#0:
library(tcltk)
rWISHPROG <- "wish83"
rmess<-function(typ=0,fns="",...){
  if(typ==0)          cat(paste(...,"\n"))
  if(typ=="message")  cat(paste(fns,"- message:",...,"\n"))
  if(typ=="error")    cat(paste(fns,"- error:",...,"\n"))
  if(typ=="print")    print(...)
  if(exists("rdebug")){
    if(typ=="fstart")   cat(paste(fns,"- start:",...,"\n"))
    if(typ=="fend")     cat(paste(fns,"- end:",...,"\n"))
    if(typ=="debug")    cat(paste(fns,"- debug point:",...,"\n"))
  }
}

rversion<-function(info){
  rmess("fstart","rversion")
  if(!missing(info)) return("rrevive-Funktionen, pw200211012000/14112000")

  if(exists("version")){
    h<-version
    rmess("fend","rversion")
    if(substring(h$os,1,7)=="Windows")                 return("R-win")
    if(substring(h$os,1,5)=="Win32")                   return("R-win"  )
    if(substring(h$os,1,4)=="hpux" &&
       (!is.null(h$language))      && h$language=="R") return("R-hpux")
    if(version$os=="MS Windows 3.1")                   return("S-win")
    if(substring(h$os,1,5)=="HP-UX")                   return("S-hpux")
  }
  return("relax")
  rmess("fend","rversion")
}
if(!exists("system"))system<-switch(rversion(),"S-hpux"=unix,"S-win"  =dos )


# .First.lib<-function(rr.pfad,name)
rREADME<-function()
{
  cat("=================================================\n")
  cat("               R-REVIVE-Module                   \n")
  cat(" Module zur Arbeit mit wiederbelebbaren Material \n")
  cat("_________________________________________________\n")
  cat("    Statistik/Informatik, WIWI, Uni Bielefeld    \n")
  cat("       email:  pwolf@wiwi.uni-bielefeld.de       \n")
  cat("  ",rversion("info"),rversion(),                "\n")
  cat("_________________________________________________\n")
  cat("-> Zur Aktivierung der Tcl/Tk-Steuerungfunktion  \n")
  cat("   ist die Funktion  rtcl  zu starten. \n")
  cat("Eingabe:   rtcl() \n")
  cat("ACHTUNG: rtcl setzt die Existenz von Tcl/Tk voraus!\n")
  cat("         auf rWISHPROG muss die vorhandene Wish stehen!\n")
  cat("         aktuelle Setzung: \"wish83\",  siehe auch:\n")
  cat("         http://www.scriptics.com/products/tcltk\n\n")
  cat("-> rreset() setzt R-REVIVE in den Anfangszustand.\n")
  cat("-> rdemo()  zeigt eine kleine Demo.              \n")
  cat("-> riq()    listet Material zum Oeffnenn.        \n")
  cat("-> rh()     listet Minimalhilfe.                 \n")
  cat("-> q()      quittet R/im Zweifel nicht speichern.\n")
  cat("_________________________________________________\n")
  print( rversion("info") )
  return()

  rrstuff<-rfind()
  h<-unlist(lapply(strsplit(search(),":"),"[",2)); h<-h[(!is.na(h))&h!="rr"]
  if(!all(is.na(match(rrstuff[,2],h))))return()

  cat("Es wurden folgende Bibliotheken gefunden, die\n")
  cat("wiederbelebbare Materialien enthalten.\n")
  if(length(rrstuff)==0) return("Es wurden keine Bibliotheken gefunden!")
  rrstuff<-rrstuff[!duplicated(rrstuff[,2]),1:3,drop=F]; h.r<-NULL
  for(i in 1:length(rrstuff[,2]))h.r<-c(h.r,rexistsl(rrstuff[i,2],rrstuff[i,3]))
  rrstuff<-rrstuff[h.r,,drop=F]
  if(length(rrstuff)>0){
    cat("Welche BIBLIOTHEKEN wollen Sie noch laden (0 = keine) ?\n")
    cat("",paste(seq(rrstuff[,2]),":",rrstuff[,2],"\n",sep=""));cat("Selection:")
    hh.r<-readline()
    if(nchar(hh.r)>0){
      hh.r<-substring(hh.r,1:nchar(hh.r),1:nchar(hh.r));hh.r[hh.r==" "]<-","
      hh.r<-c("c(",hh.r,",0)"); hh.r<-eval(parse(text=paste(hh.r,collapse="")))
      hh.r<-hh.r[0<hh.r]
    } else hh.r<-NULL

    cat("_________________________________________________\n")
    if(!is.null(hh.r))
      for(i in hh.r){
        eval(parse(text=paste( "library(name='",rrstuff[i,2],"')",sep="" )))
      }
    cat("Angeschlossene Bibliotheken:\n"); print(search())
    cat("_________________________________________________\n")
  }

  cat("Initialisierung der rr-Module beendet!\n")
  cat("Sie koennen nun ein Material aussuchen und dann\n")
  cat("ihre Arbeit mit Hilfe von   rtcl()    starten!\n")
  cat("=================================================\n")
  riq()

}

rexistsl<-function(name,loc){
 rmess("fbegin","rexistsl")
 switch(rversion(),
   "R-win"  =return(4<length(system(
              paste("command.com /c dir ",loc,"\\",name,"\\r\\",name, sep=""),
              intern=T,invisible=T ))),
   "R-hpux" =return(0<length(system(paste("ls  ",loc,"/", name,"/R/",  name,
                                        sep=""),T))))
}


rfind<-function(){
  rmess("fbegin","rfind")
  h<-NULL
  mat<-rbind(c("staff:", "lib:", "lib.loc:", "path:"))
  switch(rversion()
    ,"R-win"  ={
                 for (i in .lib.loc)
                   h<-c(h,system(paste("command.com /c dir ",i,"\\*.sch /s /w",sep=""),
                                 intern=T,invisible=T))
                 h<-h[""!=h];h<-h[" "!= substring(h,1,1)];h<-h["Date"!=substring(h,1,4)]
                 while (0 < length(h)) {
                   h1<-h[1];h<-h[-1];h1.ind<-1:nchar(h1);h1.el<-substring(h1,h1.ind,h1.ind)
                   if(any("\\" == h1.el)){
                     path   <-rev(unlist(strsplit(h1, " ")))[1]
                     lib.loc<-substring(path, 1, nchar(path) - 4)
                     lib    <-rev(unlist(strsplit(lib.loc, "\\")))[1]
                     lib.loc<-substring(lib.loc,1,nchar(lib.loc)-1-nchar(lib))
                   }else{
                     h1.el[h1.el=="\t"]<-" ";h1.el<-h1.el[h1.el!=" "|c(h1.el[-1]," ")!=" "]
                     h1<-paste(h1.el,collapse = "");h1<-unlist(strsplit(h1, " "))
                     mat <- rbind(mat, cbind(h1, lib, lib.loc, path))
                   }
                 }
               } # end of switch R-win

    ,"R-hpux" ={
                 for(lib.loc in .lib.loc){
                   h<-c(h,system(paste("find ",lib.loc,' -name "*.sch"',sep=""),T))
                   while ((!is.null(h)) && 0 < length(h)) {
                     h1<-h[1];h<-h[-1];h1.el<-unlist(strsplit(h1,"/"));n<-length(h1.el)
                     path<-paste(lib.loc,h1.el[n-2],h1.el[n-1],sep="/")
                     lib<-h1.el[n-2]; m.name  <- h1.el[n]
                     mat <- rbind(mat, c(m.name, lib, lib.loc, path))
                   }
                 }
               } # end of switch R-hpux

  )
  dimnames(mat) <- list(NULL, c("stuff:", "lib:", "lib.loc:", "path:"))
  return(mat <- mat[-1, , drop = F])
}

rsink<-function(file,append=T){
  rmess("fstart","rsink")
  if(!missing(file)){
    sink("s.tmp")
  }else{
    sink()
    h.r<-scan("s.tmp","",sep="\n")
    write(h.r,file=out.file,append=append)
  }
  rmess("fend","rsink")
}


rS<-function(){
  rmess("fstart","rS")
  if(all(search()!="r.info")) rR()
  r.info<<-eval(parse(text=paste( 'list(',
            ' "cmds"       =cmds,        ', ' "in.file"    =in.file,     ',
            ' "out.file"   =out.file,    ', ' "editor"     =editor,      ',
            ' "csize"      =csize,       ', ' "osize"      =osize,       ',
            ' "ps.height"  =ps.height,   ', ' "ps.width"   =ps.width,    ',
            ' "c.choice.r" =c.choice.r,  ', ' "o.flag.r"   =o.flag.r,    ',
            ' "r.flag.r"   =r.flag.r,    ', ' "l.cmd.r"    =l.cmd.r,     ',
            ' "l.sec.r"    =l.sec.r,     ', ' "l.sec.no.r" =l.sec.no.r,  ',
            ' "sec.lines.r"=sec.lines.r, ', ' "sch.r"      =sch.r,       ',
            ' "sch.flag.r" =sch.flag.r,  ', ' "sch.i.r"    =sch.i.r,     ',
            ' "history.r"  =history.r,   ', ' "choice.r"   =choice.r,    ',
            ' "command.r"  =command.r    ',
            ' )')) ,
            switch(rversion()
                  ,"R-win"  =sys.frame(sys.parent())
                  ,"R-hpux" =sys.frame(sys.parent())
                  ,"S-hpux" =sys.parent(1)
            )
           )
  if(rversion()=="S-hpux") synchronize()
  rR()
  rmess("fend","rS")
}


rR<-function(){
  rmess("fstart","rR")
  if(!exists("r.info")) rreset() else {
    h.r<-search()=="r.info"; if(any(h.r)) detach(,(1:length(h.r))[h.r])
    attach(r.info)
  }
  rmess("fend","rR")
}

rreset<-function(){
  rmess("fstart","rreset")
  h.r<-search()=="r.info"; if(any(h.r)) detach(,(1:length(h.r))[h.r])
  r.info<<-list(
              "cmds"       ="",           "in.file"    ="noinput",
              "out.file"   ="noreport",
              "editor"     =switch(rversion()
                                  ,"R-win"  ="edit"
                                  ,"R-hpux" ="nedit"
                                  ,"S-hpux" ="nedit"),
              "csize"      =50,           "osize"      =50,
              "ps.height"  =8,            "ps.width"   =8,
              "c.choice.r" ="-",          "o.flag.r"   =F,
              "r.flag.r"   =F,            "l.cmd.r"    ="",
              "l.sec.r"    ="",           "l.sec.no.r" =-1,
              "sec.lines.r"=c(0,0),       "sch.r"      ="nochunks",
              "sch.flag.r" =F,            "sch.i.r"    =0,
              "history.r"  =NULL,         "choice.r"   ="",
              "command.r"  ="" )
  attach(r.info)
  rmess("fend","rreset")
}

rexit<-function(){
 rmess("fstart","rexit","reexit: loescht Zustand")
 h.r<-search()=="r.info"; if(any(h.r)) detach(,(1:length(h.r))[h.r])
 h.r<-ls(pos=1)=="r.info"
 if(any(h.r))switch(rversion()
                  ,"R-win"  =rm("r.info",envir=pos.to.env(1))
                  ,"R-hpux" =rm("r.info",envir=pos.to.env(1))
                  ,"S-hpux" =rm("r.info",where=1)
             )
 rmess("fend","rexit","Zustand geloescht")
}

rcfg<-function(){
  rmess("fstart","rcfg")
  h.r<-c(
    paste('editor       <-"',editor,'" # (NICHT-EDDY!)-Editor\n',sep=""),
    paste("csize        <-",csize," # Umfang des Reports von Kommandos\n"),
    paste("osize        <-",osize," # Umfang des Reports von Output\n"),
    paste("ps.height    <-",ps.height," # Entwurfs-Hoehe von PS-Bildern\n"),
    paste("ps.width     <-",ps.width,"  # Entwurfs-Breite von PS-Bildern\n"))
  cat(h.r,file="s.tmp")
  switch(rversion()
        ,"R-win"  =system(paste(editor,"s.tmp"),T)
        ,"R-hpux" =system(paste(editor,"s.tmp"),T)
        ,"S-hpux" =unix(paste(editor,"s.tmp"),,T)
  )
  h.r<-scan("s.tmp","",sep="\n"); eval(parse(text=h.r))
  rS()
  rmess("fend","rcfg")
}

ri<-function(in.file="noinput"){
  rmess("fstart","ri","Datei:",in.file)
  if(!is.character(in.file)) in.file<-as.character(substitude(in.file))
  if(!exists("r.info")){
    h.r<-in.file; rreset(); in.file<-h.r
  }

  if(sch.flag.r<-(in.file!="noinput")){
    h.r<-substring(in.file,nchar(in.file)-3)
    if(h.r!=".sch"&h.r!=".SCH") in.file<-paste(in.file,".sch",sep="")
    sch.r<-scan(file=in.file, what=as.list(""),sep="\n")[[1]]

    rowno.r<-1:length(sch.r)
    h.r<-"#"==substring(sch.r,1,1) & 6 > nchar(sch.r)
    rowno.r<-rowno.r[h.r];
    com.r<-sch.r[h.r]

    h.r<-":"==substring(com.r,2,2)
    comh.r<-com.r[h.r]
    comh.r<-substring(comh.r,3,nchar(comh.r))
    sch.i.r<-cbind(-as.numeric(comh.r),rowno.r[h.r])
    com.r<-com.r[!h.r]
    rowno.r<-rowno.r[!h.r]

    h.r<-nchar(com.r)
    h.r<-":"==substring(com.r,h.r,h.r)
    comh.r<-com.r[h.r]
    comh.r<-substring(comh.r,2,nchar(comh.r)-1)
    sch.i.r<-rbind(cbind(as.numeric(comh.r),rowno.r[h.r]),sch.i.r)

    sch.i.r<-sch.i.r[order(abs(sch.i.r[,2])),]


    if(length(sch.i.r)==0){
      rmess("error","ri","File does not contain a revweb paper!")
    }

    l.sec.r    <-""
    l.sec.no.r <--1
    sec.lines.r<-c(0,0)
    rmess("debug","ri","sch.r",sch.r[1:min(25,length(sch.r))])
    rS()
    rs(0)

  }else rS()
  rmess("fend","ri","Datei:",in.file)
}

riq<-function(){
  rmess("fstart","riq")
  rrstuff<-rfind()
  h.r<-substring("                ",1,18-nchar(rrstuff[,1]))
  rmess(,,"Welches Material wollen Sie bearbeiten (0 = kein) ?")
  cat("",paste(seq(h.r),":",rrstuff[,1],h.r,"Ort:",rrstuff[,4],"\n",sep=""))
  rmess(,,"Selection:")
  hh.r<-readline()
  if(nchar(hh.r)>0){
    hh.r<-substring(hh.r,1:nchar(hh.r),1:nchar(hh.r));hh.r[hh.r==" "]<-","
    hh.r<-c("c(",hh.r,",0)"); hh.r<-eval(parse(text=paste(hh.r,collapse="")))
    hh.r<-hh.r[0<hh.r]
  } else hh.r<-NULL

  i<-hh.r
  if(is.null(i)||0==i) return(invisible(rrstuff))
  rmess(,,"-------------------------------------------------")
  if(rexistsl(rrstuff[i,2],rrstuff[i,3])){
    eval(parse(text=paste(
      "library(name='",rrstuff[i,2],"')",sep=""
    )))
  }
  sep<-switch(rversion() ,"R-win"  ="\\" ,"R-hpux" ="/", "S-hpux" ="/")
  ri(paste(rrstuff[i,4],rrstuff[i,1],sep=sep))
  rmess("fend","riq"); invisible(rrstuff[i,])
}


rs<-function(choice.r){
  rmess("fstart","rs","evaluate section",choice.r)
  if(is.character(choice.r)) choice.r<-eval(parse(text=choice.r))
  l.sec.no.r <-as.numeric(choice.r)[1]
  h.r<-sch.i.r[l.sec.no.r==abs(sch.i.r[,1]),2]
  if(length(h.r)>=2){
    sec.lines.r<-sort(h.r)[1:2]
    l.cmd.r<-sch.r[sec.lines.r[1]:sec.lines.r[2]]
    rmess("debug","rs","commands",l.cmd.r)
    switch(rversion()
           ,"R-win"  =eval(parse(text=l.cmd.r),envir=pos.to.env(1))
           ,"R-hpux" =eval(parse(text=l.cmd.r),envir=pos.to.env(1))
           ,"S-hpux" =eval(parse(text=l.cmd.r),1)
    )
    if(length(l.sec.no.r)<40)
      history.r<-c(list(c(paste("##",in.file,"no",l.sec.no.r),
                          l.sec.r<-l.cmd.r)), history.r)
    rS()
    rcmds()
  }else{
    rmess("error","rs",paste("Kein Code zu Nummer",choice.r,"gefunden!"))
    rmess("fend","rs","Sektion nicht existent")
  }
  rmess("fend","rs")
}

rss<-function(choice.r){
  rmess("fstart","rss","evaluate sections",choice.r)
  if(is.character(choice.r)) choice.r<-eval(parse(text=choice.r))
  for(h.r in choice.r) rs(h.r)
  rmess("fend","rss")
}

rn<-function(){
  rmess("fstart","rn")
  h.r<-min(abs(sch.i.r[max(0,l.sec.no.r)<sch.i.r[,1],1]))
  if(!is.na(h.r)){
    rmess("message","rn","evaluate section",h.r)
    rs(h.r)
  }else{
    rmess("message","rn"," --> no code chunk found!")
  }
  rmess("fend","rn")
}

re<-function(choice.r){
  rmess("fstart","re")
  if(choice.r!=" "&&choice.r!=""){
    rmess("message","re",":evaluate user cmd:", choice.r)
    l.cmd.r<-as.character(choice.r)
    history.r<-c(list(c("## error:>",l.cmd.r)),history.r)    #<-
    rS()
    h.r<-switch(rversion()
               ,"R-win"  =eval(parse(text=l.cmd.r),envir=pos.to.env(1))
               ,"R-hpux" =eval(parse(text=l.cmd.r),envir=pos.to.env(1))
               ,"S-hpux" =eval(parse(text=l.cmd.r),1)
         )
    if(!is.null(h.r)) print(h.r)
    history.r[[1]]<-  c("## >",l.sec.r<-l.cmd.r)             #<-
  # history.r<-c(list(c("## >",l.sec.r<-l.cmd.r)),history.r) #<-
    rS()
    rcmds()
  }
  rmess("fend","re")
}

repr<-function(choice.r){
  rmess("fstart","repr")
  if(choice.r!=" "&&choice.r!=""){
    rmess("message","re",":evaluate user cmd:", choice.r)
    l.cmd.r<-as.character(choice.r)
    l.cmd.r[length(l.cmd.r)]<-paste("print((",l.cmd.r[length(l.cmd.r)],"))")
    history.r<-c(list(c("## error:>",l.cmd.r)),history.r)    #<-
    rS()
    h.r<-switch(rversion()
               ,"R-win"  =eval(parse(text=l.cmd.r),envir=pos.to.env(1))
               ,"R-hpux" =eval(parse(text=l.cmd.r),envir=pos.to.env(1))
               ,"S-hpux" =eval(parse(text=l.cmd.r),1)
         )
    if(!is.null(h.r)) print(h.r)
    history.r[[1]]<-  c("## >",l.sec.r<-l.cmd.r)             #<-
    rS()
  }
  rmess("fend","repr")
}


reh<-function(choice.r){
  rmess("fstart","reh")
  if(missing(choice.r)) choice.r<-1
  if(is.null(history.r)){
    rmess("error","reh","keine Historie vorhanden")
    rmess("fend","reh")
    return(choice.r)
  }
  if(choice.r>length(history.r)){
    rmess("error","reh","Historie zu kurz")
    rmess("fend","reh")
    return(choice.r)
  }
  choice.r<-unlist(history.r[[choice.r]])
  re(choice.r)
  rmess("fend","reh")
  invisible(choice.r)
}

rehq<-function(choice.r){
  rmess("fstart","rehq")
  if(missing(choice.r)) hh.r<-20 else hh.r<-choice.r
  if(is.null(history.r)){
    choice.r<-" "
  }else{
    choice.r<-NULL
    for(i in history.r[1:min(hh.r,length(history.r))]){
      h.r<-as.character(unlist(i))
      h.r<-ifelse("##"==substring(h.r,1,min(2,nchar(h.r))) & nchar(h.r)>10,
                  substring(h.r,nchar(h.r)-17, nchar(h.r)), h.r)
      choice.r<-c(choice.r,paste(h.r[1:min(4,length(h.r))],collapse=";"))
    }
    h.r<-menu(choice.r)
    if(0!=h.r) choice.r<-unlist(history.r[[h.r]]) else choice.r<-" "
  }
  re(choice.r)
  rmess("fend","rehq")
  invisible(choice.r)
}

req<-function(){
  rmess("fstart","req")
  rmess("message","req","expression?")
  choice.r<-readline()
  if(nchar(choice.r)>0) re(choice.r)
  rmess("fend","req")
  invisible(choice.r)
}


reqq<-function(){
  rmess("fstart","reqq")
  repeat{
    if(nchar((h.r<-req()))==0) break
  }
  rmess("fend","reqq")
  invisible(h.r)
}

rmod<-function(choice.r){
  rmess("fstart","rmod")
  if(missing(choice.r)) choice.r<-1
  if(is.character(choice.r)) choice.r<-eval(parse(text=choice.r))
  if(length(history.r)<choice.r){
      rmess("error","rmod","Abbruch, Anweisung nicht existent")
      rmess("fend","rmod","Abbruch, Anweisung nicht da"); return()
  }
  write(history.r[[choice.r]],file="s.tmp")
  switch(rversion()
        ,"R-win"  =system(paste(editor,"s.tmp"),T)
        ,"R-hpux" =system(paste(editor,"s.tmp"),T)
        ,"S-hpux" =unix(paste(editor,"s.tmp"),,T)
  )
  choice.r<-scan("s.tmp","",sep="\n")
  re(choice.r)
  rmess("fend","rmod")
}

rmodq<-function(){
  rmess("fstart","rmodq")
  if(is.null(history.r)){
    choice.r<-" "
  }else{
    choice.r<-NULL
    for(i in history.r[1:min(20,length(history.r))]){
      h.r<-as.character(unlist(i))
      h.r<-ifelse("##"==substring(h.r,1,min(2,nchar(h.r))) & nchar(h.r)>10,
                  substring(h.r,nchar(h.r)-17, nchar(h.r)), h.r)
      choice.r<-c(choice.r,paste(h.r[1:min(4,length(h.r))],collapse=";"))
    }
    choice.r<-menu(choice.r)
  }
  if(choice.r!=0) rmod(choice.r)
  rmess("fend","rmodq")
  invisible(choice.r)
}

rmods<-function(choice.r){
  rmess("fstart","rmods","modify section",choice.r)
  if(missing(choice.r)||choice.r==" "){
    rmess("error","rmods","ERROR: ungeeigneter Parameter")
    rmess("fend","rmods","ERROR: ungeeigneter Parameter")
    return()
  }
  if(is.character(choice.r)) choice.r<-eval(parse(text=choice.r))
  l.sec.no.r <-as.numeric(choice.r)[1]
  sec.lines.r<-sort(sch.i.r[l.sec.no.r==abs(sch.i.r[,1]),2])[1:2]
  if(length(sec.lines.r)>=2){
    l.cmd.r<-sch.r[sec.lines.r[1]:sec.lines.r[2]]
    write(l.cmd.r,file="s.tmp")
    switch(rversion()
          ,"R-win"  =system(paste(editor,"s.tmp"),T)
          ,"R-hpux" =system(paste(editor,"s.tmp"),T)
          ,"S-hpux" =unix(paste(editor,"s.tmp"),,T)
    )
    choice.r<-scan("s.tmp","",sep="\n")
    re(choice.r)
  }
  rmess("fend","rmods")
}

rri<-function(out.file="report.rev"){
  rmess("fstart","rri")
  if(nchar(out.file)==0) out.file<-"noreport"
  h.r<-substring(out.file,1:nchar(out.file),1:nchar(out.file))
  if(all(h.r!=".")&&out.file!="noreport")
    out.file<-paste(out.file,".rev",sep="")
  rS()
  rmess("fend","rri")
}
rriq<-function(){
  rmess("fstart","rriq")
  rmess("message","rriq","Name der Reportdatei?")
  out.file<-readline()
  h.r<-substring(out.file,1:nchar(out.file),1:nchar(out.file))
  out.file<-paste(h.r[" "!=h.r],collapse="")
  rri(out.file)
  rmess("fend","rriq")
  invisible(out.file)
}

rra<-function(choice.r){
  rmess("fstart","rra")
  if(nchar(choice.r)==0){
    rmess("error","rra","Text leer!")
    rmess("fend","rra","wegen leerem Text abgebrochen!"); break
  }
  rsink(out.file,append=T)
  cat("@\n"); for(h.r in choice.r){ cat(h.r); cat("\n") }
  rsink()
  rmess("fend","rra")
}
rraq<-function(){
  rmess("fstart","rraq")
  cat("Report-Text?\n"); rra(h.r<-readline())
  rmess("fend","rraq")
  invisible(h.r)
}

rr<-function(choice.r){
  rmess("fstart","rr")
  if(missing(choice.r)){
    if(length(history.r)==0){
      rmess("error","rr","kein Statement protokollierbar!")
      rmess("fend","rr","ohne Protokoll abgebrochent!"); return()
    }
    choice.r<-history.r[[1]]
  }

  if(csize!=0){
    if(csize>0) h.r<-choice.r[1:min(csize,length(choice.r))]
    if(csize<0) h.r<-rev(rev(choice.r)[1:min(-csize,length(choice.r))])
    rsink(out.file,append=T)
    cat("@\n<","<*>>=\n",sep="");for(i in choice.r)cat(paste(i,"\n"));cat("@\n")
    rsink()
  }

  if(osize!=0){
    h.r<-choice.r[1]
    if(nchar(h.r)>9 && "## error:>"==substring(h.r,1,10)){
      rmess("error","rr","fehlerhaftes Statement, nicht protokollierbar!")
      rmess("fend","rr","Protokollversuch mit fehlerhaften Statement!");return()
    }
    sink("s.tmp")
    h.r<-switch(rversion()
               ,"R-win"  =eval(parse(text=choice.r),envir=pos.to.env(1))
               ,"R-hpux" =eval(parse(text=choice.r),envir=pos.to.env(1))
               ,"S-hpux" =eval(parse(text=choice.r),1)
         )
    sink(); h.r<-scan("s.tmp","",sep="\n")
    if(length(h.r)>0){
      if(csize>0) h.r<-h.r[1:min(csize,length(h.r))]
      if(csize<0) h.r<-rev(rev(h.r)[1:min(-csize,length(h.r))])
      rsink("s.tmp")
      cat("@\n\\begin{verbatim}\n")
      for(i in h.r) cat(paste(i,"\n"))
      cat("\n\\end{verbatim}\n")
      rsink()
    }
  }

  rmess("fend","rr")
  invisible(choice.r)
}

rrss<-function(choice.r){
  rmess("fstart","rrss")
  if(missing(choice.r))choice.r<-l.sec.no.r
  if(is.character(choice.r)) choice.r<-eval(parse(text=choice.r))
  for(i in choice.r){
    l.sec.no.r <-as.numeric(i)[1]
    sec.lines.r<-sort(sch.i.r[l.sec.no.r==abs(sch.i.r[,1]),2])[1:2]
    if(length(sec.lines.r)>=2){
      h.r<-sch.r[sec.lines.r[1]:sec.lines.r[2]]
      rr(h.r)
    }
  }
  rmess("fend","rrss")
  invisible(h.r)
}

rrhh<-function(choice.r){
  rmess("fstart","rrhh")
  if(missing(choice.r)){ choice.r<-1 }
  if(is.character(choice.r)) choice.r<-eval(parse(text=choice.r))
  for(i in choice.r){
    l.sec.no.r <-as.numeric(i)[1]
    if(length(history.r)<i){
      rmess("error","rrhh","Abbruch, da Historie leer"); next
    }
    h.r<-history.r[[i]]
    rmess("debug","rrhh","commands",h.r)
    rr(h.r)
  }
  rmess("fend","rrhh")
  invisible(h.r)
}

rrhq<-function(){
  rmess("fstart","rrhq")
  if(is.null(history.r)){
    choice.r<-" "
  }else{
    choice.r<-NULL
    for(i in history.r[1:min(20,length(history.r))]){
      h.r<-as.character(unlist(i))
      choice.r<-c(choice.r,paste(h.r[1:min(4,length(h.r))],collapse=";"))
    }
    h.r<-menu(choice.r)
    if(0!=h.r) choice.r<-unlist(history.r[[h.r]]) else choice.r<-" "
  }
  rr(choice.r)
  rmess("fend","rrhq")
  invisible(choice.r)
}

rrhd<-function(){
  rmess("fstart","rrhd")
  rsink(out.file,append=T)
  cat("@\n\\begin{verbatim}\n")
  print(history.r)
  cat("\\end{verbatim}\n")
  rsink()
  rmess("fend","rrhd")
}


rrps<-function(name,choice.r){
  rmess("fstart","rrps")
  if(!missing(name)){
    h.r<-substring(name,1:nchar(name),1:nchar(name))
    if(!any("."==h.r)) name<-paste(name,".ps",sep="")
    h.r<-paste(
               switch(rversion()
                     ,"R-win"  =
                       h.r<-paste(
                         system("command.com /c cd",intern=T,invisible=T),
                         name,sep="\\")
                     ,"R-hpux" =h.r<-paste(system("pwd",T),name,sep="/")
                     ,"S-hpux" =h.r<-paste(unix("pwd",,T),name,sep="/")),
               name,sep="\\")
    postscript(file=h.r,width=ps.width,height=ps.height)
    rr(choice.r)
    dev.off()
    if(out.file!="noreport"){
      rsink(out.file,append=T)
      cat("@\n\\centerline{",
          "\\psfig{",name,",width=10cm,height=8cm}}\n",sep="")
      rsink()
    }
  }else rmess("error","rrps","kein ps-Name angegeben!")
  rmess("fend","rrps")
}

rrdc<-function(name,device="postscript"){
  rmess("fstart","rrdc")
  if(!missing(name)){
    if(device=="postscript"){
      h.r<-substring(name,1:nchar(name),1:nchar(name))
      if(!any("."==h.r)) name<-paste(name,".ps",sep="")
         switch(rversion()
               ,"R-win"  =
                       h.r<-paste(
                         system("command.com /c cd",intern=T,invisible=T),
                         name,sep="\\")
               ,"R-hpux" =h.r<-paste(system("pwd",T),name,sep="/")
               ,"S-hpux" =h.r<-paste(unix("pwd",,T),name,sep="/")
         )
      dev.print(postscript,file=h.r,width=ps.width,height=ps.height)
      if(out.file!="noreport"){
        rsink(out.file,append=T)
        cat("@\n\\centerline{",
            "\\psfig{",name,",width=10cm,height=8cm}}\n",sep="")
        rsink()
      }
    }
    if(device=="pictex"){
      h.r<-substring(name,1:nchar(name),1:nchar(name))
      if(!any("."==h.r)) name<-paste(name,".tex",sep="")
         switch(rversion()
               ,"R-win"  =
                       h.r<-paste(
                         system("command.com /c cd",intern=T,invisible=T),
                         name,sep="\\")
               ,"R-hpux" =h.r<-paste(system("pwd",T),name,sep="/")
               ,"S-hpux" =h.r<-paste(unix("pwd",,T),name,sep="/")
         )
      dev.print(pictex,file=h.r,width=ps.width,height=ps.height)
      if(out.file!="noreport"){
        rsink(out.file,append=T)
        cat("@\n\\centerline{\\include{",name,"}}\n")
        rsink()
      }
    }
  }else rmess("error","rrps","kein ps-Name angegeben!")
  rmess("fend","rrdc")
}


rrdcq<-function(){
  rmess("fstart","rrdcq")
  rmess("message","rrdcq","Name fuer die PS-Graphik?")
  choice.r<-readline()
  rrdc(choice.r)
  rmess("fend","rrdcq")
  invisible(choice.r)
}


rred<-function(choice.r){
  rmess("fstart","rred")
  if(missing(choice.r)){
    choice.r<-out.file
    if(choice.r=="noreport") rri()
  }
  switch(rversion()
           ,"R-win"  =system(paste(editor,out.file),T)
           ,"R-hpux" =system(paste(editor,out.file),T)
           ,"S-hpux" =unix(paste(editor,out.file),,T)
  )
  rmess("fend","rred")
}

rcmds<-function(){
  rmess("fstart","rcmds")
  repeat{
    if(length(cmds)==0) break
    h.r<-cmds[1]; cmds<-cmds[-1]; rS(); rm(cmds)
    command.r<-substring(h.r,1,1); choice.r<-substring(h.r,2)
    if(command.r=="s") rss(eval(parse(text=choice.r)))
    if(command.r==">") re(choice.r)
    if(command.r=="i") ri(choice.r)
    if(command.r=="r") rri(choice.r)
  }
  rmess("fend","rcmds")
}



rM<-function(){
  rmess("fstart","rM")
  choice.r<-T
  while(choice.r){
    items<-c("exit Menue",
            "close rrevive",      "reset",
            "input file",         "next section",
            "section ?",          "evaluate cmd",
            "evaluate some cmds", "reevaluate cmd",
            "modify statement",   "initialize report",
            "report from history","copy plot",
            "help",               "version")
    switch(max(1,menu(items)),
           {choice.r<-F},
           {rexit()},
           {rreset()},
           {rmess("message","rM","file name?");h.r<-readline();ri(h.r);rs(0)},
           {rn()},
           {rmess("message","rM","section no?");h.r<-readline();rss(h.r)},
           {req()},
           {reqq()},
           {rehq()},
           {rmodq()},
           {rriq()},
           {rmess("message","rM","choose item");h.r<-readline();rrhh(h.r)},
           {rrdcq()},
           {rh()},
           {print(rversion("zeige Version!"))}
    )
  }
  rmess("fend","rM")
}

rtcl<-function(){
  sink()
  restart()    #  11.01.2000
  rmess("fstart","rtcl")
  rmess("debug","rtcl","1")
  if(!exists("r.info")) rreset()
  if(!exists("in.file")) rR()
  tclcmds<-list(NULL
    ,start=c(NULL
    ,'# Tcl/Tk Leisten-Start fuer r-revive Menue'
    ,'# Ueberschrift und Position'
    ,' '
    ,'wm title    . "R-revive-menue 10/1998"'
    ,'wm geometry . +0+0'
    ,'# Ende-Prozedur nach Knopfdruck'
    ,'proc fertig {Command Choice} {'
    ,'              set Datei [open "s.tmp" w+]'
    ,'              puts $Datei $Command'
    ,'              puts $Datei $Choice'
    ,'              close $Datei'
    ,'              exit'
    ,'}'
    ,'# Grobaufbau der Leiste durch zwei frame-Zeilen'
    ,'frame       .menu'
    ,'frame       .inputmess'
    ,'# einige Variablensetzungen'
    ,'set         buttonlength 1'
    ,'set         entrylength 3'
    ,'set         messlength 40'
    ,'set         Choice " "'
    ,'# Eingabefeld- und Textausgabefelddefinition'
    ,'entry       .eingabe           -width $entrylength -textvariable Choice'
    ,'label       .message -text " " -width $messlength')

    ,bh=c(NULL
    ,'button .bh -text "h" -width $buttonlength \\'
    ,'                     -command {'
    ,'                               set Command "h"'
    ,'                               fertig $Command $Choice'
    ,'                     }'
    ,'bind   .bh <Enter> { .message config -text "h: Hilfe" }'
    ,'pack   .bh -in .menu -side left  -anchor w')

    ,blower=c(NULL
    ,'button .blower   -text "<" -width $buttonlength \\'
    ,'                 -command { .message config -text "<: Anweisung?"'
    ,'                            .message config -width 20'
    ,'                            .eingabe config -width 45'
    ,'                            pack forget .menu'
    ,'                            pack .eingabe -in .inputmess -side left'
    ,'                            focus .eingabe'
    ,'                            set Command "<"'
    ,'                 }'
    ,'bind   .blower <Enter> {'
    ,'           .message config -text "<: manuelle Eingabe einer Anweisung"'
    ,'}'
    ,'pack   .blower -in .menu -side left  -anchor w')

    ,bgreater=c(NULL
    ,'button .bgreater -text ">" -width $buttonlength \\'
    ,'                 -command { '
    ,'                               set Command ">"'
    ,'                               fertig $Command $Choice'
    ,'                 }'
    ,'bind   .bgreater <Enter> {'
    ,'           .message config -text ">: mehrere manuelle Eingaben"'
    ,'}'
    ,'pack   .bgreater -in .menu -side left  -anchor w')

    ,bws=c(NULL
    ,'button .bws   -text "ws" -width $buttonlength \\'
    ,'              -command {'
    ,'                               set Command "ws"'
    ,'                               fertig $Command $Choice'
    ,'              }'
    ,'bind   .bws   <Enter> {'
    ,'           .message config -text "ws: Wiederholung der letzten Sequenz"'
    ,'}'
    ,'pack   .bws   -in .menu -side left  -anchor w')

    ,bwh=c(NULL
    ,'button .bwh -text "wh" -width $buttonlength \\'
    ,'            -command {'
    ,'                               set Command "wh"'
    ,'                               set Choice  "?"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .bwh <Enter> {'
    ,'         .message config -text "wh: Wiederholung aus Historie" }'
    ,'pack   .bwh -in .menu -side left  -anchor w')

    ,bm=c(NULL
    ,'button .bm  -text "m" -width $buttonlength  \\'
    ,'            -command {'
    ,'                               set Command "m"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .bm  <Enter> {'
    ,'           .message config -text "m: Modifikation der letzten Sequenz"'
    ,'}'
    ,'pack   .bm  -in .menu -side left  -anchor w')

    ,bmh=c(NULL
    ,'button .bmh -text "mh" -width $buttonlength \\'
    ,'            -command {'
    ,'                               set Command "mh"'
    ,'                               set Choice  "?"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .bmh <Enter> {'
    ,'           .message config -text "mh: Modifikation aus Historie" }'
    ,'pack   .bmh -in .menu -side left  -anchor w')

    ,bi=c(NULL
    ,'button .bi -text "i" -width $buttonlength \\'
    ,'           -command { .message config -text "i: Dateiname?"'
    ,'                               .message config -width 20'
    ,'                               .eingabe config -width 15'
    ,'                               pack forget .menu'
    ,'                               pack .eingabe -in .inputmess -side left'
    ,'                               focus .eingabe'
    ,'                               set Command "i"'
    ,'           }'
    ,'bind   .bi <Enter> {'
    ,'           .message config -text "i: Wahl eines Input-Materials" }'
    ,'pack   .bi -in .menu -side left  -anchor w')
    ,biq=c(NULL
    ,'button .biq -text "iq" -width $buttonlength \\'
    ,'            -command {'
    ,'                               set Command "iq"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .biq <Enter> {'
    ,'           .message config -text "iq: fragt nach einer Input-Datei" }'
    ,'pack   .biq -in .menu -side left  -anchor w')

    ,bn=c(NULL
    ,' # --------------------------'
    ,'button .bn    -text "n" -width $buttonlength \\'
    ,'                    -command {'
    ,'                               set Command "n"'
    ,'                               fertig $Command $Choice'
    ,'                    }'
    ,'   bind .bn    <Enter> {'
    ,'           .message config -text "n: Ausfuehrung der naechsten Sektion"'
    ,'   }'
    ,'pack  .bn -in .menu -side left  -anchor w'
         )
    ,bpoint=c(NULL
    ,'button .bpoint -text "." -width $buttonlength \\'
    ,'               -command {'
    ,'                               set Command "."'
    ,'                               fertig $Command $Choice'
    ,'               }'
    ,'bind   .bpoint  <Enter> {'
    ,'           .message config -text ".: Wiederholung der letzten Sektion"'
    ,'   }'
    ,'pack   .bpoint -in .menu -side left  -anchor w')

    ,bs=c(NULL
    ,'button .bs -text "s" -width $buttonlength \\'
    ,'           -command { .message config -text "s: Sektions-Nummer?"'
    ,'                               .message config -width 20'
    ,'                               .eingabe config -width 15'
    ,'                               pack forget .menu'
    ,'                               pack .eingabe -in .inputmess -side left'
    ,'                               focus .eingabe'
    ,'                               set Command "s"'
    ,'           }'
    ,'bind   .bs <Enter> {'
    ,'           .message config -text "s: Wahl der naechsten Sektion(en)" }'
    ,'pack   .bs -in .menu -side left  -anchor w')

    ,bms=c(NULL
    ,'button .bms -text "ms" -width $buttonlength \\'
    ,'            -command { .message config -text "ms: Sektionsnummer?"'
    ,'                               .message config -width 20'
    ,'                               .eingabe config -width 15'
    ,'                               pack forget .menu'
    ,'                               pack .eingabe -in .inputmess -side left'
    ,'                               focus .eingabe'
    ,'                               set Command "ms"'
    ,'            }'
    ,'bind   .bms <Enter> {'
    ,'           .message config -text "ms: Modifikation einer Sektion" }'
    ,'pack   .bms -in .menu -side left  -anchor w')

    ,bRi=c(NULL
    ,'button .bRi -text "Ri" -width $buttonlength \\'
    ,'            -command { .message config -text "Ri: Dateiname?"'
    ,'                               .message config -width 20'
    ,'                               .eingabe config -width 15'
    ,'                               pack forget .menu'
    ,'                               pack .eingabe -in .inputmess -side left'
    ,'                               focus .eingabe'
    ,'                               set Command "Ri"'
    ,'            }'
    ,'bind   .bRi <Enter> {'
    ,'           .message config -text "Ri: Wahl einer Report-Datei" }'
    ,'pack   .bRi -in .menu -side left  -anchor w')

    ,bRcl=c(NULL
    ,'button .bRcl -text "Rcl" -width $buttonlength \\'
    ,'            -command {'
    ,'                               set Command "Rcl"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .bRcl <Enter> {'
    ,'           .message config -text "Rcl: Schliessen der Report-Datei" }'
    ,'pack   .bRcl -in .menu -side left  -anchor w')

    ,bRed=c(NULL
    ,'button .bRed -text "Red" -width $buttonlength \\'
    ,'            -command {'
    ,'                               set Command "Red"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .bRed <Enter> {'
    ,'           .message config -text "Red: Editieren des Reports" }'
    ,'pack   .bRed -in .menu -side left  -anchor w')

    ,bRw=c(NULL
    ,'button .bRw -text "Rw" -width $buttonlength \\'
    ,'            -command {'
    ,'                               set Command "Rw"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .bRw <Enter> {'
    ,'           .message config -text "Rw: Report durch Wiederholung" }'
    ,'pack   .bRw -in .menu -side left  -anchor w')

    ,bRwp=c(NULL
    ,'button .bRwp -text "Rwp" -width $buttonlength \\'
    ,'             -command { .message config -text "Rwp: PS- Dateiname?"'
    ,'                               .message config -width 20'
    ,'                               .eingabe config -width 15'
    ,'                               pack forget .menu'
    ,'                               pack .eingabe -in .inputmess -side left'
    ,'                               focus .eingabe'
    ,'                               set Command "Rwp"'
    ,'             }'
    ,'bind   .bRwp <Enter> {'
    ,'       .message config -text "Rwp: Report durch Wiederholung mit Plot" }'
    ,'pack   .bRwp -in .menu -side left  -anchor w')

    ,bRh=c(NULL
    ,'button .bRh -text "Rh" -width $buttonlength \\'
    ,'            -command {'
    ,'                               set Command "Rh"'
    ,'                               fertig $Command $Choice'
    ,'            }'
    ,'bind   .bRh <Enter> {'
    ,'        .message config -text "Rh: Report durch wiederholte Historie" }'
    ,'pack   .bRh -in .menu -side left  -anchor w')

    ,bRhp=c(NULL
    ,'button .bRhp -text "Rhp" -width $buttonlength \\'
    ,'             -command { .message config -text "Rhp: PS- Dateiname?"'
    ,'                               .message config -width 20'
    ,'                               .eingabe config -width 15'
    ,'                               pack forget .menu'
    ,'                               pack .eingabe -in .inputmess -side left'
    ,'                               focus .eingabe'
    ,'                               set Command "Rhp"'
    ,'             }'
    ,'bind   .bRhp <Enter> {'
    ,'        .message config -text "Rhp: Report durch wd. Historie mit Plot" }'
    ,'pack   .bRhp -in .menu -side left  -anchor w')

    ,bRp=c(NULL
    ,'button .bRp -text "Rp" -width $buttonlength \\'
    ,'            -command { .message config -text "Rp: PS-Dateiname? "'
    ,'                               .message config -width 20'
    ,'                               .eingabe config -width 15'
    ,'                               pack forget .menu'
    ,'                               pack .eingabe -in .inputmess -side left'
    ,'                               focus .eingabe'
    ,'                               set Command "Rp"'
    ,'            }'
    ,'bind   .bRp <Enter> {'
    ,'           .message config -text "Rp: Report durch Kopie des Plots" }'
    ,'pack   .bRp -in .menu -side left  -anchor w')

    ,bRhd=c(NULL
    ,'button .bRhd -text "Rhd" -width $buttonlength \\'
    ,'             -command {'
    ,'                               set Command "Rhd"'
    ,'                               fertig $Command $Choice'
    ,'             }'
    ,'bind   .bRhd <Enter> {'
    ,'        .message config -text "Rhd: kompletter Dump der Historie" }'
    ,'pack   .bRhd -in .menu -side left  -anchor w')

    ,bcfg=c(NULL
    ,'button .bcfg -text "Cfg" -width $buttonlength \\'
    ,'             -command {'
    ,'                               set Command "Cfg"'
    ,'                               fertig $Command $Choice'
    ,'             }'
    ,'bind   .bcfg <Enter> {'
    ,'           .message config -text "Cfg: Konfigurationsparameter aendern" }'
    ,'pack   .bcfg -in .menu -side left  -anchor w')

    ,bq=c(NULL
    ,'button .bq -text "q" -width $buttonlength \\'
    ,'           -command {'
    ,'                               set Command "q"'
    ,'                               fertig $Command $Choice'
    ,'           }'
    ,'bind   .bq <Enter> {'
    ,'           .message config -text "quit Tk-Menue" }'
    ,'pack   .bq -in .menu -side left  -anchor w')


    ,secno=" "

    ,eingabe='bind  .eingabe <Return> { fertig $Command $Choice }'

    ,pack=c(NULL
    ,'# Beendigung des Menueaufbaus'
    ,'pack   .menu .inputmess -anchor w'
    ,'pack   .message -in .inputmess -side left   -anchor w')


  )
  tclcmds<-lapply(tclcmds,paste,"\n",sep="")
  repeat{
    h.r<-in.file
    h.r<-substring(h.r,1:nchar(h.r),1:nchar(h.r))
    if(any(h.r=="\\")) h.r[h.r=="\\"]<-"\\\\"
    h.r<-paste(h.r,collapse="")
    tclcmds$secno<-
        c(if(exists("l.sec.no.r")){
            c(paste('label .secnr -text "',h.r,'-Nr:',l.sec.no.r,'"\n'),
              'pack  .secnr -in .inputmess -side left -anchor w\n'
            )
          }else{
            c(paste('label .secnr -text ',h.r,'-Nr:',0,'"\n'),
              'pack  .secnr -in .inputmess -side left -anchor w\n')
          })

    rmess("debug","rtcl","1")
    h.r<-c(tclcmds$start
          ,tclcmds$bh   ,tclcmds$blower ,tclcmds$bgreater ,tclcmds$bws
          ,tclcmds$bwh  ,tclcmds$bm     ,tclcmds$bmh      ,tclcmds$bi
          ,tclcmds$biq
          ,if(in.file!="noinput")
                    c(   tclcmds$bn     ,tclcmds$bpoint
                        ,tclcmds$bs     ,tclcmds$bms )
          ,tclcmds$bRi
          ,if(out.file!="noreport")
                    c(   tclcmds$bRed   ,tclcmds$bRw    ,tclcmds$bRwp
                        ,tclcmds$bRh    ,tclcmds$bRhp   ,tclcmds$bRp
                        ,tclcmds$bRcl )
          ,tclcmds$bcfg ,tclcmds$bq
          ,if(in.file!="noinput") tclcmds$secno
          ,tclcmds$pack ,tclcmds$eingabe
         )

    rmess("debug","rtcl","3")
    sink("s.tmp"); for(i in h.r)cat(i); sink()
    rmess("debug","rtcl","4")
             switch(rversion()
                   ,"R-win"  =.Internal(
                     system(paste(rwishprog(),"s.tmp"),as.integer(3),""))
                   ,"R-hpux" =.Internal(system(paste(rwishprog(),"s.tmp"),F))
                   ,"S-hpux" =unix(paste(rwishprog(),"s.tmp"))
             )
             switch(rversion()
                   ,"R-win"  =choice.r<-scan("s.tmp","",quiet=T)
                   ,"R-hpux" =choice.r<-scan("s.tmp","",quiet=T)
                   ,"S-hpux" =choice.r<-scan("s.tmp","")
             )
    rmess("debug","rtcl","5")

    rmess("debug","rtcl",choice.r)
    if(any(choice.r[1]==c("h","<",">","ws","wh","n","s",".","ms","m","mh")))
          h.r<-"wait for return"  else h.r<-"no return"
    if(choice.r[1]=="h")      {rversion();rh()}
    if(choice.r[1]=="<")       repr(choice.r[2])
    if(choice.r[1]==">")repeat{h.r<-req(); if(""==h.r[1]||substring(h.r,1,1)=="q"){
                                             h.r<-"no return"; break } }
    if(choice.r[1]=="ws")      reh(1)
    if(choice.r[1]=="wh")      rehq()
    if(choice.r[1]=="m")       rmod()
    if(choice.r[1]=="mh")      rmodq()
    if(choice.r[1]=="i")       ri(choice.r[2])
    if(choice.r[1]=="iq")      riq()
    if(choice.r[1]=="n")       rn()
    if(choice.r[1]==".")       rs(l.sec.no.r)
    if(choice.r[1]=="s")       rss(choice.r[2])
    if(choice.r[1]=="ms")      rmods(choice.r[2])
    if(choice.r[1]=="Ri")      rri(choice.r[2])
    if(choice.r[1]=="Red")     rred()
    if(choice.r[1]=="Rw")      rr()
    if(choice.r[1]=="Rwp")    {rr();rrdc(choice.r[2]) }
    if(choice.r[1]=="Rh")      rrhq()
    if(choice.r[1]=="Rhd")      rrhd()
    if(choice.r[1]=="Rhp")    {rehq(); rrdc(choice.r[2])}
    if(choice.r[1]=="Rp")      rrdc(choice.r[2])
    if(choice.r[1]=="Rcl")     rri("noreport")
    if(choice.r[1]=="Cfg")     rcfg()
    if(h.r !="no return") {
      if(in.file!="noinput") cat("Nr:",l.sec.no.r," ")
      cat("Bitte Return! -> Tk-Menue\n"); h.r<-readline(); cat("\n")
      if(0<nchar(h.r)[1]&&substring(h.r,1,1)=="q") break
    }

    # if(choice.r[1]=="q") break    eine kleine Meldung: 11.01.2000
    if(choice.r[1]=="q"){cat("Neustart der Knopfleiste:  rtcl()  \n");break}

  }
  rmess("fend","rtcl")
  return(choice.r)
}

rwishprog<-function(){
  switch(rversion()
      #  ,"R-win"  ="..\\bin\\rrtcl\\bin\\wish80"
        ,"R-win"  = rWISHPROG
        ,"R-hpux" ="wish" ,"S-hpux" ="wish")
}

rh<-function(choice.r){
  rmess("fstart","rh")
  h.r<-c(    rM=      "rM        Minimenue")
  h.r<-c(h.r,rh=      "rh        Hilfefunktion")
  h.r<-c(h.r,rexit=   "rexit     loescht  Zustandsliste")
  h.r<-c(h.r,rreset=  "rreset    legt neue Zustandsliste an: r.info")
  h.r<-c(h.r,ri=      "ri        liest ein Papier ein")
  h.r<-c(h.r,riq=     "riq       fragt und liest ein Papier ein")
  h.r<-c(h.r,rfind=   "rfind     sucht Materialien")
  h.r<-c(h.r,rexistsl="rexistsl  prueft Existenz von Libraries")
  h.r<-c(h.r,rn=      "rn        fuehrt naechste Sektion aus")
  h.r<-c(h.r,rs=      "rs        fuehrt eine Sektion aus")
  h.r<-c(h.r,rss=     "rss       fuehrt mehrere Sektionen aus")
  h.r<-c(h.r,re=      "re        fuehrt Ausdruck aus")
  h.r<-c(h.r,req=     "req       fragt nach auszufuehrenden Ausdruck")
  h.r<-c(h.r,reqq=    "reqq      fragt wiederholt nach Ausdruecken")
  h.r<-c(h.r,rehq=    "rehq      fuehrt Ausdruck der Historie aus")
  h.r<-c(h.r,repr=    "repr      fuehrt Anweisung mit print aus")
  h.r<-c(h.r,rmod=    "rmod      modifiziert Anweisungssequenz")
  h.r<-c(h.r,rmodq=   "rmodq     fragt nach zu modifizierenden Sequenz")
  h.r<-c(h.r,rri=     "rri       oeffnet Reportdatei")
  h.r<-c(h.r,rr=      "rr        protokolliert Anweisungen")
  h.r<-c(h.r,rrps=    "rrps      protokolliert Anweisungen mit ps-Device")
  h.r<-c(h.r,rriq=    "rriq      fragt nach Namen und oeffnet Report")
  h.r<-c(h.r,rred=    "rred      editiert Report")
  h.r<-c(h.r,rra=     "rra       verlaengert Report")
  h.r<-c(h.r,rraq=    "rraq      fragt nach zur Verlaengerung des Reports")
  h.r<-c(h.r,rrss=    "rrss      protokolliert ausgewaehlte Sektionen")
  h.r<-c(h.r,rrhh=    "rrhh      protokolliert ausgewaehlte Historie")
  h.r<-c(h.r,rrdc=    "rrdc      kopiert Device")
  h.r<-c(h.r,rrdcq=   "rrdcq     fragt und kopiert Device")
  h.r<-c(h.r,rR=      "rR        liest Zustand von der Zustandsliste r.info")
  h.r<-c(h.r,rS=      "rS        sichert neuen Zustand")
  h.r<-c(h.r,rmess=   "rmess     gibt Meldungen aus")
  h.r<-c(h.r,rsink=   "rsink     Hilfsfunktion fuer Report")
  h.r<-c(h.r,rversion="rversion  zeigt Version")
  if(missing(choice.r)){
    rmess("message","", h.r)
    rmess("message","", "Wenige Details mittels: rh(<funktionsname>)")
  }else{
    rmess("message","",paste(h.r[choice.r],", Parameter:"))
    print(switch(rversion()
                 ,"R-win"  =formals(choice.r) ,"R-hpux" =formals(choice.r)
                 ,"S-hpux" =unlist(rev(rev(eval(parse(text=choice.r)))[-1])) ))
  }
  rmess("","","__________________________________________________")
  rmess("message","","RESET des Systemzustands:                rreset() ")
  rmess("message","","EXIT und Entfernung verschiedener Dinge: rexit() ")
  rmess("message","","Zum Start der Tcl/Tk-Menuesteuerung:     rtcl() ")
  rmess("message","","Zum Oeffnen eines Papiers:               riq() ")
  rmess("fend","rh")
}

rmenu<-function(choices, graphics = F, title = "Menue"){
  rmess("fbegin","rmenu")
  for(i in seq(choices)){
    h<-substring(choices[i],1:nchar(choices[i]),1:nchar(choices[i]))
    if(any(h=="\\")) choices[i]<-paste(h[h!="\\"],collapse="")
  }
  n<-max(10,nchar(choices<-c("Abbruch",choices)))
  tclcmds<-list(c(paste('wm title . "',title,'" ',sep=""),'wm geometry . +0+0'
                 ,'proc fertig {Choice} {',' set Datei [open "s.tmp" w+]'
                 ,' puts $Datei $Choice',' close $Datei',' exit' ,'}'
                 ,paste('set  buttonlength ',n),'set  Choice " "'))
  for(i in seq(choices)) tclcmds<-c(tclcmds,list(
      c(paste("button .b",i,' -text "',choices[i],'" -width $buttonlength ',
              "-command { set Choice ",i,"; fertig $Choice } ",sep=""),
        paste("pack   .b",i," ",sep="") )))
  tclcmds<-unlist(lapply(tclcmds,paste,"\n",sep=""))
  sink("s.tmp"); for(i in tclcmds)cat(i); sink()
  switch(rversion()
        ,"R-win"  =.Internal(
                 system(paste(rwishprog(),"s.tmp"),as.integer(3),""))
        ,"R-hpux" =.Internal(system(paste(rwishprog(),"s.tmp"),F))
        ,"S-hpux" =unix(paste(rwishprog(),"s.tmp")) )
  return(scan("s.tmp",0)-1)
}

rjump.find<-function(key='cat("Revbook',trenn=":",end.skip=3){
  rmess("fbegin","rjump.find")
  jump.def<-sch.r[zeilen<-(1:length(sch.r))[substring(sch.r,1,nchar(key))==key]]
  jump.def<-substring(jump.def,nchar(key)+2,nchar(jump.def)-end.skip)

  section.no<-substring(sch.r[zeilen-1],2,4)
  section.no<-ifelse( substring(section.no,3,3)==":",
                      substring(section.no,1,2), section.no )
  section.no<-ifelse( substring(section.no,2,2)==":",
                      substring(section.no,1,1), section.no )

  jump.text <-jump.def
  jump.names<-jump.index<-rep(" ",length(jump.def))
  for(i in 1:length(jump.def)){
      sep<-switch(rversion(), ,"R-win"  ="\\" ,"R-hpux" ="/" ,"S-hpux" ="/")
      h<-(1:nchar(jump.def[i]))
      h<-h[substring(jump.def[i],h,h)==trenn]
      if(length(h)==2){
          jump.index[i]<-substring(jump.def[i],1,h[1]-1)
          jump.text[i] <-h.r<-substring(jump.def[i],h[2]+1)
          h.r<-substring(h.r,1:nchar(h.r),1:nchar(h.r))
          if(any(h.r==sep)) jump.text[i]<-paste(h.r[h.r!=sep],collapse="")
          jump.names[i]<-substring(jump.def[i],h[1]+1,h[2]-1)
          h<-1:nchar(jump.names[i])
          h<-substring(jump.names[i],h,h)
          h<-paste(h[h!=" "],collapse="")
          if(nchar(h)>0)
            switch(rversion()
              ,"R-win" =assign(h,section.no[i],envir=pos.to.env(1))
              ,"R-hpux"=assign(h,section.no[i],envir=pos.to.env(1)))
      }
  }
  h<-max(nchar(jump.names))
  jump.names<-paste(jump.names,
                   substring("                   ",0,h-nchar(jump.names)),sep="")

  h<-cbind(jump.names,jump.text,jump.index,section.no)
  return(h)


}

rjump.to<-function(name.text.index.no){
  rmess("fbegin","rjump.to")
        key.text<-paste(name.text.index.no[,1],name.text.index.no[,2],sep=" ")
        h<-name.text.index.no[,3]
        ord<-order(substring(h,2))
        section.no<-name.text.index.no[,4]
        h<-paste(rep(" ",nchar(name.text.index.no[1,1])),collapse="")
        wahl<-Menu(c(paste(h,"Abbruch",sep=" "),key.text[ord]))-1
        if(wahl>0){
                #  cmds<-paste("s",section.no[ord][wahl])
                #S assign("cmds",cmds,frame=sys.parent())
                #  rS() #R
                  rs(section.no[ord][wahl]) #R
        }
}

#:0
#96:
rdemo<-function(){

#97:
  rmess("fstart","rdemo")
  cat("Achtung: Fuer die Demo wird der Zustand der       \n")
  cat("         Schreibtisch komplett aufgeraeumt!       \n")
  cat("         Angefangene Arbeiten zum Beispiel mit dem\n")
  cat("         CompBook werden deshalb abgebrochen und  \n")
  cat("         das Buch zugeschlagen!                   \n")
  cat("         Wollen Sie mit der Demo fortfahren?      \n")
  cat("         (j=ja)                                   \n")
  if("j"!=substring(paste(readline(),""),1,1))return("Vielleicht spaeter!")
  cat("Vorgehen:\n")
  rreset()
  cat(" 0. Lesen Sie das Lotto-Papier!\n")
  cat(" 1. Zunaechst wird das Lotto-Papier geladen!\n")

#:97


#99:
  r.info <<- structure(list(cmds = character(0),
    in.file   = "\\r\\compbook\\lib\\rrevbook\\rch\\lotto.sch",
    out.file  = "noreport", editor = "edit", csize = 50, osize = 50,
    ps.height = 8, ps.width = 8,c.choice.r="-",o.flag.r = FALSE,r.flag.r=FALSE,
    l.cmd.r   = "relax", l.sec.r   = "relax",
    l.sec.no.r= 0, sec.lines.r = c(1,22),
    sch.r = c("#0:", "options(width=75);options(digits=3);zz.start<-20",
            "anz.spiele<-10;anz.kugeln<-49;anz.gewaehlt<-6;schon.gewartet<-5",
     "lotto.experiment<-",
        "function(anz.spiele=1,anz.kugeln=49,anz.gewaehlt=6,zz.start=13){",
        "  anz.spiele<-min(100,anz.spiele)",
        "  result<-NULL;.Random.seed<-(zz.start)",
        "  for(i in 1:anz.spiele){",
     "     result<-cbind(result,sort(sample(1:anz.kugeln,size=anz.gewaehlt)))",
        "  }",
        "  dimnames(result)<-list(NULL,paste(1:anz.spiele,\":\",sep=\"\"))",
        "  result", "}",
     "warte.experiment<-",
       "function(anz.ziehungen=100,anz.kugeln=49,anz.gewaehlt=6,zz.start=13){",
       "  .Random.seed[3]<-(zz.start)",
 "prob<-1-prod((anz.kugeln-(1:anz.gewaehlt))/(1+anz.kugeln-(1:anz.gewaehlt)))",
       "  result<-rbinom(anz.ziehungen,1,prob)",
       "  result<-diff(c(0,(1:anz.ziehungen)[result==1]))-1",
       "  result", "}",
              "#:0",
              "#1:",
       "print(\"Lottoziehungsexperiment\")",
  "result<-lotto.experiment(anz.spiele, anz.kugeln, anz.gewaehlt, zz.start)",
       "print(paste(\"Anzeige der ersten\",anz.spiele,\"Ziehungen\"))",
       "print(result)",
       "#:1",
       "#2:",
       "print(\"Wartezeiten auf die 7 ermitteln\")",
    "print(\"Wie viele Ziehungen sollen realisiert werden? (Anzahl<10000)\")",
    "anz.ziehungen<-min(10000,scan(nmax=1))",
    "result<-warte.experiment(anz.ziehungen,anz.kugeln,anz.gewaehlt,zz.start)",
    "print(\"Fehlversuche bis zum Auftreten der 7\")", "print(result)",
    "#:2",
    "#3:",
    "print(\"Mittlere Wartezeit auf die 7\")",
    "print(mean(result))",
    "#:3",
    "#4:",
    "print(\"Plot laufende Nummer/Wartezeiten\")",
    "plot(result,ylab=\"Fehlversuche\",xlab=\"Nummer\")",
    "abline(h=mean(result))",
    "#:4",
    "#5:",
"print(paste(\"Mittlere zusaetzliche Wartezeit jenseits\",schon.gewartet))",
    "print(mean(result[result>=schon.gewartet]-schon.gewartet))",
    "#:5",
    "#6:",
    "print(\"theoretische mittlere Wartezeit\")",
    "#10:",
"prob<-1-prod((anz.kugeln-(1:anz.gewaehlt))/(1+anz.kugeln-(1:anz.gewaehlt)))",
    "#:10",
    "print((1-prob)/prob)",
    "#:6",
    "#7:",
    "print(\"Neusetzung einiger Parameter\");",
    "print(\"============================\")",
    "print(paste(\"Bisher wurden\",anz.kugeln,\"verwendet.\"))",
    "print(\"Aus wievielen Kugeln soll gezogen werden?\")",
    "anz.kugeln<-c(scan(nmax=1),anz.kugeln)[1]",
    "print(paste(\"Bisher wurden\",anz.gewaehlt,\"gezogen.\"))",
"print(\"Wie viele Kugeln sollen gezogen werden? (Nicht zu viele!)\")",
    "anz.gewaehlt<-min(c(scan(nmax=1),anz.gewaehlt)[1],anz.kugeln)",
"print(paste(\"Im Experiment wurden\",anz.spiele,\"Spiele gespielt.\"))",
    "print(\"Wie viele Spiele soll durchgefuehrt werden?\")",
    "anz.spiele<-c(scan(nmax=1),anz.spiele)[1]",
    "print(paste(\"Als Fehlversuchsanzahl war\",schon.gewartet,\"gesetzt.\"))",
    "print(\"Wie soll der neue Wert sein?\")",
    "print(\"Dieser Wert sollte nicht zu gross gewaehlt werden!\")",
    "schon.gewartet<-c(scan(nmax=1),schon.gewartet)[1]",
"print(\"Um nicht immer dieselben Ergebnisse zu bekommen, kann noch die\")",
    "print(\"Ausgangssituations fuer den Zufall gesetzt werden.\")",
"print(\"Hierzu kann eine ganze Zahl zwischen 1 und 999 eingegeben werden.\")",
    "print(paste(\"Zuletzt war diese Zahl\",zz.start))",
    "zz.start<-c(scan(nmax=1),zz.start)[1]",
    "#:7"),
    sch.flag.r = TRUE,
    sch.i.r    = structure(c(0, 0, 1,
                    -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, 10, -10, -6, 7, -7, 1,
                    22, 23, 28, 29, 36, 37, 40, 41, 45, 46, 49, 50, 52, 54, 56,
                    57, 77), .Dim = c(18, 2)),
    history.r  = list("relax"),
    choice.r   = 0, command.r = ""),
    .Names     = c("cmds",
               "in.file", "out.file", "editor", "csize", "osize", "ps.height",
               "ps.width", "c.choice.r", "o.flag.r", "r.flag.r", "l.cmd.r",
               "l.sec.r", "l.sec.no.r", "sec.lines.r", "sch.r", "sch.flag.r",
               "sch.i.r", "history.r", "choice.r", "command.r"))

#:99


#98:
  rR()
  cat(" 2. Jetzt wird die Funktion rtcl gestartet!\n")
  cat(" 3. Mit dieser koennen Sie nun herumexperimentieren!\n")
  cat(" 4. Falls es zu einem Absturz kommt,\n")
  cat("    koennen Sie entweder wieder  rdemo starten oder \n")
  cat("    aber rtcl direkt durch Aufruf von:!\n")
  cat("     rtcl()                                 \n")
  cat(" 5. Viel Spass und Erfolg!\n")
  rs(0)
  rtcl()
  rmess("fend","rdemo")


#:98

}
#:96

rREADME()