path: root/app/mpg/1987/src/GRAPHIK.Configurator

(**************************************************************************) 
(*                                                                        *) 
(*                        MPG - Graphik - System                          *) 
(*                                                                        *) 
(*                      Version 2.2 vom 11.11.1987                        *) 
(*                                                                        *) 
(*            (c) 1987 Beat Jegerlehner & Carsten Weinholz                *) 
(*                unter Verwendung der Standard-Graphik                   *) 
(*          "Graphik-Konfiguration" geschrieben von C.Weinholz            *) 
(*                                                                        *) 
(**************************************************************************) 
(*                                                                        *) 
(*                          Graphik-Konfiguration                         *) 
(*                                                                        *) 
(*              Erstellung eines fuer alle Engeraete gueltigen            *) 
(*                Basisgraphik-Paketes durch zusammenfuegen               *) 
(*                           von '.GCONF'-Dateien                         *) 
(*                                                                        *) 
(*            Aufruf durch 'configurate graphik', wenn insertiert         *) 
(*                      (normalerweise nicht notwendig)                   *) 
(*             Bei 'run' muss 'configurate graphik' ans Dateiende         *) 
(*                            geschrieben werden.                         *) 
(*                                                                        *) 
(**************************************************************************) 
PACKET graphik configuration DEFINES configurate graphik: 
 
LET PLOTTERCONF = STRUCT (TEXT name, station, channel, area, prep, init, end, 
                               clear, home, move, draw, pixel, foreground, 
                               background, palette, std colors, circle, box, 
                               fill, cursor, get cursor, set marker, linked,
                               BOOL editor, 
                               BOOL no plotter); 
LET max conf      = 15,
    dquote        = ""34""34"",
    interface     = "GRAPHIK.Configuration", 
    env conf file = "ENVIRONMENT.GCONF",
    packet header = "PACKET device interface DEFINES prepare, init plot, endplot, clear, home, moveto, drawto, setpixel, foreground, background, set color, stdcolors, color, colors, set palette, circle, box,fill,graphik cursor, get cursor, set marker:",
    packet end    = "END PACKET device interface", 
    target        = "TARGET VAR  plotter; initialize target ( plotter);", 
    install target= "install plotter ( plotter);", 
    init set      = "PROC initplot: IF  wsc THEN  palette :=  std palette 
                     ELSE  palette :=  empty palette FI;  initplot; set palette 
                     END PROC initplot;", 
    end set       = "BOOL VAR  we::TRUE; 
                     PROCendplot(BOOL CONSTs): we:=s 
                     END PROCendplot; 
                     PROCendplot: IF weTHEN endplotFI 
                     END PROCendplot;", 
    clear set     = "BOOL VAR  wc::TRUE; PROCclear(BOOL CONSTs): wc:=s  
                     END PROC clear; PROC clear:IF wcTHEN clearFI END PROC clear;", 
    color set     = "BOOL VAR  wsc::TRUE; TEXT VAR  palette; PROC setcolor (INT CONST no,rgb):
                     IF (no+1) <= colors THEN replace( palette,no+1,rgb)
                     FI END PROC set color;", 
    color set2    = "INT PROC colors : length ( palette) DIV 2 END PROC colors; 
                     INT PROC color (INT CONST no): IF no >= 0  AND (no+1) <= colors 
                     THEN  palette ISUB (no+1) ELSE maxint FI END PROC color;", 
    std colors    = "PROCstdcolors(BOOL CONSTs):  wsc:=s END PROCstdcolors; 
                     PROC stdcolors:IF wscTHEN palette :=  std palette;set palette FI END PROCstdcolors;", 
    foreground    = "INT VAR af::1; INT PROCforeground: af END PROCforeground; 
                     PROCforeground(INT CONSTm):  af:=m; foreground( af) END PROCforeground;",  
    background    = "INT VAR  ab::0; INT PROCbackground: ab END PROCbackground; 
                     PROCbackground(INT CONSTm):  ab:=m; background( ab) END PROCbackground;"; 

ROW max conf PLOTTERCONF VAR plotter; 
ROW max conf DATASPACE VAR global data; 
 
TEXT CONST spaces :: 20 * " ";
INT VAR inst plotter, targets, error line :: 0;
TEXT VAR errorm1, errorm2, procvalue :: "", env conf, error source :: "";
BOOL VAR errors :: FALSE; 
FILE VAR f; 
DATASPACE VAR conf ds; 
THESAURUS VAR plotconfs; 
 
PROC configurate graphik: 
   FOR inst plotter FROM 1 UPTO max conf REP 
       act plotter.name := ""; 
       act plotter.area := ""; 
       act plotter.prep := "";
       act plotter.init := ""; 
       act plotter.end  := ""; 
       act plotter.clear:= ""; 
       act plotter.home := ""; 
       act plotter.move := ""; 
       act plotter.draw := ""; 
       act plotter.pixel:= ""; 
       act plotter.foreground := ""; 
       act plotter.background := ""; 
       act plotter.palette    := ""; 
       act plotter.circle     := ""; 
       act plotter.box        := "";  
       act plotter.fill       := ""; 
       act plotter.cursor     := ""; 
       act plotter.get cursor := ""; 
       act plotter.set marker := ""; 
       act plotter.linked     := "";
       act plotter.editor     := FALSE; 
    PER; 
    env conf := "";
    inst plotter := 0; 
    plotconfs := empty thesaurus; 
    IF exists (env conf file) 
       THEN plotconfs := ALL env conf file 
    FI; 
    plotconfs := SOME (plotconfs + (all LIKE "*.GCONF") - env conf file);  
    INT VAR id :: 0; TEXT VAR conf file; 
    get (plotconfs, conf file, id); 
    WHILE id > 0 REP 
       IF exists (conf file) 
          THEN extract conf data (conf file)  
          ELSE get environment plotter
       FI;
       get (plotconfs, conf file, id); 
    PER; 
    IF inst plotter > 0 
       THEN generate interface
       ELSE errorstop ("Kein Interface erzeugt") 
    FI;
    last param (interface). 
 
    get environment plotter: 
       check sequence (conf file, "PLOTTER *,*,*,*,*,*,*;", 
                             "2|4,3,3,3,3,3,3;", 
                             "PLOTTER erwartet,"+ 
                             "Name erwartet,,"+ 
                             "Station erwartet,,"+ 
                             "Kanal erwartet,,"+ 
                             "XPixel erwartet,,"+ 
                             "YPixel erwartet,,"+ 
                             "Xcm erwartet,,"+ 
                             "Ycm erwartet,,"+ 
                             "Plotterkommando fehlerhaft"); 
       IF errors  
          THEN errorstop (errorm2) 
          ELSE TEXT VAR one int :: ""0""0"", one real :: 8 * ""0"";
               replace (one int,1,length(get var (1))); 
               env conf CAT one int;
               env conf CAT get var (1);
               replace (one int, 1, int (get var (2)));
               env conf CAT one int;
               replace (one int, 1, int (get var (3)));
               env conf CAT one int; 
               replace (one int, 1, int (get var (4)));
               env conf CAT one int; 
               replace (one int, 1, int (get var (5)));
               env conf CAT one int; 
               replace (one real, 1, real (get var (6)));
               env conf CAT one real; 
               replace (one real, 1, real (get var (7))); 
               env conf CAT one real;
       FI 
END PROC configurate graphik; 
 
PROC extract conf data (TEXT CONST conf file): 
   TEXT VAR line;
   inst plotter INCR 1; 
   IF inst plotter > max conf 
      THEN putline ("Warnung: Es koennen nicht mehr als " + text(max conf) + 
                    " Geraete konfiguriert werden"); 
           inst plotter DECR 1 
      ELSE error source := conf file; 
           conf ds := old (conf file); 
           f := sequential file (modify, conf ds); 
           set line numbers;
           IF is plotter configuration 
              THEN get name and area (line, act plotter.name, 
                                            act plotter.station, 
                                            act plotter.channel, 
                                            act plotter.area);
                   get linked    (act plotter.linked);
                   get includes;
                   putline ("""" + act plotter.name + """ wird eingelesen"); 
                   get paramless ("initplot",act plotter.init); 
                   get paramless ("endplot" ,act plotter.end); 
                   get paramless ("clear"   ,act plotter.clear); 
                   get paramless ("home"    ,act plotter.home); 
                   get paramless ("prepare" ,act plotter.prep);
                   get koord     ("moveto"  ,act plotter.move); 
                   get koord     ("drawto"  ,act plotter.draw); 
                   get koord     ("setpixel",act plotter.pixel); 
                   get var param ("foreground",act plotter.foreground); 
                   get var param ("background",act plotter.background); 
                   get paramless ("setpalette",act plotter.palette); 
                   get std colors(act plotter.std colors); 
                   get circle    (act plotter.circle); 
                   get box       (act plotter.box); 
                   get fill      (act plotter.fill); 
                   IF editor available 
                      THEN get graphik cursor (act plotter.cursor); 
                           get get cursor     (act plotter.get cursor); 
                           get set marker     (act plotter.set marker) 
                   FI;
                   push error; 
                   IF anything noted 
                      THEN f := sequential file (modify,conf file); 
                           out (""7"");note edit (f);errorstop("") 
                   FI 
              FI;  
              global data [inst plotter] := conf ds; 
              forget (conf ds) 
   FI. 
 
   is plotter configuration: 
      plotter [inst plotter].no plotter := NOT sequence found ("PLOTTER", 
                                                               line, 1,TRUE);
      NOT plotter [inst plotter].no plotter. 
 
   editor available: 
      plotter [inst plotter].editor := sequence found ("EDITOR", line, 1,TRUE); 
      IF plotter [inst plotter].editor
         THEN delete record (f); 
              check sequence (line, "EDITOR;", "2;",  
                            "EDITOR erwartet,"+ 
                            "Semikolon erwartet," + 
                            "Editorkommando fehlerhaft") 
      FI; 
      plotter [inst plotter].editor. 
 
   set line numbers: 
      INT VAR  line number;
      to line (f,1); 
      FOR line number FROM 1 UPTO lines (f)-1 REP 
          cout (line number);
          insert line number;           
          down (f)
      PER; 
      insert line number. 
 
   insert line number: 
      TEXT VAR new line;
      read record (f, new line); 
      insert char (new line, " ", 1); 
      insert char (new line, " ", 1); 
      replace (new line, 1, line number); 
      write record (f, new line). 
          
   get includes: 
      BOOL VAR include found :: sequence found ("INCLUDE",line, 1, TRUE); 
      WHILE include found REP 
         push error;
         include found := sequence found ("INCLUDE",line, line no (f), TRUE); 
         IF include found 
            THEN add to plotconfs 
         FI 
      PER. 
 
      add to plotconfs: 
         check sequence (line, "INCLUDE *;","2|4;", 
                               "INCLUDE erwartet,Dateiname erwartet," +
                               "Includekommando fehlerhaft");
         IF NOT errors CAND exists (get var (1))
            THEN IF NOT (plotconfs CONTAINS get var (1)) 
                    THEN insert (plotconfs,get var (1))
                 FI;
         ELIF NOT errors
            THEN error ("""" + get var (1) + """ existiert nicht")
         FI;
         delete record (f)
END PROC extract conf data; 
 
PROC generate interface: 
   INT VAR act conf; 
   conf ds := nilspace; 
   forget (interface,quiet); 
   proc value := ""; 
   FILE VAR f :: sequential file (output, conf ds); 
   putline (f,packet header); 
   putline (f,target); 
   generate target;
   putline (f,install target); 
   putline (f,init set);
   putline (f,end set); 
   putline (f,clear set); 
   putline (f,color set); 
   putline (f,color set 2);
   putline (f, std colors);
   putline (f,foreground); 
   putline (f,background); 
   FOR act conf FROM 1 UPTO inst plotter REP 
      FILE VAR source := sequential file (modify,global data [act conf]); 
      copy lines (f,source) 
   PER; 
   generate proc (""," initplot", TEXT PROC (INT CONST) initplotbody); 
   generate proc (""," endplot",  TEXT PROC (INT CONST) endplotbody); 
   generate proc (""," clear",    TEXT PROC (INT CONST) clearbody); 
   generate proc ("","prepare",   TEXT PROC (INT CONST) prepbody);
   proc value := " TEXT";
   generate proc (""," std palette", TEXT PROC (INT CONST) std palette body); 
   generate proc (""," empty palette", TEXT PROC (INT CONST) empty palette body);
   proc value := "";
   generate proc ("","home",     TEXT PROC (INT CONST) homebody); 
   generate proc ("INT CONST x,y","moveto", TEXT PROC (INT CONST) movebody); 
   generate proc ("INT CONST x,y","drawto", TEXT PROC (INT CONST) drawbody); 
   generate proc ("INT CONST x,y","set pixel", TEXT PROC (INT CONST) pixelbody); 
   generate proc ("INT VAR type"," foreground", TEXT PROC (INT CONST) foregroundbody); 
   generate proc ("INT VAR type"," background", TEXT PROC (INT CONST) backgroundbody); 
   generate proc ("","set palette", TEXT PROC (INT CONST) set palette body); 
   generate proc ("INT CONST x,y,rad,from,to","circle", TEXT PROC (INT CONST) circlebody); 
   generate proc ("INT CONST x1,y1,x2,y2,pattern", "box", TEXT PROC (INT CONST) box body); 
   generate proc ("INT CONST x,y,pattern","fill", TEXT PROC (INT CONST) fill body); 
   generate proc ("INT CONST x,y, BOOL CONST on","graphik cursor",TEXT PROC (INT CONST) graphik cursor body); 
   generate proc ("INT VAR x,y, TEXT VAR exit char","get cursor",TEXT PROC (INT CONST) get cursor body); 
   generate proc ("INT CONST x,y, type","set marker",TEXT PROC (INT CONST) set marker body); 
   proc value := "BOOL "; 
   generate proc ("","graphik cursor",TEXT PROC (INT CONST) editor available); 
   generate device link;
   putline (f,packet end); 
   copy (conf ds,interface);
   IF yes ("""" + interface + """ insertieren")
      THEN insert (interface)
   FI.
 
   generate target:
      INT VAR devices :: 0; 
      targets := 0;
      FOR act conf FROM 1 UPTO inst plotter REP 
         TEXT VAR linked :: plotter[act conf].linked,
                  one int:: ""0""0"";
         plotter [act conf].linked := "";
         IF NOT plotter [act conf].no plotter 
             THEN putline (f,"complete target ( plotter,""" + 
                  plotter [act conf].station + "/" + 
                  plotter [act conf].channel + "/" + 
                  plotter [act conf].name + 
                  """,""" + plotter [act conf].area + """);"); 
                  devices INCR 1; 
                  targets INCR 1;
                  replace (one int, 1, devices);
                  plotter [act conf].linked CAT one int; 
                  replace (one int, 1, targets);
                  plotter [act conf].linked CAT one int;
                  IF linked > "" 
                     THEN INT VAR x :: 1; 
                          WHILE x <=  length (linked) DIV 2 REP 
                             putline (f,"complete target ( plotter, """ + 
                             text(linked ISUB x) + "/" + 
                             text(linked ISUB (x+1)) + "/" + 
                             plotter[act conf].name + """,""" + 
                             plotter[act conf].area + """);"); 
                             targets INCR 1; 
                             replace (one int, 1, targets);
                             plotter [act conf].linked CAT one int; 
                             x INCR 2 
                          PER
                  FI
          FI 
      PER; 
      WHILE env conf <> "" REP 
         generate env target (env conf) 
      PER 
END PROC generate interface; 
 
PROC generate env target (TEXT VAR conf):
   INT VAR nlen  :: conf ISUB 1; 
   TEXT VAR tnam :: subtext (conf, 3, 2+nlen); 
   conf := subtext (conf, nlen + 3);
   putline (f,"complete target ( plotter, """ + text (conf ISUB 1) + "/" + 
              text (conf ISUB 2) + "/" + tnam + """,""" + 
              text (conf ISUB 3) + "," + text (conf ISUB 4) + "," + 
              first real + "," + text (conf RSUB 2) + """);");
   conf := subtext (conf, 17). 
 
   first real: 
      conf := subtext (conf, 9); 
      text (conf RSUB 1)
END PROC generate env target; 
 
TEXT PROC initplotbody (INT CONST no): 
   plotter [no].init 
END PROC initplotbody; 
 
TEXT PROC endplotbody (INT CONST no): 
   plotter [no].end 
END PROC endplotbody; 
 
TEXT PROC clearbody (INT CONST no): 
   plotter [no].clear 
END PROC clearbody; 
 
TEXT PROC prepbody (INT CONST no): 
   plotter [no].prep 
END PROC prepbody; 
 
TEXT PROC homebody (INT CONST no): 
   plotter [no].home 
END PROC homebody; 
 
TEXT PROC movebody (INT CONST no): 
   plotter [no].move 
END PROC movebody; 
 
TEXT PROC drawbody (INT CONST no): 
   plotter [no].draw 
END PROC drawbody; 
 
TEXT PROC pixelbody (INT CONST no): 
   plotter [no].pixel  
END PROC pixelbody; 
 
TEXT PROC std palette body (INT CONST no): 
   TEXT CONST rgb codes :: plotter [no].std colors;
   TEXT VAR body :: dquote; 
   INT VAR x; 
   FOR x FROM 1 UPTO length (rgb codes) DIV 3 REP 
      INT VAR color :: int (subtext(rgb codes, (x-1)*3+1, x*3)); 
      body CAT (text (color AND 255) + dquote);
      body CAT (text (color DIV 256) + dquote);
   PER;
   body 
END PROC std palette body;
 
TEXT PROC empty palette body (INT CONST no):
   text (length (plotter[no].std colors) DIV 3) + "*" + dquote +
   "255" + dquote + "127" + dquote
END PROC empty palette body;

TEXT PROC set palette body (INT CONST no): 
   plotter[no].palette 
END PROC set palette body; 
 
TEXT PROC foregroundbody (INT CONST no): 
   plotter [no].foreground 
END PROC foregroundbody; 
 
TEXT PROC backgroundbody (INT CONST no): 
   plotter [no].background 
END PROC backgroundbody; 
 
TEXT PROC circle body (INT CONST no): 
   plotter [no].circle 
END PROC circle body; 
 
TEXT PROC box body (INT CONST no): 
   plotter [no].box  
END PROC box body; 
 
TEXT PROC fill body (INT CONST no): 
   plotter [no].fill 
END PROC fill body; 
 
TEXT PROC graphik cursor body (INT CONST no): 
   plotter [no].cursor 
END PROC graphik cursor body; 
 
TEXT PROC get cursor body (INT CONST no): 
   plotter [no].get cursor 
END PROC get cursor body; 
 
TEXT PROC set marker body (INT CONST no): 
   plotter [no].set marker 
END PROC set marker body; 
 
TEXT PROC editor available (INT CONST no): 
   IF plotter [no].editor 
      THEN "TRUE" 
      ELSE "FALSE" 
   FI 
END PROC editor available; 

PROC generate device link:
   INT VAR actconf;
   putline (f, "INT PROC  act device :");
   putline (f, "SELECT actual plotter OF");
   FOR act conf FROM 1 UPTO inst plotter REP
      IF NOT plotter [act conf].no plotter
         THEN putline (f,"CASE " + text (plotter[act conf].linked ISUB 2) + ":");
              put (f,text (plotter[act conf].linked ISUB 1));
              IF length (plotter[act conf].linked) > 2 
                 THEN generate table 
              FI
      FI 
   PER;
   putline (f,"OTHERWISE errorstop (""Kein Endgeraet angekoppelt"");0"); 
   putline (f,"END SELECT END PROC  act device;").

   generate table: 
      INT VAR x; 
      FOR x FROM 3 UPTO length (plotter[act conf].linked) DIV 2 REP 
         put (f,"CASE"); 
         put (f,text (plotter[act conf].linked ISUB x)); 
         put (f,":"); 
         put (f, text (plotter[act conf].linked ISUB 1))
      PER 
END PROC generate device link; 

PROC generate proc (TEXT CONST params,procname,TEXT PROC (INT CONST)procbody): 
   INT VAR actconf, no plotter :: 0; 
   IF params = "" 
      THEN putline (f,procvalue + " PROC " + procname + ":") 
      ELSE putline (f,procvalue + " PROC " + procname + "(" + params + "):") 
   FI; 
   IF procvalue <> "" 
      THEN putline (f,procvalue + " VAR  d;") 
   FI; 
   putline (f,"SELECT  act device OF");  
   FOR act conf FROM 1 UPTO inst plotter REP 
       IF NOT plotter [act conf].no plotter 
          THEN putline (f, "CASE " + text (act conf-no plotter) + ":" + 
                           lowercase(plotter[act conf].name) + 
                           plotter [act conf].channel + procname) 
          ELSE no plotter INCR 1 
       FI 
   PER; 
   IF procvalue <> "" 
      THEN putline (f," OTHERWISE  d END SELECT")
      ELSE putline (f," END SELECT") 
   FI; 
   FOR act conf FROM 1 UPTO inst plotter REP                                 
       IF NOT plotter [act conf].no plotter 
          THEN putline (f,"."); 
               putline (f,lowercase(plotter[act conf].name)+ 
                          plotter[act conf].channel + procname + ":"); 
                          putline (f,procbody (act conf)) 
       FI 
   PER; 
   putline (f,"END PROC "+ procname +";") 
END PROC generate proc;      
 
PROC get name and area (TEXT CONST line, TEXT VAR name, station, channel, area): 
   push error; 
   check sequence (line, "PLOTTER *,*,*,*,*,*,*;", 
                         "2|4,3,3,3,3,3,3;", 
                         "PLOTTER erwartet,"+ 
                         "Name erwartet,,"+ 
                         "Station erwartet,,"+ 
                         "Kanal erwartet,,"+ 
                         "XPixel erwartet,,"+ 
                         "YPixel erwartet,,"+ 
                         "Xcm erwartet,,"+ 
                         "Ycm erwartet,,"+ 
                         "Plotterkommando fehlerhaft"); 
   name    := get var (1); 
   station := get var (2); 
   channel := get var (3); 
   area := ""; 
   area CAT (get var (4) + ","); 
   area CAT (get var (5) + ","); 
   area CAT (get var (6) + ","); 
   area CAT (get var (7) + ","); 
   delete record (f)
END PROC get name and area; 
 
PROC get linked (TEXT VAR keep):
   TEXT VAR line;
   IF sequence found ("LINK", line, 1, TRUE)
      THEN extract data;
           delete record (f)
   FI.  
 
   extract data: 
      TEXT VAR symbol, one int :: ""0""0"";
      INT VAR ltyp :: 2,type :: 0;(* 0 = ',' 1 = '/' 2 = Station 3 = Kanal*) 
      push error;                 (* 4 = Ende erwartet ! *)
      keep := "";
      errorm1 := line; 
      scan (line);
      next symbol (symbol);
      IF symbol <> "LINK"
         THEN error ("LINK erwartet")
      FI;
      WHILE type < 7 AND NOT errors REP 
         next symbol (symbol, type); 
         IF ltyp = 0 
            THEN IF symbol = "," 
                    THEN ltyp := 2 
                 ELIF symbol = ";" 
                    THEN ltyp := 4 
                    ELSE error ("Semikolon oder Komma erwartet") 
                 FI
         ELIF ltyp = 1 
            THEN IF symbol = "/" 
                    THEN ltyp := 3 
                    ELSE error ("'/' erwartet")
                 FI
         ELIF ltyp = 4 
            THEN IF type = 8 
                    THEN error ("Kommentarende fehlt") 
                 ELIF type = 9 
                    THEN error ("Text unzulaessig (Textende fehlt)") 
                 ELIF type <> 7 
                    THEN error ("Zeilenende nach Semikolon erwartet") 
                 FI 
         ELIF type = 3  
            THEN replace (one int, 1, int (symbol)); 
                 keep CAT one int; 
                 ltyp DECR 1;
                 IF ltyp = 2 
                    THEN ltyp := 0 
                 FI 
      FI
   PER
END PROC get linked; 
 
PROC get graphik cursor (TEXT VAR keep): 
   get proc ("graphik cursor","(INT CONST x,y, BOOL CONST on)", 
             "(2|2 x,y,2|2 on)","INT erwartet, CONST erwartet,"+ 
             "Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,"+ 
             "BOOL erwartet, CONST erwartet,"+ 
             "Formaler Parameter muss on heissen", 
             keep); 
END PROC get graphik cursor; 
 
PROC get get cursor (TEXT VAR keep): 
   get proc ("get cursor","(INT VAR x,y, TEXT VAR exit char)", 
             "(2|2 x,y,2|2 exit char)","INT erwartet, VAR erwartet,"+ 
             "Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,"+ 
             "TEXT erwartet, VAR erwartet,"+ 
             "Formaler Parameter muss exit char heissen", 
             keep); 
END PROC get get cursor; 
 
PROC get set marker (TEXT VAR keep): 
   get proc ("set marker","(INT CONST x,y,type)","(2|2 x,y,type)", 
             "INT erwartet, CONST erwartet,"+ 
             "Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,"+ 
             "Formaler Parameter muss type heissen", 
             keep); 
END PROC get set marker; 
 
PROC get std colors (TEXT VAR keep): 
   TEXT VAR line;
   push error; 
   IF sequence found ("COLORS", line, 1, TRUE)
      THEN extract data 
      ELSE error ("COLORS fehlt") 
   FI.  
 
   extract data: 
      check sequence (line, "COLORS *;","2|4;", 
                            "COLORS erwartet,"+ 
                            "Rgbcodes erwartet,Semikolon fehlt"); 
      keep := get var (1); 
      delete record (f); 
END PROC get std colors; 
 
PROC get paramless (TEXT CONST procname, TEXT VAR keep): 
   get proc (procname, "", "", "", keep) 
END PROC get paramless; 
 
PROC get var param (TEXT CONST procname, TEXT VAR keep): 
   get proc (procname, "(INT VAR type)","(2|2 type)", 
             "INT erwartet, VAR erwartet, Formaler Parameter muss type heissen", 
             keep); 
END PROC get var param; 
 
PROC get koord (TEXT CONST procname, TEXT VAR keep): 
   get proc (procname, "(INT CONST x,y)","(2|2 x,y)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen",keep) 
END PROC get koord; 
 
PROC get circle (TEXT VAR keep): 
   get proc ("circle","(INT CONST x,y,rad,from,to)","(2|2 x,y,rad,from,to)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+ 
             "Formaler Parameter muss y heissen,Formaler Parameter muss rad heissen,"+ 
             "Formaler Parameter muss from heissen,Formaler Parameter muss to heissen", 
             keep); 
END PROC get circle; 
 
PROC get box (TEXT VAR keep): 
   get proc ("box","(INT CONST x1,y1,x2,y2,pattern)","(2|2 x1,y1,x2,y2,pattern)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x1 heissen,"+ 
             "Formaler Parameter muss y1 heissen,Formaler Parameter muss x2 heissen,"+ 
             "Formaler Parameter muss y2 heissen,Formaler Parameter muss pattern heissen", 
             keep); 
END PROC get box; 
 
PROC get fill (TEXT VAR keep): 
   get proc ("fill","(INT CONST x,y,pattern)","(2|2 x,y,pattern)", 
             "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen"+ 
             "Formaler Parameter muss y heissen,Formaler Parameter muss pattern heissen", 
             keep); 
END PROC get fill; 
 
PROC get proc (TEXT CONST procname, psym, ptyp, perr, 
               TEXT VAR   keep): 
   TEXT VAR line;
   push error; 
   IF sequence found ("PROC"+procname, line, 1, TRUE) 
      THEN errors := FALSE;
           get body (line,procname,psym,ptyp,perr,keep)
      ELSE error (procname + " nicht gefunden") 
   FI
END PROC get proc; 
 
PROC get body (TEXT CONST header,procname,psyms,ptypes ,perrs, TEXT VAR keep body): 
   INT VAR start, ende; 
   start := line no(f); 
   keep body := ""; 
   check sequence (header, "PROC " + procname + psyms + ":", 
                         "2|1"+ ptypes + ":", 
                         "PROC erwartet,"      + 
                          procname + " erwartet,,"+ 
                          perrs+ 
                         ",Fehler in " + procname + "-Header"); 
   IF NOT errors
      THEN get to end of proc
   FI.

   get to end of proc:
      TEXT VAR last;
      errors := FALSE; 
      IF sequence found ("END PROC " + procname,  last, line no(f),FALSE)
         THEN ende := line no (f); 
              check sequence (last, "END PROC " + procname + ";", 
                                    "2|2|1;", 
                                    "END erwartet,"+ 
                                    "PROC erwartet,"+ 
                                    "PROC heisst " + procname + 
                                    ",Semikolon fehlt"); 
              IF NOT errors 
                 THEN to line (f,start); 
                      delete record (f); 
                      INT VAR lc; 
                      FOR lc FROM start UPTO ende-2 REP 
                          TEXT VAR scratch; 
                          read record (f,scratch); 
                          scratch := subtext (scratch, 3);
                          keep body CAT (" " + scratch); 
                          delete record (f); 
                      PER; 
                      delete record (f)
              FI 
         ELSE error ("END PROC " + procname + " nicht gefunden") 
      FI 
END PROC get body; 
 
BOOL PROC sequence found (TEXT CONST sequence text, 
                          TEXT VAR   sequence line, INT CONST from line,
                          BOOL CONST evtl at): 
   BOOL VAR found :: FALSE, at char :: evtl at;
   to line (f,from line);
   col (f,1);
   WHILE NOT (found OR eof (f)) REP 
      cout (line no (f));
      to first char; 
      IF found 
         THEN read record (f, sequence line);
              error line := sequence line ISUB 1;
              sequence line := subtext (sequence line, 3); 
              scan sequence
      FI
   PER; 
   IF NOT found 
      THEN read record (f, sequence line);
           IF pos (first char, sequence line) > 0 
              THEN scan sequence 
           FI
   FI;
   found.
 
   to first char: 
      IF at char
         THEN downety (f, first char)
         ELSE down (f, first char)
      FI; 
      at char := FALSE;
      found := pattern found. 
 
   scan sequence: 
      TEXT VAR source symbols,symbols;
      scan (sequence text); 
      get symbols;
      source symbols := symbols;
      scan (sequence line); 
      get symbols; 
      found := pos (symbols,source symbols) = 1.

   get symbols: 
      TEXT VAR symbol;
      INT VAR type;
      symbols := "";
      REP 
          next symbol (symbol, type); 
          symbols CAT symbol
      UNTIL type > 6 PER. 
 
   first char: 
      sequence text SUB 1 
END PROC sequence found; 
 
PROC error (TEXT CONST emsg): 
   IF NOT eof (f) 
      THEN read record (f,errorm1); 
           errorm1 := """" + error source + """, Zeile " + 
                      text (error line) + ":"
      ELSE errorm1 := """" + error source + """, Fileende:" 
   FI; 
   errorm2 := spaces + emsg; 
   errors  := TRUE  
END PROC error; 
 
PROC push error: 
  IF errors 
     THEN note (errorm1);note line; 
          note (10* " " + errorm2); note line; 
          errors := FALSE 
  FI 
END PROC push error; 
 
 (* Hinweis: bei Fehlermeldungen statt Blank ' ' (geschuetzt) verwenden. 
             Bei verschiedenen Typen ohne trennenden Delimiter zur 
             Abgrenzung in 'seq typ' '|' verwenden. 
             '*' wird in 'seq sym' als Wildcard verwendet (Itemweise) 
             Bei Delimitern wird der 'allgemeine Fehler' (letzter i.d Liste) 
             verwendet. Jedoch muss auch fuer Delimiter ein Eintrag 
             in der Liste freigehalten werden (...,,... oder ...,dummy,...). 
*) 
 
ROW 100 STRUCT (TEXT sym, INT typ, BOOL var) VAR seqlist; 
INT VAR scanpos; 
 
TEXT PROC get var (INT CONST no): 
   INT VAR count :: 0, checkpos :: 1; 
   WHILE checkpos <= scanpos REP 
      IF seqlist[checkpos].var 
         THEN count INCR 1; 
              IF count >= no 
                 THEN LEAVE get var WITH seqlist[checkpos].sym 
              FI 
      FI; 
      checkpos INCR 1  
   PER;"" 
END PROC get var; 
 
PROC check sequence (TEXT CONST seq, seq sym, seq typ, seq err): 
   ROW 100 TEXT VAR err; 
   INT VAR checkpos,erpos, typ, error1 :: 0,error2 :: 0; 
   TEXT VAR sym; 
   scan (seq err); 
   next symbol (sym, typ); 
   erpos := 1; 
   err[erpos] := ""; 
   REP 
       SELECT typ OF 
         CASE 5: err[erpos] CAT " " 
         CASE 6: erpos INCR 1; 
                 err [erpos] := "" 
       OTHERWISE err[erpos] CAT sym 
       END SELECT; 
       next symbol (sym, typ) 
    UNTIL typ >= 7 PER; 
    scan (seq); 
    FOR scanpos FROM 1 UPTO 100 REP 
       next symbol (seqlist[scanpos].sym,seqlist[scanpos].typ); 
    UNTIL seqlist[scanpos].typ >= 7 PER; 
    SELECT seqlist[scanpos].typ OF 
      CASE 8: error ("Kommentarende fehlt") 
      CASE 9: error ("Textende fehlt") 
      OTHERWISE IF scanpos = 100 
                   THEN error ("Kommando zu schwierig") 
                FI 
    END SELECT; 
    scan (seq sym); 
    FOR checkpos FROM 1 UPTO scanpos REP 
       next symbol (sym, typ); 
       IF sym = "*" 
          THEN seqlist[checkpos].var := TRUE 
          ELSE seqlist[checkpos].var := FALSE 
       FI 
    PER; 
    scan (seq typ); 
    next symbol (sym,typ); 
    FOR checkpos FROM 1 UPTO scanpos REP 
       WHILE sym = "|" REP 
         next symbol (sym, typ) 
       PER; 
       BOOL VAR std err :: typ <> 3;  
       IF NOT std err 
          THEN typ := int(sym); 
               IF seqlist[checkpos].typ <> typ 
                  THEN error1 := checkpos 
               FI; 
       ELIF seqlist[checkpos].sym <> sym 
          THEN error1 := erpos 
       FI; 
       next symbol (sym, typ) 
    UNTIL error1 > 0 OR typ >= 7 PER; 
    scan (seq sym); 
    next symbol (sym,typ); 
    FOR checkpos FROM 1 UPTO scanpos-1 REP 
       std err := typ = 6; 
       IF (seqlist[checkpos].sym <> sym) AND (sym <> "*") 
          THEN IF std err 
                  THEN error2 := erpos 
                  ELSE error2 := checkpos 
               FI 
       FI; 
       next symbol (sym, typ) 
    UNTIL error2 > 0 PER; 
    IF error1 = 0 
       THEN error1 := error2 
    ELIF error1 = erpos 
       THEN IF (error2 <> 0) AND (error2 <> erpos) 
               THEN error1 := error2 
            FI 
    FI;  
    IF error1 > 0 
       THEN error (err [error1]) 
    FI 
END PROC check sequence; 
 
INT PROC lower pair (INT CONST upper pair): 
   INT VAR lower :: upper pair; 
   set bit (lower,5); 
   set bit (lower,13); 
   lower 
END PROC lower pair; 
 
TEXT PROC lower case (TEXT CONST uppercase): 
   TEXT VAR lower :: uppercase; 
   INT VAR x; 
   IF length(lower) MOD 2 <> 0 
      THEN lower CAT ""0"" 
   FI ; 
   FOR x FROM 1 UPTO length(lower)DIV2 REP 
      replace (lower,x,lower pair (lower ISUB x)) 
   PER; 
   lower  
END PROC lower case; 
 
PROC copy lines (FILE VAR dest, source): 
   INT VAR l; 
   input(source); 
   output(dest); 
   FOR l FROM 1 UPTO lines (source) REP 
      TEXT VAR scratch,test; 
      getline (source,scratch); 
      scratch := subtext (scratch,3);
      test := scratch; 
      change all (test," ",""); 
      IF test <> "" 
         THEN putline (dest, scratch) 
      FI 
   PER 
END PROC copy lines;

.act plotter:
   plotter[inst plotter]
 
END PACKET graphik configuration; 
configurate graphik