path: root/app/mpg/2.2/src/GRAPHIK.Fkt

(***************************************************************************)
(*                                                                         *)
(*                       FKT - Funktionenplotter                           *)
(*                                                                         *)
(* Grundversion : MPG, KB, KN, LP      23.05.84     | 7756 Byte Code       *)
(* Version 6.20 : MPG, Rainer Kottmann 23.09.85     | 7196 Byte Paketdaten *)
(* Angepasst an MPG-Turtle-Standard :  07.03.85     | 1374 Zeilen          *)
(* Version 8.21 : MPG,Beat Jegerlehner 18.09.87     |                      *)
(* Angepasst an MPG EUMELGRAPHIK/EUMEL Version 1.8.1|                      *)
(*                                                                         *)
(***************************************************************************)
PACKET funktionen DEFINES fkt plot,   (*************************************)
                          y grenzen,  (* Interaktives Programm             *)
                          wertetafel, (* Einzelprozeduren fuer "do"        *)
                          ~,          (* BOOL OP "ungefaehr gleich"        *)
                          luecke :    (* Dummykonstante fuer "undefiniert" *)
                                      (*************************************)
                                      (* Autoren:    Klaus Bovermann       *)
                                      (*             Kai Nikisch           *)
                                      (*             Lutz Prechelt         *)
                                      (*             Rainer Kottmann       *)
                                      (*             Beat Jegerlehner      *)
                                      (*************************************) 
 
LET fkpos          =  1,           (* Diese LETs sind Bildschirmpositionen *)
    inpos          =  2,
    wpos           =  3,
    fehlerpos      =  5,
    eingpos        =  7,
    textpos        = 11,
    wahlpos        = 24,
    xupos          = 16,
    yupos          = 16,
    xopos          = 32,
    yopos          = 32,
    stuetzpktpos   = 48,
    endgeraetepos  = 20;

LET punkte         = 512,            (* maximale Anzahl der Stuetzpunkte *) 
    ug1            = 0.15051,        (* Hilfswerte fuer 'gauss'          *)
    ug2            = 0.5, 
    ug3            = 0.84948,
    din a 4 hoehe  = 5.0,            (* Hoehe der Beschriftung  *)
    din a 4 breite = 5.0,            (* in mm                   *)
    ziffern        = 12,             (* Genauigkeitsangabe      *)
    gross          = 8.888888e88,
    epsilon        = 1.0e-11;

LET wahlstring              = ""8""2"fdwsazntlLAqeb~?",
    farbstr                 = "<CR>Standard <r>ot <b>lau <g>ruen <s>chwarz",
    farbchars               = ""13"rbgs",
    graphikvater            = "GRAPHIK",
    helpfile                = "FKT.help";

ROW punkte REAL VAR graph;

TEXT VAR term            :: "",
         rohterm         :: "",
         picfilename     :: "",
         prefix          :: "PICFILE.",
         postfix         :: "",
         fehlernachricht :: "",
         proc,
         inline;

REAL VAR x min ::  -gross,  x max ::  gross,
         y min ::  maxreal, y max :: -maxreal,
         xstep;

INT  VAR nachkomma :: 2,
         stuetzen  :: punkte,
         endgeraet :: 1,
         endgeraete :: highest entry(plotters);

BOOL VAR intervall definiert   :: FALSE,
         wertebereich bestimmt :: FALSE,
         wertetafel vorhanden  :: FALSE,
         fehlerzustand         :: FALSE;

REAL CONST luecke :: gross;

PICTURE VAR dummy picture :: nilpicture;
move (dummy picture,0.0,0.0);

(***************************************************************************)
(* Alte Prozeduren (Graphik-unabhaengig)                                   *)
(***************************************************************************)

PROC get (TEXT VAR text):    (* moeglichkeit, ueberall abzubrechen! *)
  text := "";
  TEXT VAR exit char;
  editget (text,""27"","",exit char);
  IF exit char = ""27""
    THEN errorstop("Abgebrochen")
  FI
END PROC get;

PROC get (INT VAR nr):
  TEXT VAR t;
  get(t);
  line;
  nr := int(t)
END PROC get;

PROC get (REAL VAR nr):
  TEXT VAR t;
  get(t);
  line;
  nr := real(t)
END PROC get;

PROC editget (TEXT VAR t):
  TEXT VAR t2 :: t,exit char;
  editget(t2,""27"","",exit char);
  IF exit char = ""27""
    THEN errorstop("Abgebrochen")
  FI;
  t := t2
END PROC editget;

PROC inchar (TEXT VAR a,TEXT CONST b):
  REP
    inchar (a)
  UNTIL pos(b,a) <> 0 OR a = ""27"" PER;
  IF a = ""27""
    THEN errorstop("Abgebrochen")
  FI
END PROC inchar;

BOOL OP ~ (REAL CONST left , right) :
     abs (left - right) <= xstep
END OP ~;

(*******************     MAIN PROGRAMM        *****************************)

PROC fkt plot:
  auswahlbild;
  select plotter(name(plotters,endgeraet));
  REP
    bild;
    auswahl (inline)
  UNTIL inline = "q" PER

END PROC fkt plot;

(******************        LAY OUT            *****************************)

PROC auswahlbild:
  page;
  cursor (1,textpos);
  put     ("(f)  Funktionsterm eingeben             ");
  putline ("(?)  Hilfestellung                    ");
  put     ("(d)  Definitionsbereich waehlen         ");
  putline ("(q)  in die Kommandoebene zurueck     ");
  put     ("(w)  Wertebereich ermitteln lassen      ");
  putline ("(s)  Anzahl der Stuetzpunkte waehlen  ");
  put     ("(z)  Zeichnung anfertigen               ");
  putline ("(n)  Nachkommastellenzahl waehlen     ");
  put     ("(a)  Ausgabe der Zeichnung auf Endgeraet");
  putline ("(e)  Arbeit beenden                   ");
  put     ("(t)  Wertetafel erstellen lassen        ");
  putline ("(L)  Zeichnungen loeschen             "); 
  put     ("(l)  Zeichnungen auflisten              ");
  putline ("(A)  Zeichnungen archivieren          ");
  put     ("                                        "); 
  putline ("(b)  Zeichnung beschriften            ");
  cursor (1,wahlpos);
  put ("Ihre Wahl:")
END PROC auswahlbild;

PROC bild:
  cursor (1,fkpos);
  put ("f(x) = " + rohterm);
  out (""5"");
  cursor (1,inpos);
  put ("Def.Bereich:  [              /               ]");
  cursor (xupos,inpos);
  put (text (x min,ziffern,nachkomma));
  cursor (xopos,inpos);
  put (text (x max,ziffern,nachkomma));
  cursor (1,wpos);
  put ("Wertebereich: [              /               ]");
  cursor (yupos,wpos);
  put (text (y min,ziffern,nachkomma));
  cursor (yopos,wpos);
  put (text (y max,ziffern,nachkomma));
  cursor (1,endgeraetepos);
  put endgeraetestring;
  cursor (stuetzpktpos,inpos);
  put ("Anzahl der Stuetzpunkte: " + text (stuetzen,3));
  drei zeilen ab eingpos loeschen.
END PROC bild;

(******************       MONITOR             *****************************)

PROC auswahl 1 (TEXT VAR wahl):
  enable stop;
  SELECT code (wahl) OF
    CASE    8 : endgeraet := max(endgeraet-1,1);
                select plotter(name(plotters,endgeraet))
    CASE    2 : endgeraet := min(endgeraet+1,endgeraete);
                select plotter(name(plotters,endgeraet))
    CASE  102 : fkt lesen                 (*  f  *)
    CASE  100 : defbereich waehlen        (*  d  *)
    CASE  119 : wertebereich erstellen    (*  w  *)
    CASE  116 : wertetafel erstellen      (*  t  *)
    CASE  113 : LEAVE auswahl 1           (*  q  *)
    CASE  122 : graph erstellen           (*  z  *)
    CASE   97 : graph zeigen              (*  a  *)
    CASE  110 : genauigkeitsangabe        (*  n  *)
    CASE   65 : dm;                       (*  A  *)
                auswahlbild
    CASE  108 : dateien listen            (*  l  *)
    CASE   76 : dateien aus task raeumen  (*  L  *)
    CASE  101 : unterbrechung             (*  e  *)
    CASE  126 : spezialeingabe            (* TIL *)
    CASE   63 : hilfe                     (*  ?  *)
    CASE  115 : stuetzpunkte setzen       (*  s  *)
    CASE   98 : zeichnung beschriften     (*  b  *)
  END SELECT;
END PROC auswahl 1;

PROC auswahl (TEXT VAR wahl):       (* Faengerebene *)
  cursor (12,24);
  out (""5"");
  inchar (wahl,wahlstring);
  fehlerloeschen;
  disable stop;
  auswahl 1 (wahl);
  IF is error
     THEN fehlersetzen (error message);
          clear error
  FI;
  enable stop;
  IF fehlerzustand
     THEN fehleraus (fehlernachricht)
  FI
END PROC auswahl;

PROC put endgeraetestring:
  TEXT VAR s :: "Endgeraet: ";
  INT VAR i;
  THESAURUS CONST t :: plotters;
  FOR i FROM 1 UPTO endgeraete REP
    IF length(s)+length(name(t,i))+4 > 79
      THEN putline(s+""5"");
           s := "           "
    FI;
    IF i = endgeraet
      THEN s CAT ""15"" + name(t,i) + " "14" "
      ELSE s CAT " "+name(t,i) + "   "
    FI
  PER;
  putline(s+""5"")

END PROC put endgeraetestring;


(**************************** f *******************************************)

PROC fkt lesen:
  reset wertebereich;
  cursor (1,eingpos);
  put ("f(x) =");
  out (""5"");
  cursor (1,eingpos + 1);
  out(""5"");
  cursor (8,eingpos);
  editget (rohterm);
  change int to real (rohterm,term);
  change all (term,"X","x");
  change all (term,"=","~");                         (* Ueberdeckung von = *)
  change all (term,"<~","<=");                       (* ruecksetzen von <= *)
  change all (term,">~",">=");                       (*       "         >= *)
  term testen;
  wertetafel vorhanden := FALSE.

term testen:
  disable stop;
  proc := "REAL PROC f (REAL CONST x):";
  proc CAT term;
  proc CAT " END PROC f";
  do ("do ("""+proc+""")");      (* komischer do-Fehler *)
  IF is error
     THEN fehlersetzen ("Term fehlerhaft");
          clear error;
          LEAVE fkt lesen
  FI
END PROC fkt lesen;

(**************************** d *******************************************)

PROC defbereich waehlen:
  cursor (1,eingpos);
  put ("Untergrenze  :");
  out (""5"");
  get (x min);
  obergrenze lesen;
  intervall definiert := TRUE;
  reset wertebereich.

obergrenze lesen:
  REP
    put ("Obergrenze   :");
    out (""5"");
    get (x max);
    IF x max <= x min
       THEN out (""7""13""3""5"")
    FI
  UNTIL x max > x min PER
END PROC defbereich waehlen;

(**************************** w *******************************************)

PROC wertebereich erstellen:
  IF rohterm = ""
     THEN fehlersetzen ("Erst Fkts.Term eingeben! (f)");
          LEAVE wertebereich erstellen
  ELIF NOT intervall definiert
     THEN fehlersetzen ("Erst Def.Bereich waehlen (d)");
          LEAVE wertebereich erstellen
  ELIF wertebereich bestimmt
     THEN fehlersetzen ("Wertebereich ist bereits bestimmt");
          LEAVE wertebereich erstellen
  FI;
  proc := "REAL PROC f (REAL CONST x):"+ term;
  proc CAT " END PROC f; ygrenzen (PROC f)";
  do (proc)
END PROC wertebereich erstellen;

PROC ygrenzen (REAL PROC (REAL CONST) f):
  REAL VAR x, f von x;
  INT  VAR i :: 1;
  
  disable stop;
  xstep := (x max - x min) / real (stuetzen - 1);
  x := x min;
  y min :=  maxreal;
  y max := -maxreal;
  cursor (1,eingpos);
  putline ("Wertebereich wird ermittelt");
  out (""5"");
  out ("bei Stuetzpunkt Nr.: ");
  wertegrenzen berechnen;
  IF is error
     THEN fehler setzen (error message);
          reset wertebereich;
          LEAVE ygrenzen
  ELIF fehlerzustand
     THEN reset wertebereich;
          LEAVE ygrenzen
     ELSE wertebereich bestimmt := TRUE
  FI;
  IF y min = y max
     THEN y min DECR 1.0;
          y max INCR 1.0
  FI.

wertegrenzen berechnen:
  FOR i FROM 1 UPTO stuetzen REP
    x := real (i-1) * xstep + x min;
    cout (i);
    f von x := f (x);
    graph [i] := f von x;
    IF f von x <> luecke
       THEN y min := min (y min, f von x);
            y max := max (y max, f von x)
    FI
  UNTIL is error OR interrupt PER .

interrupt:
  IF incharety = ""27""
     THEN fehlersetzen ("Abgebrochen");
          TRUE
     ELSE FALSE
  FI
END PROC ygrenzen;

(**************************** t *******************************************)

PROC wertetafel erstellen:
  IF rohterm = ""
     THEN fehleraus ("Erst Fkts.Term eingeben (f)");
          LEAVE wertetafel erstellen
  ELIF NOT intervall definiert
     THEN fehleraus ("Erst Def.Bereich waehlen (d)");
          LEAVE wertetafel erstellen
  FI;
  proc := "REAL PROC f (REAL CONST x):"+ term;
  proc CAT " END PROC f; wertetafel (PROC f)";
  do (proc)
END PROC wertetafel erstellen;

PROC wertetafel (REAL PROC (REAL CONST ) f):
  FILE VAR g :: sequential file (output,rohterm);
  REAL VAR x, f von x;
  INT  VAR i :: 0;
  
  REP
    schrittweite einlesen
  UNTIL (xstep > 0.0) CAND ((x max-x min) / xstep < real (punkte)) PER;
  x := x min;
  evtl ueberschrift;
  disable stop;
  REP
    datei erstellen
  UNTIL x > x max OR is error PER;
  fehleraus in tafel;
  enable stop;
  modify  (g);
  edit (g);
  line;
  IF yes("Tafel drucken")
     THEN print (rohterm)
  FI;
  line (2);
  IF yes("Tafel loeschen")
     THEN forget(rohterm,quiet);
          wertetafel vorhanden := FALSE
     ELSE wertetafel vorhanden := TRUE
  FI;
  auswahlbild.

evtl ueberschrift:
  IF NOT wertetafel vorhanden
     THEN putline (g, "       W E R T E T A F E L");
          line (g);
          putline (g, "      x         !     " + rohterm);
          putline (g, "----------------!----------------")
  FI.

fehleraus in tafel:
  IF is error
     THEN fehlernachricht := errormessage;
          clearerror;
          line (g,2);
          putline (g,fehlernachricht);
          fehlernachricht := ""
  FI.

datei erstellen:
  i INCR 1;
  cout (i);
  put (g, text (x,ziffern,nachkomma));
  put (g, "   !");
  f von x := f (x);
  IF f von x <> luecke
    THEN put (g, text (f von x,ziffern,nachkomma))
    ELSE put (g, "Definitionsluecke")
  FI;
  line (g);
  x INCR xstep.

schrittweite einlesen:
  cursor (1,eingpos);
  put ("Schrittweite:");
  out (""5"");
  cursor (1,eingpos + 1);
  out (""5"");
  cursor (15,eingpos);
  get (xstep);
  put ("Zwischenpunkt :");
  IF (xstep <= 0.0) COR ((x max-x min) / xstep > real (punkte))
     THEN fehleraus ("Schrittweite zu klein");
          LEAVE wertetafel
  FI
END PROC wertetafel;

(*********************************** n *************************************)

PROC genauigkeitsangabe:
  cursor (1,eingpos);
  put ("Anzahl der Nachkommastellen : ");
  get (nachkomma);
  disable stop;
  nachkomma := min (nachkomma, ziffern - 3);
  nachkomma := max (nachkomma, 0);
  IF is error
     THEN fehlersetzen ("Falscher Wert");
          clear error;
          nachkomma := 2
  FI
END PROC genauigkeitsangabe;

(********************************l ****************************************)

PROC dateien listen:
  th(all LIKE (prefix+"*"));
  auswahlbild
END PROC dateien listen;

(********************************L ****************************************)

PROC dateien aus task raeumen:
  forget(some(all LIKE (prefix+"*")));
  auswahlbild
END PROC dateien aus task raeumen;

(**************************** s *******************************************)

PROC stuetzpunkte setzen:
  cursor (1,eingpos);
  put ("Anzahl der Stuetzpunkte :");
  get (stuetzen);
  disable stop;
  IF stuetzen <= 1  OR stuetzen > punkte
     THEN fehler setzen ("Achtung Stuetzpunkte fehlerhaft")
  FI;
  stuetzen := max (stuetzen, 2)  ;
  stuetzen := min (stuetzen, punkte);
  IF is error
     THEN fehlersetzen ("Falscher Wert");
          clear error;
          stuetzen := punkte
  FI;
  reset wertebereich
END PROC stuetzpunkte setzen;
(**************************** e *******************************************)

PROC unterbrechung:
  break;
  auswahlbild
END PROC unterbrechung;

(****************************** ? ******************************************)

PROC hilfe:
  IF NOT exists(helpfile)
    THEN fetch(helpfile,task (graphikvater))
  FI;
  FILE VAR f :: sequential file(input,helpfile);
  headline(f,"Verlassen mit <ESC> <q>");
  open editor(f,FALSE);
  edit (groesster editor,"q",PROC (TEXT CONST) dummy ed);
  auswahlbild
END PROC hilfe;

PROC dummy ed (TEXT CONST t):
  IF t = "q"
    THEN quit
    ELSE out(""7"")
  FI
END PROC dummy ed;

(**************************** TILDE ****************************************)
 
PROC spezialeingabe:
  TEXT CONST termeingabename :: "Bitte Funktionsrumpf eingeben";
  TEXT VAR t;
  FILE VAR f :: sequential file (modify, termeingabename);
 
  edit (f);
  lese den term aus;
  teste den term;
  rohterm := "spezial";
  reset wertebereich;
  auswahlbild.

lese den term aus:
  term := "";
  input (f);
  WHILE NOT eof (f) REP
    getline (f,t);
    term CAT t;
    term CAT " "
  PER.

teste den term:
  disable stop;
  proc := "REAL PROC f (REAL CONST x):";
  proc CAT term;
  proc CAT " END PROC f";
  do (proc);
  IF is error
     THEN fehlersetzen ("Funktionsrumpf fehlerhaft");
          clear error;
          term := "";
          rohterm := "";
          reset wertebereich;
          auswahlbild;
          LEAVE spezialeingabe
  FI
END PROC spezialeingabe;

(***************************************************************************)
(*********                 Ab hier Hilfsprozeduren                 *********)
(***************************************************************************)

PROC fehleraus (TEXT CONST t):
   cursor (1,fehlerpos);
   out (""7"F E H L E R : ", t);
   fehlerzustand := FALSE
END PROC fehleraus;

PROC fehlerloeschen:
  cursor (1,fehlerpos);
  out (""5"");
  fehlernachricht := "";
  fehlerzustand   := FALSE
END PROC fehlerloeschen;

PROC fehler setzen (TEXT CONST message):
  fehlernachricht := message;
  fehlerzustand   := TRUE;
  clear error
END PROC fehler setzen;

REAL PROC gauss (REAL CONST z):
  IF is integer (z)
     THEN round (z,0)
  ELIF sign (z) = -1
     THEN floor (z) - 1.0
     ELSE floor (z)
  FI
END PROC gauss;

BOOL PROC is integer (REAL CONST x):
  abs (x - floor (x)) < epsilon
END PROC is integer;

PROC berechnung (REAL CONST min, max,
                 REAL VAR   sweite,
                 INT VAR    styp):

  sweite := faktor * round (10.0 ** expo,11).

faktor: 
  IF nachkomma < ug1
       THEN styp := 1;
            1.0
  ELIF nachkomma < ug2
       THEN  styp := 2;
             2.0
  ELIF nachkomma < ug3
       THEN styp := 5;
            5.0
       ELSE styp := 1;
            10.0
  FI.

nachkomma:
  IF frac (logwert) < -epsilon
     THEN 1.0 + frac (logwert)
  ELIF frac (logwert) > epsilon
     THEN frac (logwert)
     ELSE 0.0
  FI.

differenz:
  max - min.

expo:
  gauss (logwert) - 1.0.

logwert:
  round (log10 (differenz),8)
END PROC berechnung;

REAL PROC runde ab (REAL CONST was, auf):
  auf * gauss (was / auf)
END PROC runde ab;

REAL PROC runde auf (REAL CONST was, auf):
  REAL VAR hilf :: runde ab (was,auf);
 
  IF abs (hilf - was) < epsilon
     THEN was
     ELSE hilf + auf 
  FI
END PROC runde auf;

PROC loesche zeile (INT CONST zeile):
  cursor (1,zeile);
  out (""5"")
END PROC loesche zeile;

PROC drei zeilen ab eingpos loeschen:
  loesche zeile (eingpos);
  loesche zeile (eingpos + 1);
  loesche zeile (eingpos + 2);
END PROC drei zeilen ab eingpos loeschen;

PROC change int to real (TEXT CONST term alt,TEXT VAR term neu):
  TEXT VAR symbol :: "", presymbol :: "";
  INT  VAR type :: 0, pretype :: 0, position;
  LET number      = 3,
      tag         = 1,
      end of scan = 7,
      pot         = "**";

  term neu := "";
  scan (term alt);
  WHILE type <> end of scan REP
    presymbol :=  symbol;
    pretype   :=  type;
    next symbol (symbol,type);
    IF type <> number OR presymbol = pot
       THEN term neu CAT evtl mal und symbol
       ELSE term neu CAT changed symbol
    FI
  PER.

evtl mal und symbol:
  IF pretype = number AND type = tag
     THEN "*" + symbol
     ELSE symbol
  FI.

changed symbol:
  position := pos (symbol,"e"); 
  IF position <> 0 
     THEN text (symbol,position - 1) + ".0" +
          subtext (symbol,position,length (symbol)) 
  ELIF pos (symbol,".") = 0
     THEN symbol CAT ".0";
          symbol
     ELSE symbol
  FI
END PROC change int to real;

PROC reset wertebereich:
  y min := -maxreal;
  y max :=  maxreal;
  wertebereich bestimmt := FALSE
END PROC reset wertebereich;

TEXT PROC textreal (REAL CONST z):
  TEXT VAR t :: text (z);

  IF (t SUB length (t)) = "."
     THEN subtext (t,1,length (t) - 1)
  ELIF (t SUB 1) = "." 
     THEN "0" + t
  ELIF (t SUB 2) = "." AND sign (z) = -1
     THEN "-0" + subtext (t,2)
  ELIF t = "0.0" 
     THEN "0"
     ELSE t
  FI
END PROC textreal;

INT PROC length (REAL CONST z):
  length (text (z))
END PROC length;

PROC put format(INT CONST wo, REAL CONST xxmi,xxma,yymi,yyma):
  cursor (1,wo);
  put ("Aktuelles Format:       xmin           xmax" +
       "           ymin           ymax");
  cursor (19,wo + 1);
  put (text (xx mi,ziffern,nachkomma));
  cursor (34,wo + 1);
  put (text (xx ma,ziffern,nachkomma));
  cursor (49,wo + 1);
  put (text (yy mi,ziffern,nachkomma));
  cursor (64,wo + 1);
  put (text (yy ma,ziffern,nachkomma))
END PROC put format;
 
PROC out (TEXT CONST a, b) :
  out (a); out (b)
END PROC out;

(***************************************************************************)
(* Neue Prozeduren                                                         *)
(***************************************************************************)

PROC graph erstellen:
  PICFILE VAR funktionen;
  PICTURE VAR funktionsgraph :: nilpicture,
              formatpic      :: nilpicture;
  REAL VAR xx min :: x min,
           xx max :: x max,
           yy min :: y min,
           yy max :: y max;

  IF rohterm = ""
     THEN fehlersetzen ("Erst Funktionsterm waehlen (f)");
          LEAVE graph erstellen
  ELIF NOT wertebereich bestimmt
     THEN fehlersetzen ("Erst Wertebereich bestimmen lassen (w)");
          LEAVE graph erstellen
  FI;

  hole filenamen;
  funktionen := picture file (picfilename);
  initialisiere stifte;
  waehle format;
  zeichne graphen;
  pictures ins picfile.

hole filenamen:
  TEXT VAR t :: "";
  REP 
    namen lesen
  UNTIL t = "l" OR t = "e" PER. 

namen lesen:
  cursor (1,eingpos);
  out ("Welchen Namen soll die Zeichnung haben: "+ prefix);
  postfix:= rohterm;
  editget (postfix);
  line;
  IF (postfix SUB 1) = "?"
    THEN picfilename := one(all LIKE (prefix+"*"));
         auswahlbild;
         bild;
         cursor(1,eingpos)
    ELSE picfilename := prefix + postfix;
         picfilename := compress (picfilename)
  FI;
  IF NOT exists (picfilename)
    THEN LEAVE hole filenamen
  FI;
  putline ("Zeichnung gibt es schon!");
  put ("loeschen (l), Namen neuwaehlen (n), " +
       "alte Zeichnung ergaenzen (e):");
  inchar (t,"lne");
  IF t = "l"
     THEN forget (picfilename,quiet)
  ELIF t = "n"
     THEN drei zeilen ab eingpos loeschen
  FI.

initialisiere stifte:
  select pen (funktionen, 1, 1, 0, 1, TRUE); (* Standardfarbe *)
  select pen (funktionen, 2, 2, 0, 1, TRUE); (* Rot           *)
  select pen (funktionen, 3, 3, 0, 1, TRUE); (* Blau          *)
  select pen (funktionen, 4, 4, 0, 1, TRUE); (* Gruen         *)
  select pen (funktionen, 5, 5, 0, 1, TRUE). (* Schwarz       *)

waehle format:
  IF altes picfile
    THEN ergaenze wertebereich
  FI;
  drei zeilen ab eingpos loeschen;
  REAL VAR step;
  INT VAR i dummy;
  berechnung (yy min, yy max, step, idummy);
  yy min := runde ab (yy min, step);
  yy max := runde auf (yy max, step);
  put format(eingpos, xx min, xx max, yy min, yy max);
  pause ;
  drei zeilen ab eingpos loeschen;
  cursor(1,eingpos);
  IF yes("Format aendern")
    THEN interactive change of format (xx min,xx max,yy min,yy max)
  FI;
  drei zeilen ab eingpos loeschen.

ergaenze wertebereich:
  to pic (funktionen,3);             (* Formatpicture *)
  read picture (funktionen,formatpic);
  move (formatpic, xx min, yy min);
  move (formatpic, xx max, yy max);
  extrema (formatpic, xx min, xx max, yy min, yy max).

altes picfile:
  t = "e".

zeichne graphen:
  REAL VAR x              :: x min,
           x schrittweite :: (x max - x min) / real (stuetzen - 1);
  INT  VAR i;

  cursor (1,eingpos);
  put ("Graph bei Stuetzpunkt Nr. ");
  FOR i FROM 1 UPTO stuetzen REP
     cout (i);
     IF graph[i] <> luecke
       THEN IF zuletzt luecke
              THEN move (funktionsgraph, x, graph[i])
              ELSE draw (funktionsgraph, x, graph[i])
            FI
     FI;
     x INCR x schrittweite
  UNTIL abbruch PER;
  drei zeilen ab eingpos loeschen.

  abbruch:
    IF incharety = ""27""
      THEN errorstop("Abgebrochen");
           TRUE
      ELSE FALSE
    FI.

  zuletzt luecke:
   i = 1 COR graph[i-1] = luecke.

pictures ins picfile:
  setze graphenfarbe;
  to first pic(funktionen);
  IF altes picfile
    THEN down (funktionen);        (* Skip *)
         down (funktionen)
    ELSE put picture (funktionen, dummy picture); (* Zusaetzliche Beschr.*)
         put picture (funktionen, dummy picture)
  FI;
  formatpic := nilpicture;
  move (formatpic, xx min, yy min);
  move (formatpic, xx max, yy max);
  IF altes picfile
    THEN write picture (funktionen, formatpic)
    ELSE put picture (funktionen, formatpic)
  FI;
  put picture (funktionen, funktionsgraph).

setze graphenfarbe:
  cursor (1,eingpos);
  put("Farbe des Graphen :");
  pen (funktionsgraph, farbe).

farbe :
  TEXT VAR ff;
  put(farbstr);
  inchar (ff,farbchars);
  out(ff);
  pos (farbchars,ff).

END PROC graph erstellen;

PROC interactive change of format (REAL VAR x mi,x ma,y mi,y ma):
  TEXT VAR tt;
  REP
    cursor (1,eingpos + 2);
    put ("Geben Sie die neuen Koordinaten ein");
    out (""5"");
    pause (20);
    loesche zeile (eingpos + 2);
    cursor (1,eingpos + 2);
    put ("xmin:");
    tt := text (xmi);
    editget (tt); 
    xmi := real (tt);
    cursor (1,eingpos + 2);
    put ("xmax:"); 
    out (""5"");
    tt := text (xma);
    editget (tt);
    xma := real (tt);
    cursor (1,eingpos + 2);
    put ("ymin:");
    out (""5"");
    tt := text (ymi);
    editget (tt);
    ymi := real (tt);
    cursor (1,eingpos + 2);
    put ("ymax:");
    out (""5"");
    tt := text (yma);
    editget (tt);
    yma := real (tt);
  UNTIL format ok PER.

  format ok:
    IF xma <= xmi OR yma <= ymi
      THEN fehlersetzen ("Format falsch");
           FALSE
      ELSE TRUE
    FI
END PROC interactive change of format;

PROC geraet waehlen:
END PROC geraet waehlen;

PROC zeichnung beschriften:
  namen holen;
  PICFILE VAR funktionen :: picture file(picfilename);
  PICTURE VAR beschr;
  to pic(funktionen,2);
  read picture(funktionen,beschr);
  cursor(1,eingpos);
  put("Beschriftung (e) rgaenzen , (l) oeschen oder (a) bbruch");
  TEXT VAR t;
  inchar(t,"ela");
  IF t = "l"
    THEN to pic(funktionen,2);
         beschr := nilpicture;
         write picture(funktionen,beschr)
  ELIF t = "e"
    THEN beschrifte
  FI;
  cursor(1,eingpos);
  drei zeilen ab eingpos loeschen.

  beschrifte:
    farbe holen;
    REAL VAR rx,ry,hx,bx;
    to pic(funktionen,3);
    PICTURE VAR format;
    read picture(funktionen,format);
    extrema(format,rx,ry,hx,bx);
    drei zeilen ab eingpos loeschen;
    put format (eingpos,rx,ry,hx,bx);
    pause;
    REP
      drei zeilen ab eingpos loeschen;
      cursor(1,eingpos);
      put("Text :");
      TEXT VAR btext;
      getline(btext);
      put("Koordinaten in (c)m oder in (r)eal ");
      inchar(t,"cra");
      drei zeilen ab eingpos loeschen;
      cursor(1,eingpos);
      put("X-Koordinate:");
      get(rx);
      put("Y-Koordinate:");
      get(ry);
      IF t = "c"
        THEN move cm(beschr,rx,ry)
        ELSE move   (beschr,rx,ry)
      FI;
      drei zeilen ab eingpos loeschen;
      cursor(1,eingpos);
      put("Hoehe der Zeichen in mm :");
      get(hx);
      put("Breite der Zeichen in mm:");
      get(bx);
      draw(beschr,btext,0.0,hx,bx);
      drei zeilen ab eingpos loeschen;
      cursor(1,eingpos)
    UNTIL no("Weitere Beschriftungen") PER;
    to pic(funktionen,2);
    write picture(funktionen,beschr).

  farbe holen:
    drei zeilen ab eingpos loeschen;
    cursor(1,eingpos);
    put("Farbe der Beschriftungen: ");
    TEXT VAR ff;
    put(farbstr);
    inchar (ff,farbchars);
    out(ff);
    pen(beschr,pos (farbchars,ff)).

  namen holen:
    cursor(1,eingpos);
    put("Wie heisst die Zeichnung:");
    out(prefix);
    editget(postfix);
    picfilename := prefix + postfix;
    IF (postfix SUB 1) = "?"
      THEN picfilename := one(all LIKE (prefix + "*"));
           auswahlbild;
           bild
    FI;
    IF NOT exists(picfilename)
      THEN fehlersetzen("Zeichnung gibt es nicht");
           LEAVE zeichnung beschriften
    FI

END PROC zeichnung beschriften;

PROC graph zeigen:
  REAL VAR xx max,xx min,yy max,yy min;

  cursor (1,eingpos);
  put ("Wie heisst die Zeichnung :");
  out(prefix);
  editget(postfix);
  picfilename := prefix+postfix;
  IF (postfix SUB 1) = "?"
    THEN picfilename := one(all LIKE (prefix+"*"));
         postfix := subtext(picfilename,length(prefix)+1);
         auswahlbild;
         bild
  ELIF NOT exists (picfilename)
    THEN fehlersetzen ("Zeichnung gibt es nicht");
         LEAVE graph zeigen
  FI;
  drei zeilen ab eingpos loeschen;
  PICFILE VAR funktionen :: picture file (picfilename);
  PICTURE VAR rahmen :: nilpicture;
  hole ausschnitt;
  hole headline;
  erzeuge rahmen;
  gib bild aus.

  gib bild aus:
    REAL VAR x cm,y cm; INT VAR i,j;
    drawing area (x cm,y cm,i,j);
    viewport (funktionen, 0.0, x cm/y cm, 0.0, 1.0);
    erweitere bereich;  (* Rundungsfehler beim clippen vermeiden !!! *)
    window (funktionen, xx min, xx max, yy min, yy max);
    plot (picfilename);
    auswahlbild.

  erweitere bereich:
    xx max := xx max + (xx max - xx min) / real(i).

 erzeuge rahmen:
   to pic (funktionen,1);
   waehle achsenart;
   IF achsenart = "r"
     THEN rahmen := frame (xx min,xx max,yy min,yy max)
     ELSE rahmen := axis  (xx min,xx max,yy min,yy max)
   FI;
   rahmen CAT beschriftung (xx min,xx max,yy min,yy max,headline,
                            achsenart = "r");
   cursor (1,eingpos);
   put ("Farbe des");
   IF achsenart = "k"
     THEN put("Koordinatensystems :")
     ELSE put("Rahmens :")
   FI;
   pen (rahmen,farbe);
   drei zeilen ab eingpos loeschen;
   write picture (funktionen,rahmen).

  farbe :
    TEXT VAR ff;
    put(farbstr);
    inchar (ff,farbchars);
    out(ff);
    pos (farbchars,ff).

  waehle achsenart:
    TEXT VAR achsenart :: "r";
    IF koord moeglich
      THEN frage nach achsenart
    FI.

  frage nach achsenart:
    cursor (1,eingpos);
    put("<k>oordinatensystem oder <r>ahmen zeichnen ?");
    inchar (achsenart,"kr");
    putline(achsenart);
    drei zeilen ab eingpos loeschen.

  koord moeglich:
    NOT (xmin >= 0.0 OR xx max <= 0.0 OR yy min >= 0.0 OR yy max <= 0.0).

  hole ausschnitt:
    PICTURE VAR format;
    to pic (funktionen,3);
    read picture (funktionen,format);
    extrema (format, xx min, xx max, yy min, yy max);
    cursor (1,eingpos);
    put format (eingpos, xx min, xx max, yy min, yy max);
    pause;
    drei zeilen ab eingpos loeschen;
    cursor (1,eingpos);
    IF yes ("Wollen Sie den Ausschnitt veraendern")
      THEN interactive change of format (xx min,xx max,yy min,yy max)
    FI;
    drei zeilen ab eingpos loeschen.

  hole headline:
    cursor (1,eingpos);
    TEXT VAR headline :: rohterm;
    put ("Ueberschrift :");
    editget (headline);
    drei zeilen ab eingpos loeschen
END PROC graph zeigen;

PICTURE PROC frame (REAL CONST xx min,xx max,yy min,yy max):

   PICTURE VAR rahmen :: nilpicture;
   zeichne achsen;
   zeichne restrahmen;
   rahmen.

  zeichne restrahmen:
   move (rahmen,xx min,yy max);
   draw (rahmen,xx max,yy max);
   draw (rahmen,xx max,yy min).

  zeichne achsen:
    rahmen := axis (xx min,xx max,yy min,(yy max - yy min) / 90.0,0,0);
    rahmen CAT axis (yy min,yy max,xx min,(xx max - xx min) / 90.0,1,0)

END PROC frame;

PICTURE PROC axis (REAL VAR xx min,xx max,yy min,yy max):
  PICTURE VAR rahmen :: nilpicture;
  rahmen := axis (xx min,xx max,0.0,(yy max - yy min) / 180.0,0,1);
  rahmen CAT axis (yy min,yy max,0.0,(xx max - xx min) / 180.0,1,1);
  rahmen
END PROC axis;

PICTURE PROC axis (REAL CONST min, max, pos,strich,
                   INT CONST  dir,mode):
  PICTURE VAR achse ::  nilpicture;
  REAL VAR step,
           feinstep,
           wert;
  INT VAR type;
  berechnung (min,max,step,type);
  feinstep := step / real(zwischenstriche);
  IF min MOD feinstep <> 0.0
    THEN wert := runde auf (min,feinstep);
    ELSE wert := min
  FI;
  INT VAR zaehler :: int( wert MOD step / feinstep + 0.5);
  WHILE wert <= max REP
    IF wert = 0.0
      THEN ziehe nullstrich
    ELIF zaehler MOD zwischenstriche = 0
      THEN ziehe normstrich
      ELSE ziehe feinstrich
    FI;
    wert INCR feinstep;
    zaehler INCR 1
  PER;
  zeichne achse;
  achse.

  zwischenstriche:
    IF type = 2
      THEN 4
      ELSE 5
    FI.

  ziehe nullstrich:
    REAL VAR p0 :: pos + real (mode) * strich * 3.0,
             p1 :: pos - strich * 3.0;
    ziehe linie.

  ziehe normstrich:
    p0 := pos + real (mode) * strich * 2.0;
    p1 := pos - strich * 2.0;
    ziehe linie.

  ziehe feinstrich:
    p0 := pos + real (mode) * strich;
    p1 := pos - strich;
    ziehe linie.

  zeichne achse:
    IF dir = 0
      THEN move (achse,min,pos);
           draw (achse,max,pos)
      ELSE move (achse,pos,min);
           draw (achse,pos,max)
    FI.

  ziehe linie:
    IF dir = 0
      THEN move (achse,wert,p0);
           draw (achse,wert,p1)
      ELSE move (achse,p0,wert);
           draw (achse,p1,wert)
    FI
END PROC axis;

PICTURE PROC beschriftung (REAL VAR xx min,xx max,yy min,yy max,
                           TEXT CONST ueberschrift,
                           BOOL CONST mode):
 PICTURE VAR rahmen :: nilpicture;
 beschrifte;
 rahmen.

 beschrifte :
    REAL VAR x cm,y cm;
    INT VAR dummy;
    drawing area (x cm,y cm,dummy,dummy);
    erweitere;
    zeichne x achse;
    zeichne y achse;
    zeichne ueberschrift;
    xx max := xn max;
    xx min := xn min;
    yy max := yn max;
    yy min := yn min.

  erweitere:
    REAL VAR hoehe  :: din a4 hoehe  / 23.5 * y cm,   { der Zeichen }
             breite :: din a4 breite / 30.5 * x cm;
    INT CONST anzahl y stellen :: max (stellen (yy min),stellen (yy max)),
              anzahl x stellen :: max (stellen (xx min),stellen (xx max));
    REAL VAR xn min :: xx min,
             xn max :: xx max,
             yn min :: yy min;
    IF mode                                      { rahmen wg clipping }
      THEN xn min DECR (xx max - xx min) / 30.0;
           yn min DECR (yy max - yy min) / 30.0
    FI;
    REAL VAR xx dif :: xx max - xn min,
             yy dif :: yy max - yn min,
             yn dif :: y cm / (y cm - 2.0 * hoehe / 10.0 - 0.4) * yy dif,
             xn dif :: x cm / (x cm - x erweiterung) * xx dif,
             y 1 mm :: yn dif / y cm / 10.0,
             r hoch :: hoehe / y cm / 10.0 * yn dif,
             r breit:: breite / x cm / 10.0 * xn dif,
             yn max :: yy max + r hoch + 3.0 * y 1 mm;
    yn min := yn min - r hoch - 2.0 * y 1 mm;
    IF mode
      THEN xn min := xn min - real(anzahl y stellen) * r breit
    FI.

    x erweiterung:
      IF mode
        THEN real(anzahl y stellen) * breite / 10.0
        ELSE 0.0
      FI.

    zeichne x achse:
      TEXT VAR zahl :: text (xx min, anzahl x stellen, nachkomma);
      ersetze zahl;
      move (rahmen, max(xn min, xx min - real(length(zahl)) * r breit / 2.0),
                    yn min);
      draw (rahmen, zahl, 0.0, breite, hoehe);
      zahl := text (xx max, anzahl x stellen, nachkomma);
      ersetze zahl;
      move (rahmen, xx max - real(length(zahl)) * r breit, yn min);
      draw (rahmen, zahl, 0.0, breite, hoehe).

    zeichne y achse:
      zahl := text (yy min, anzahl y stellen, nachkomma);
      ersetze zahl;
      move (rahmen, max (xn min, xx min - real(length(zahl)) * r breit -
                         (xx max - xx min) / 30.0),yy min - r hoch / 2.0);
      draw (rahmen, zahl, 0.0, breite, hoehe);
      zahl := text (yy max,anzahl y stellen,nachkomma);
      ersetze zahl;
      move (rahmen, max (xn min, xx min - real(length(zahl)) * r breit -
                          (xx max - xx min) / 30.0),yy max - r hoch / 2.0);
      draw (rahmen, zahl, 0.0, breite, hoehe).

    zeichne ueberschrift:
      move (rahmen, (xx max + xx min - real(length(ueberschrift)) * r breit)
                    / 2.0, yy max + y 1 mm);
      draw (rahmen, ueberschrift, 0.0, breite, hoehe).

    ersetze zahl:
      change all (zahl, ".", ",")

END PROC beschriftung;

INT PROC stellen (REAL CONST r):
  IF r = 0.0
    THEN nachkomma + 2
    ELSE nachkomma + 3 + max (0, int ( round(log10 (abs(r)),nachkomma)))
  FI
END PROC stellen

END PACKET funktionen;

PACKET fkt manager DEFINES fkt manager:
 
LET continue code = 100, 
    ack           = 0,
    nack          = 1; 
 
DATASPACE VAR dummy space;
INT VAR order;
TASK VAR order task;

PROC fkt manager:
   set autonom;
   disable stop;
   break (quiet);
   REP
      forget (dummy space);
      wait (dummy space, order, order task);
      IF order >= continue code AND order task = supervisor
         THEN call (supervisor, order, dummy space, order);
              IF order = ack
                 THEN fkt online
              FI;
              set autonom;
              command dialogue (FALSE);
              forget (ALL myself)
         ELSE send (order task, nack, dummy space)
      FI
   PER.

   fkt online:
      command dialogue (TRUE);
      fktplot;
      IF online
         THEN eumel must advertise;
              break (quiet)
      FI
END PROC fktmanager

END PACKET fktmanager