diff options
Diffstat (limited to 'app')
58 files changed, 22630 insertions, 0 deletions
diff --git a/app/misc-games/unknown/src/LINDWURM.ELA b/app/misc-games/unknown/src/LINDWURM.ELA new file mode 100644 index 0000000..57de114 --- /dev/null +++ b/app/misc-games/unknown/src/LINDWURM.ELA @@ -0,0 +1,337 @@ +PACKET lind wurm DEFINES lindwurm:
+deklaration;
+LET max = 500,zeilen = 23,spalten = 77;
+
+PROC kriech :
+ speicher := stelle;
+ REP
+ putline(""1"Punkte:"+text(punkte + bonus) + ""6""0""30"Zeit:" + zeit);
+ IF punkte <> 0
+ THEN ende INCR 1;
+ IF ende > max THEN ende := 1 FI;
+ laenge := laenge + 1 - zaehler;
+ IF laenge > max THEN laenge := 1 FI;
+ wurm(ende) := speicher;
+ IF zaehler = 0 AND wurm(laenge) >= basis AND wurm(laenge) < (basis+(spalten*zeilen))
+ THEN poke(wurm(laenge),leerzeichen)
+ FI;
+ IF speicher >= basis AND speicher < (basis+(spalten*zeilen)) THEN
+ poke(speicher,char1)
+ FI
+ ELSE IF speicher >= basis AND speicher < (basis+(spalten*zeilen))
+ THEN poke (speicher,leerzeichen)
+ FI;
+ FI;
+ zaehler := 0;
+ speicher INCR richtung;
+ IF peek(speicher) <> leerzeichen THEN nahrung oder gift FI;
+ IF speicher >= basis AND speicher < (basis+(spalten*zeilen)) THEN poke(speicher,char2) FI;
+ tastaturabfrage;
+ IF punkte > begrenzung THEN x := int(zeit); index := 1 FI;
+ IF zeit > stopzeit THEN index := 2 FI;
+ UNTIL index <> 0 PER
+ENDPROC kriech;
+
+PROC nahrung oder gift :
+ IF peek(speicher) <> char 3 THEN index := 3
+ ELSE punkte INCR 10; zaehler := 1
+ FI;
+ENDPROC nahrung oder gift;
+
+PROC tastaturabfrage :
+ taste := incharety(9 DIV geschwindigkeit);
+ feuer := taste = ""13"";
+ IF feuer THEN richtung := 0
+ ELIF taste = ""10"" THEN richtung INCR spalten
+ ELIF taste = ""8"" THEN richtung DECR 1
+ ELIF taste = ""2"" THEN richtung INCR 1
+ ELIF taste = ""3"" THEN richtung DECR spalten
+ FI
+ENDPROC tastatur abfrage;
+
+PROC bonus erreicht :
+ x := (int(stopzeit)-x) * schwierigkeit;
+ cspalte := 10;
+ czeile := 10;
+ cursorpositionieren;
+ putline("B O N U S ! ! !");
+ line;
+ putline(""15" "+text(x)+" Punkte !!!"14"");
+ bonus := bonus + punkte + x;
+ENDPROC bonus erreicht;
+
+PROC poke (INT CONST stelle,wert) :
+ INT VAR x pos := 1 + ((stelle - basis) MOD spalten),
+ y pos := 1 + ((stelle - basis) DIV spalten);
+ cursor(x pos,y pos);
+ IF wert = 126 THEN out(""15""8""14"") ELSE
+ out(code(wert));
+ FI;
+ bildschirm (x pos)(y pos) := wert;
+ENDPROC poke;
+
+INT PROC peek (INT CONST stelle) :
+ INT VAR x pos := 1 + ((stelle - basis) MOD spalten),
+ y pos := 1 + ((stelle - basis) DIV spalten);
+ bildschirm (x pos)(y pos)
+ENDPROC peek;
+
+PROC cursorpositionieren :
+ bildschirm zeile := basis + spalten*czeile;
+ cursor(cspalte+1,czeile+1);
+ENDPROC cursor positionieren;
+
+PROC highscore und platznummer :
+ punkte := punkte + bonus;
+ bonus := 0;
+ IF punkte > highscore THEN highscore := punkte FI;
+ player counter INCR 1;
+ q := player counter + 1;
+ spieler punkte(playercounter) := punkte;
+ FOR i FROM 1 UPTO playercounter REP
+ IF punkte > spielerpunkte (i) THEN q DECR 1 FI;
+ PER;
+ c spalte :=10;
+ czeile := 10;
+ cursorpositionieren;
+ putline("Hoechstpunktzahl "+text(highscore));line;
+ putline(" Punkte :"+text(punkte));
+ putline(" Platznr.:"+text(q-1));
+ IF q-1 >= 10 THEN inchar(hilf)
+ ELSE put("Name des Gewinners:");
+ getline(hilf);
+ disablestop;
+ FOR i FROM playercounter DOWNTO q REP
+ spielername(i+1) := spielername(i);
+ IF iserror THEN clearerror; spielername(i+1) := "" FI;
+ PER;
+ enablestop;
+ spielername(q-1) := "(" +text(punkte) + " Punkte: " + hilf+")";
+ FI;
+ page;
+ putline("Die ersten 10 Gewinner :");
+ disablestop;
+ FOR i FROM 1 UPTO min(playercounter,10) REP
+ putline(text(i)+"."+spielername(i));
+ IF iserror THEN clearerror;spielername(i) := "" FI
+ PER;
+ enablestop;
+ putline("Druecken Sie eine Taste");
+ inchar(hilf);
+ENDPROC highscore und platznummer;
+
+PROC explosion :
+ out(""7"");
+ FOR i FROM ende DOWNTO laenge +1REP
+ IF wurm (i) >= basis AND wurm(i) < (basis+spalten*zeilen) THEN poke(wurm(i),leerzeichen);
+ FI;
+ PER;
+ highscore und platznummer
+ENDPROC explosion;
+
+PROC lindwurm :
+ bonus := 0;
+
+ REP
+ clearscreen;
+ out(""14""1""4"");
+ IF bonus = 0 THEN neues spiel FI;
+ IF bonus > 0 THEN bonusspiel FI;
+ page;
+ rahmen;
+ lebensraum generieren;
+ lindwurm kopf setzen;
+ reset time;
+ kriech;
+ SELECT index OF
+ CASE 1 : bonus erreicht
+ CASE 2 : highscore und platznummer
+ CASE 3 : explosion
+ ENDSELECT
+ UNTIL bonus<= 0 COR no(""1""4""10""10"Noch ein Spiel") PER
+
+ENDPROC lindwurm;
+
+PROC neues spiel :
+ basis := 0;
+ stelle := basis + spalten*zeilen DIV 2;
+ schwierigkeit := 4;
+ geschwindigkeit :=9;
+ char 1:= 126;
+ char 2:= 79;
+ char 3:= 42;
+ char 4:= 124;
+ leerzeichen := 32;
+ index := 0;
+ ende := 0;
+ laenge := 0;
+ richtung := 0;
+ zaehler := 0;
+ bonus := 0;
+ punkte := 0;
+ stopzeit :="3:00";
+ vorwahl;
+ begrenzung := 120 * schwierigkeit;
+ENDPROC neues spiel;
+
+PROC liste aller spieler :
+ page;
+ FOR i FROM 1 UPTO playercounter REP
+ putline(text(i)+"."+spielername(i));
+ IF i > 24 THEN pause(20) FI;
+ PER;
+ putline("ENDE");
+ inchar(hilf);
+ page;
+ENDPROC liste aller spieler;
+
+
+PROC vorwahl :
+ spielregeln;
+ page;
+ REP
+ out(""1"");
+ putline(""142" Lindwurm "143"");
+ czeile :=12;
+ cspalte:=3;
+ cursorpositionieren;
+ putline("Schwierigkeitsgrad (1/2) "+ text(schwierigkeit,3));
+ czeile :=14;
+ cspalte:=3;
+ cursorpositionieren;
+ putline("Geschwindigkeit (3/4) "+ text(geschwindigkeit,3));
+ czeile :=16;
+ cspalte:=3;
+ cursorpositionieren;
+ putline("Liste aller Spieler (5) ");
+ czeile :=18;
+ cspalte:=3;
+ cursorpositionieren;
+ putline("Start mit RETURN");
+ x := 0;
+ inchar(hilf);
+ IF hilf = ""13""THEN LEAVE vorwahl
+ ELIF hilf = "1" THEN schwierigkeit INCR 1
+ ELIF hilf = "2" THEN schwierigkeit DECR 1
+ ELIF hilf = "3" THEN geschwindigkeit INCR 1
+ ELIF hilf = "4" THEN geschwindigkeit DECR 1
+ ELIF hilf = "5" THEN liste aller spieler
+ ELSE out(""7"")
+ FI;
+ IF schwierigkeit > 26 THEN schwierigkeit := 1
+ ELIF schwierigkeit < 1 THEN schwierigkeit := 26 FI;
+ IF geschwindigkeit > 9 THEN geschwindigkeit := 1
+ ELIF geschwindigkeit < 1 THEN geschwindigkeit := 9 FI;
+ PER
+
+ENDPROC vorwahl;
+
+PROC spielregeln :
+ putline(code(char1)+" = Rahmen (Mauer)");
+ line;
+ putline(code(char2)+" = Lindwurmkopf");
+ line;
+ putline(code(char3)+" = Nahrung");
+ line;
+ putline(""15""8""14" = Lindwurm");
+ line;
+ putline(". = Gift");
+ line;
+ putline ("Ziel des Spiels ist es, den Wurm mit Nahrung zu versorgen. Gift ist tdlich.");
+ line;
+ putline ("Der Wurm kann mit den Pfeiltasten gesteuert werden. Wird eine Taste mehrmals");
+ line;
+ putline ("gedrckt, wird der Wurm schneller. Vorsicht: Der Wurm darf nicht auf eine");
+ line;
+ putline ("Mauer treffen. Mit jedem gefressenen Nahrungsteilchen wird der Wurm etwas");
+ line;
+ putline ("lnger. Du hast 3 Minuten Zeit, den Wurm zu fttern.");
+ line;
+ putline ("Viel Erfolg. Bitte drcke jetzt eine Taste.");
+ pause(6000);
+ENDPROC spielregeln;
+
+PROC bonusspiel :
+ stelle := basis+zeilen*spaltenDIV2;
+ index := 0;
+ punkte := 0;
+ richtung := 0;
+ zaehler := 0;
+ ende := 0;
+ laenge := 0;
+ schwierigkeit INCR 1;
+ IF schwierigkeit > 26 THEN schwierigkeit := 26 FI;
+ begrenzung := 120 * schwierigkeit
+
+ENDPROC bonusspiel;
+
+PROC lebensraum generieren :
+ FOR i FROM 1 UPTO 16 * schwierigkeit REP
+ REP
+ x := int(random * real((zeilen-2)*spalten) + real(spalten));
+ UNTIL peek(basis+x) = leerzeichen PER;
+ poke(basis+x,char3)
+ PER;
+ FOR i FROM 1 UPTO schwierigkeit REP
+ REP
+ x := int(random * real((zeilen-2)*spalten) + real(spalten));
+ UNTIL peek(basis+x) = leerzeichen PER;
+ poke(basis+x,46)
+ PER;
+ENDPROC lebensraum generieren;
+
+PROC lindwurmkopf setzen :
+ WHILE peek(stelle) <> leerzeichen REP stelle INCR 1 PER;
+ poke(stelle,char2);
+ out(""7"");
+
+ENDPROC lindwurmkopf setzen;
+
+PROC rahmen :
+ FOR i FROM basis UPTO basis + spalten-1 REP
+ poke(i,char4);
+ poke(i+(zeilen-1)*spalten,char4);
+ PER;
+ i := basis + spalten;
+ REP poke(i ,char4);
+ poke(i+spalten-1,char4);
+ i INCR spalten
+ UNTIL i >( basis + (zeilen-1)*spalten )PER
+
+ENDPROC rahmen;
+
+PROC clearscreen :
+ INT VAR x,y;
+ putline ("Nun markiert der Wurm sein Revier.");
+ line ;
+ put("Es ist");put(spalten);put("qm gross.");line;
+ FOR x FROM 1 UPTO spalten REP
+ cout(x);
+ FOR y FROM 1 UPTO zeilen REP
+ bildschirm(x)(y) := leerzeichen
+ PER
+ PER
+ENDPROC clearscreen;
+
+TEXT PROC zeit :
+ subtext(time(clock(1)-uhr),5,8)
+ENDPROC zeit;
+
+PROC reset time :
+ uhr := clock(1)
+ENDPROC reset time;.
+
+deklaration :
+ ROW spalten ROW zeilen INT VAR bildschirm;
+ ROW 300 INT VAR spielerpunkte;
+ ROW 300 TEXT VAR spielername;
+ ROW max INT VAR wurm;
+ TEXT VAR hilf,taste,stopzeit;
+ INT VAR basis:=0,playercounter:=0,highscore:=0,q:=0,i:=0,x:=0,y:=0,stelle:=1000,richtung,
+ punkte:=0,bonus:=0,index:=0,cspalte,czeile,bildschirmzeile,zaehler:=0,ende:=0,
+ laenge:=0,speicher:=1,leerzeichen:=32,begrenzung:=480,schwierigkeit:=4,
+ geschwindigkeit:=9,c:=90,char1:=90,char2:=90,char3:=90,char4:=90;
+
+ REAL VAR uhr;
+ BOOL VAR feuer;
+ENDPACKET lindwurm
diff --git a/app/misc-games/unknown/src/SCHIFFEV.ELA b/app/misc-games/unknown/src/SCHIFFEV.ELA new file mode 100644 index 0000000..2979a2c --- /dev/null +++ b/app/misc-games/unknown/src/SCHIFFEV.ELA @@ -0,0 +1,424 @@ + (* M.Staubermann,15.03.83 *)
+
+PACKET schiffe versenken DEFINES schiffe versenken :
+
+
+(* D E K L A R A T I O N S T E I L *)
+
+
+TEXT VAR eingabe, mitteilung := "";
+INT VAR x pos, y pos, reply;
+BOOL VAR spieler 1, dran;
+ROW 5 INT VAR count := ROW 5 INT : (0,0,0,0,0);
+DATASPACE VAR ds;
+forget(ds);
+ds := nilspace;
+BOUND TEXT VAR msg := ds;
+CONCR(msg) := "";
+TASK VAR gegner,source;
+forget(ds);
+ds:=nilspace;
+BOUND STRUCT (INT x , y) VAR schuss := ds;
+forget(ds);
+CONCR(schuss).x:= 1;
+CONCR(schuss).y := 1;
+ROW 11 ROW 17 TEXT VAR spielfeld;
+LET mark begin = ""15"",
+ mark end = ""14"",
+ return = ""13"",
+ down = ""10"",
+ back = ""8"",
+ bell = ""7"",
+ up = ""3"",
+ vor = ""2"",
+ blank = " ",
+ nil = "",
+ schiffstypen= "5:F4:K3:S2:V1:P";
+
+(* Ende des Deklarationsteils *)
+
+
+
+PROC schiffe versenken :
+ command dialogue(TRUE);
+ REP
+ IF no("Sind die Spielregeln bekannt") THEN page;
+ gib die spielregeln aus;
+ pause(200);
+ FI;
+ page;
+ line(6);
+ putline(" ABCDEFGH");
+ putline(" +--------+");
+ putline("1| |");
+ putline("2| |");
+ putline("3| |");
+ putline("4| |");
+ putline("5| |");
+ putline("6| |");
+ putline("7| |");
+ putline("8| |");
+ putline(" +--------+");
+ putline(" Spielfeld");
+ cursor(20,1);
+ putline("S c h i f f e v e r s e n k e n : ");
+ spiel ausfuehren;page
+ UNTIL no("Noch ein Spiel") PER
+END PROC schiffe versenken;
+
+
+
+PROC gib die spielregeln aus:
+ cursor(15,2);
+ putline("DIE SPIELREGELN :");
+ cursor(15,3);
+ putline("Es gibt fuenf Schiffstypen mit verschieden Laengen, die beim");
+ cursor(15,4);
+ putline("""Gegner"" versenkt werden muessen.Er versenkt sie hier.Dazu");
+ cursor(15,5);
+ putline("geht man mit dem Cursor an die entsprechende Stelle im Spiel -");
+ cursor(15,6);
+ putline("feld und gibt zuerst die Position der Schiffe(waagerecht und ");
+ cursor(15,7);
+ putline("senkrecht) ein und waehrend des Spiels die Position, an der ");
+ cursor(15,8);
+ putline("ein gegnerisches Schiff vermutet wird. Ein Signal ertoent, ");
+ cursor(15,9);
+ putline("wenn man getroffen hat.Von jedem Schiffstyp ist nur ein Schiff");
+ cursor(15,10);
+ putline("erlaubt.Beenden des Spiels mit 'E'. Schiessen mit <RETURN>.");
+ cursor(3,9);
+END PROC gib die spielregeln aus;
+
+
+
+
+PROC botschaft (TEXT CONST message , TEXT CONST darstellen):
+ forget(ds);
+ ds := nilspace;
+ msg := ds;
+ CONCR(msg) := message;
+ REP send(gegner,0,ds,reply) UNTIL reply = 0 PER;
+ IF NOT (darstellen = "") THEN cursor(1,21);
+ putline(darstellen);
+ pause(100);
+ cursor(1,21);
+ leerzeile;
+ cursor(3,9)
+ FI
+END PROC botschaft;
+
+
+
+PROC empfang (TEXT VAR message , BOOL CONST darstellen) :
+ forget(ds);
+ ds := nilspace;
+ REP wait (ds,reply,source) UNTIL (reply = 0) AND (source=gegner)
+ PER;
+ msg := ds;
+ message := CONCR(msg);
+ forget(ds);
+ IF darstellen THEN cursor(1,21);
+ putline(message);
+ pause(100);
+ cursor(1,21);
+ leerzeile;
+ cursor(3,9)
+ FI
+END PROC empfang;
+
+
+
+PROC darstellen (TEXT CONST message) :
+ cursor(1,21);
+ putline(message);
+ pause(100);
+ cursor(1,21);
+ leerzeile;
+ cursor(3,9);
+END PROC darstellen;
+
+
+
+PROC spiel ausfuehren :
+ forget(ds);
+ ds := nilspace;
+ msg := ds;
+ forget(ds);
+ ds := nilspace;
+ schuss := ds;
+ forget(ds);
+ cursor(1,20);
+ putline(mark begin + 28 * blank + "Info an den Spieler" + 28 * blank +
+ mark end);
+ cursor(1,21);
+ put("Task - Name des Mitspielers : ");
+ getline(eingabe);
+ IF exists(task(eingabe)) AND NOT (task (eingabe)
+ = myself) AND NOT (channel(task(eingabe)) < 0)
+ THEN gegner := task(eingabe);
+ putline("Er sitzt an Terminal " + text (channel(gegner)));
+ pause(100);
+ cursor(1,22);
+ leerzeile;
+ cursor(1,21);
+ leerzeile;
+ ELSE putline("Unerlaubter Task - Name !");
+ pause(100);
+ LEAVE spiel ausfuehren
+ FI;
+ darstellen("Mit dem Partner vereinbaren , wer beginnt.");
+ cursor(1,21);
+ spieler 1 := yes("Faengt der Spieler an, der an diesem Terminal sitzt");
+ cursor(1,21);
+ pause(10);
+ leerzeile;
+ IF spieler 1 THEN botschaft (name(myself) + " faengt an !","");
+ ELSE empfang(mitteilung, TRUE)
+ FI;
+ dran := spieler 1;
+ cursor(15,14);
+ putline("Schiffstypen sind :");
+ cursor(15,15);
+ putline("Flugzeugtraeger : FFFFF");
+ cursor(15,16);
+ putline("Kreuzer : KKKK");
+ cursor(15,17);
+ putline("Schnellboote : SSS");
+ cursor(15,18);
+ putline("Versorger : VV");
+ cursor(15,19);
+ putline("Paddelboote : P");
+ cursor(3,9);
+ eingabe der schiffe;
+ spiele eine runde;
+END PROC spiel ausfuehren;
+
+
+
+PROC eingabe der schiffe :
+ count := ROW 5 INT : (0,0,0,0,0);
+ FOR y pos FROM 8 UPTO 17 REP
+ FOR x pos FROM 2 UPTO 11 REP
+ spielfeld[ x pos] [y pos] := ""
+ PER
+ PER;
+ darstellen("Positionieren Sie den Cursor auf die entsprechende Position innerhalb des");
+ darstellen("Spielfeldes und druecken Sie (mit <SHIFT>) die Buchstaben , so dass alle");
+ darstellen("Schiffe auf dem Spielfeld sind.");
+ REP
+ inchar(eingabe);
+ getcursor(x pos , y pos);
+ IF NOT randbegrenzung ueberschritten THEN
+ IF eingabe = "E" THEN IF spieler 1 THEN
+ botschaft(name(myself) + "hoert auf","Spiel beendet");
+ ELSE darstellen("Spiel beendet.")
+ FI;
+ LEAVE eingabe der schiffe
+ ELIF eingabe = "F" THEN wenn moeglich vergroessere("F")
+ ELIF eingabe = "K" THEN wenn moeglich vergroessere("K")
+ ELIF eingabe = "S" THEN wenn moeglich vergroessere("S")
+ ELIF eingabe = "V" THEN wenn moeglich vergroessere("V")
+ ELIF eingabe = "P" THEN wenn moeglich vergroessere("P")
+ ELIF eingabe = " " THEN loesche position
+ ELIF eingabe = "?" THEN gib die spielregeln aus
+ ELIF (eingabe = back) OR (eingabe = vor) OR (eingabe = down)
+ OR (eingabe = up) THEN out(eingabe)
+ ELSE out(bell)
+ FI
+ ELSE out(bell)
+ FI
+ UNTIL alle schiffe eingegeben PER.
+
+
+ loesche position :
+ out(" ");out(""8"");
+ IF NOT (spielfeld [x pos] [y pos] = "") THEN count[int(schiffstypen
+ SUB (pos(schiffstypen,spielfeld[x pos][y pos])-2))] DECR 1
+ FI;
+ spielfeld [x pos] [y pos] := "".
+
+
+
+
+ alle schiffe eingegeben :
+ (count [5] = 5) CAND (count [4] = 4) CAND (count [3] = 3) CAND
+ (count [2] = 2) CAND (count [1] = 1).
+
+
+END PROC eingabe der schiffe;
+
+
+
+ BOOL PROC randbegrenzung ueberschritten :
+ ((eingabe = back) CAND (x pos <= 3)) COR ((eingabe = vor) CAND (x pos >=
+ 10)) COR ((eingabe = down) CAND (y pos >= 16)) COR ((eingabe = up) CAND
+ (y pos <= 9))
+
+END PROC randbegrenzung ueberschritten;
+
+
+
+PROC wenn moeglich vergroessere (TEXT CONST schiff) :
+ IF ((schiff = "F") AND (count [5] < 5)) COR ((schiff = "K") AND
+ (count [4] < 4)) COR ((schiff = "S") AND (count [3] < 3)) COR
+ ((schiff = "V") AND (count [2] < 2)) COR ((schiff = "P") AND
+ (count [1] = 0))
+ THEN IF waagerechter oder senkrechter nachbar AND NOT diagonaler nachbar
+ OR(count [int(schiffstypen SUB (pos(schiffstypen, schiff) - 2))]=0)
+ AND noch kein schiff da
+ THEN count [int(schiffstypen SUB (pos(schiffstypen, schiff) - 2))]
+ INCR 1;
+ out(schiff + ""8"");
+ spielfeld [x pos] [y pos] :=schiff
+ FI
+ FI.
+
+
+
+ waagerechter oder senkrechter nachbar :
+ ((spielfeld [sub x(x pos - 1)] [y pos] = schiff) OR
+ (spielfeld [sub x(x pos + 1)] [y pos] = schiff))XOR
+ ((spielfeld [x pos] [sub y(y pos - 1)] = schiff) OR
+ (spielfeld [x pos] [sub y(y pos + 1)] = schiff)).
+
+
+
+ diagonaler nachbar :
+ (spielfeld [sub x(x pos + 1)] [sub y(y pos + 1)] = schiff) OR
+ (spielfeld [sub x(x pos + 1)] [sub y(y pos - 1)] = schiff) OR
+ (spielfeld [sub x(x pos - 1)] [sub y(y pos + 1)] = schiff) OR
+ (spielfeld [sub x(x pos - 1)] [sub y(y pos - 1)] = schiff) .
+
+
+
+ noch kein schiff da :
+ IF spielfeld[x pos] [y pos] <> "" THEN out(bell);FALSE ELSE TRUE FI.
+
+END PROC wenn moeglich vergroessere;
+
+
+
+INT PROC sub x(INT CONST subscription):
+ IF subscription > 11 THEN 11
+ ELIF subscription < 2 THEN 2
+ ELSE subscription
+ FI
+
+END PROC sub x;
+
+
+
+INT PROC sub y(INT CONST subscription):
+ IF subscription > 17 THEN 17
+ ELIF subscription < 8 THEN 8
+ ELSE subscription
+ FI
+
+END PROC sub y;
+
+
+
+PROC spiele eine runde :
+ IF spieler 1 THEN botschaft(name(myself)+" hat alle Schiffe eingegeben."
+ , "Eingabe der Schiffe beendet.")
+ ELSE empfang(mitteilung , TRUE)
+ FI;
+ REP
+ IF dran THEN darstellen("Jetzt schiessen !");
+ abschiessen
+ ELSE rufe gegner
+ FI;
+ dran := NOT dran;
+ UNTIL kein schiff mehr da PER;
+ gegner hat verloren .
+
+
+
+ kein schiff mehr da :
+ (count [5] = 0) CAND (count [4] = 0) CAND (count [3] = 0) CAND
+ (count [2] = 0) CAND (count [1] = 0).
+
+
+
+ abschiessen :
+ REP
+ inchar(eingabe);
+ getcursor(x pos, y pos);
+ IF NOT randbegrenzung ueberschritten THEN
+ IF eingabe = "E" THEN IF spieler 1 THEN
+ botschaft(name(myself)+" hoert auf.","Spiel beendet.");
+ ELSE darstellen ("Spiel beendet.") FI;
+ LEAVE spiele eine runde
+ ELIF eingabe = return THEN schuss gegner;
+ forget(ds);
+ ds := nilspace;
+ CONCR(schuss).x := x pos;
+ CONCR(schuss).y := y pos;
+ schuss := ds;
+ REP send (gegner,0,ds,reply)
+ UNTIL reply = 0 PER;
+ empfang(mitteilung,TRUE);
+ ELIF eingabe = "?" THEN gib die spielregeln aus
+ ELIF (eingabe = back) OR (eingabe = vor) OR (eingabe = up)
+ OR (eingabe = down) THEN out(eingabe)
+ ELSE out(bell)
+ FI
+ ELSE out(bell)
+ FI
+ UNTIL eingabe = return PER.
+
+
+
+ elem :
+ spielfeld [sub x(CONCR(schuss).x)] [sub y(CONCR(schuss).y)].
+
+
+
+ gegner hat verloren :
+ botschaft("gegner hat verloren","Sie haben gewonnen.Herzlichen Glueckwunsch meinerseits !").
+
+
+ schuss gegner :
+ botschaft("gegner schiesst","").
+
+
+
+ rufe gegner :
+ empfang(mitteilung,FALSE);
+ IF mitteilung = "gegner schiesst" THEN forget(ds);
+ ds := nilspace;
+ REP wait(ds,reply,source)
+ UNTIL (reply = 0) AND (source
+ = gegner) PER;
+ schuss := ds;
+ IF elem <> "" THEN
+ count[int(schiffstypen SUB
+ (pos(schiffstypen,elem)- 2
+ ))] DECR 1;
+ cursor(CONCR(schuss).x,
+ CONCR(schuss).y);
+ out(" ");
+ IF count[int(schiffstypen SUB (pos(schiff
+ stypen,elem) - 2))] = 0
+ THEN botschaft(elem + " versenkt" +
+ bell, "")
+ ELSE botschaft(elem + " getroffen" +
+ bell,"")
+ FI;
+ elem := ""
+ ELSE botschaft("nicht getroffen","")
+ FI;forget(ds)
+ ELIF mitteilung = "gegner hat verloren" THEN
+ botschaft("Spiel beendet",
+ "Sie haben verloren.Tut mir leid.");
+ LEAVE spiele eine runde
+ ELSE darstellen(mitteilung)
+ FI
+END PROC spiele eine runde.
+
+
+leerzeile :
+ 77 TIMESOUT blank
+
+END PACKET schiffe versenken
diff --git a/app/misc-games/unknown/src/SCHIFFEV2.ELA b/app/misc-games/unknown/src/SCHIFFEV2.ELA new file mode 100644 index 0000000..a4b8b0b --- /dev/null +++ b/app/misc-games/unknown/src/SCHIFFEV2.ELA @@ -0,0 +1,409 @@ + (* M.Staubermann,15.03.83 *)
+ (* Korr. 24.05.87 *)
+PACKET schiffe versenken DEFINES schiffe versenken :
+
+
+(* D E K L A R A T I O N S T E I L *)
+
+
+TEXT VAR eingabe, mitteilung := "";
+INT VAR x pos, y pos, reply;
+BOOL VAR spieler 1, dran;
+ROW 5 INT VAR count := ROW 5 INT : (0,0,0,0,0);
+DATASPACE VAR ds;
+forget(ds);
+ds := nilspace;
+BOUND TEXT VAR msg := ds;
+CONCR(msg) := "";
+TASK VAR gegner,source;
+forget(ds);
+ds:=nilspace;
+BOUND STRUCT (INT x , y) VAR schuss := ds;
+forget(ds);
+CONCR(schuss).x:= 1;
+CONCR(schuss).y := 1;
+ROW 11 ROW 17 TEXT VAR spielfeld;
+LET mark begin = ""15"",
+ mark end = ""14"",
+ return = ""13"",
+ down = ""10"",
+ back = ""8"",
+ bell = ""7"",
+ up = ""3"",
+ vor = ""2"",
+ blank = " ",
+ schiffstypen= "5:F4:K3:S2:V1:P";
+
+(* Ende des Deklarationsteils *)
+
+
+
+PROC schiffe versenken :
+ command dialogue(TRUE);
+ REP
+ IF no("Sind die Spielregeln bekannt") THEN page;
+ gib die spielregeln aus;
+ pause(200);
+ FI;
+ page;
+ line(6);
+ putline(" ABCDEFGH");
+ putline(" +--------+");
+ putline("1| |");
+ putline("2| |");
+ putline("3| |");
+ putline("4| |");
+ putline("5| |");
+ putline("6| |");
+ putline("7| |");
+ putline("8| |");
+ putline(" +--------+");
+ putline(" Spielfeld");
+ cursor(20,1);
+ putline("S c h i f f e v e r s e n k e n : ");
+ spiel ausfuehren;page
+ UNTIL no("Noch ein Spiel") PER
+END PROC schiffe versenken;
+
+
+
+PROC gib die spielregeln aus:
+ cursor(15,2);
+ putline("DIE SPIELREGELN :");
+ cursor(15,3);
+ putline("Es gibt fnf Schiffstypen mit verschieden Lngen, die beim");
+ cursor(15,4);
+ putline("""Gegner"" versenkt werden mssen. Er versenkt sie hier. Dazu");
+ cursor(15,5);
+ putline("geht man mit dem Cursor an die entsprechende Stelle im Spiel-");
+ cursor(15,6);
+ putline("feld und gibt zuerst die Position der Schiffe (waagerecht und");
+ cursor(15,7);
+ putline("senkrecht) ein und whrend des Spiels die Position an der ");
+ cursor(15,8);
+ putline("ein gegnerisches Schiff vermutet wird. Ein Signal ertnt,");
+ cursor(15,9);
+ putline("wenn man getroffen hat. Von jedem Schiffstyp ist nur ein Schiff");
+ cursor(15,10);
+ putline("erlaubt. Beenden des Spiels mit 'E'. Schieáen mit <RETURN>.");
+ cursor(3,9);
+END PROC gib die spielregeln aus;
+
+
+
+
+PROC botschaft (TEXT CONST message , TEXT CONST darstellen):
+ forget(ds);
+ ds := nilspace;
+ msg := ds;
+ CONCR(msg) := message;
+ REP send(gegner,0,ds,reply) UNTIL reply = 0 PER;
+ IF NOT (darstellen = "") THEN cursor(1,21);
+ putline(darstellen);
+ pause(100);
+ cursor(1,21);
+ leerzeile;
+ cursor(3,9)
+ FI
+END PROC botschaft;
+
+
+
+PROC empfang (TEXT VAR message , BOOL CONST darstellen) :
+ forget(ds);
+ ds := nilspace;
+ REP wait (ds,reply,source) UNTIL (reply = 0) AND (source=gegner)
+ PER;
+ msg := ds;
+ message := CONCR(msg);
+ forget(ds);
+ IF darstellen THEN cursor(1,21);
+ putline(message);
+ pause(100);
+ cursor(1,21);
+ leerzeile;
+ cursor(3,9)
+ FI
+END PROC empfang;
+
+
+
+PROC darstellen (TEXT CONST message) :
+ cursor(1,21);
+ leerzeile ;
+ putline(message);
+ pause(50);
+ cursor(3,9);
+END PROC darstellen;
+
+
+
+PROC spiel ausfuehren :
+ forget(ds);
+ ds := nilspace;
+ msg := ds;
+ forget(ds);
+ ds := nilspace;
+ schuss := ds;
+ forget(ds);
+ cursor(1,20);
+ putline(mark begin + 28 * blank + "Info an den Spieler" + 28 * blank +
+ mark end);
+ cursor(1,21);
+ put("Task - Name des Mitspielers : ");
+ getline(eingabe);
+ IF exists task(eingabe) AND NOT (task (eingabe)
+ = myself) AND NOT (channel(task(eingabe)) <= 0)
+ THEN gegner := task(eingabe);
+ putline("Er sitzt an Terminal " + text (channel(gegner)));
+ pause(100);
+ cursor(1,22);
+ leerzeile;
+ cursor(1,21);
+ leerzeile;
+ ELSE putline("Unerlaubter Task - Name !");
+ pause(100);
+ LEAVE spiel ausfuehren
+ FI;
+ darstellen("Mit dem Partner vereinbaren, wer beginnt.");
+ cursor(1,21);
+ spieler 1 := yes("Faengt der Spieler an, der an diesem Terminal sitzt");
+ cursor(1,21);
+ pause(10);
+ leerzeile;
+ IF spieler 1 THEN botschaft (name(myself) + " faengt an !","");
+ ELSE empfang(mitteilung, TRUE)
+ FI;
+ dran := spieler 1;
+ cursor(15,14);
+ putline("Schiffstypen sind :");
+ cursor(15,15);
+ putline("Flugzeugtraeger : FFFFF");
+ cursor(15,16);
+ putline("Kreuzer : KKKK");
+ cursor(15,17);
+ putline("Schnellboote : SSS");
+ cursor(15,18);
+ putline("Versorger : VV");
+ cursor(15,19);
+ putline("Paddelboote : P");
+ cursor(3,9);
+ eingabe der schiffe;
+ spiele eine runde;
+END PROC spiel ausfuehren;
+
+
+
+PROC eingabe der schiffe :
+ count := ROW 5 INT : (0,0,0,0,0);
+ FOR y pos FROM 8 UPTO 17 REP
+ FOR x pos FROM 2 UPTO 11 REP
+ spielfeld[ x pos] [y pos] := ""
+ PER
+ PER;
+ darstellen("Positionieren Sie den Cursor auf die entsprechende Position innerhalb des");
+ darstellen("Spielfeldes und drcken Sie (mit <SHIFT>) die Buchstaben, so daá alle");
+ darstellen("Schiffe auf dem Spielfeld sind.");
+ REP
+ inchar(eingabe);
+ getcursor(x pos , y pos);
+ IF eingabe = "E" THEN IF spieler 1 THEN
+ botschaft(name(myself) + "hoert auf","Spiel beendet");
+ ELSE darstellen("Spiel beendet.")
+ FI;
+ LEAVE eingabe der schiffe
+ ELIF eingabe = "F" THEN wenn moeglich vergroessere("F")
+ ELIF eingabe = "K" THEN wenn moeglich vergroessere("K")
+ ELIF eingabe = "S" THEN wenn moeglich vergroessere("S")
+ ELIF eingabe = "V" THEN wenn moeglich vergroessere("V")
+ ELIF eingabe = "P" THEN wenn moeglich vergroessere("P")
+ ELIF eingabe = " " THEN loesche position
+ ELIF eingabe = "?" THEN gib die spielregeln aus
+ ELIF (eingabe = back) AND x pos > 3 THEN out (back)
+ ELIF (eingabe = vor) AND x pos < 10 THEN out (vor)
+ ELIF (eingabe = down) AND y pos < 16 THEN out (down)
+ ELIF (eingabe = up) AND y pos > 9 THEN out(up)
+ FI
+ UNTIL alle schiffe eingegeben PER.
+
+
+ loesche position :
+ out(" ");out(""8"");
+ IF NOT (spielfeld [x pos] [y pos] = "") THEN count[int(schiffstypen
+ SUB (pos(schiffstypen,spielfeld[x pos][y pos])-2))] DECR 1
+ FI;
+ spielfeld [x pos] [y pos] := "".
+
+
+
+
+ alle schiffe eingegeben :
+ (count [5] = 5) CAND (count [4] = 4) CAND (count [3] = 3) CAND
+ (count [2] = 2) CAND (count [1] = 1).
+
+
+END PROC eingabe der schiffe;
+
+
+
+PROC wenn moeglich vergroessere (TEXT CONST schiff) :
+ IF ((schiff = "F") AND (count [5] < 5)) COR ((schiff = "K") AND
+ (count [4] < 4)) COR ((schiff = "S") AND (count [3] < 3)) COR
+ ((schiff = "V") AND (count [2] < 2)) COR ((schiff = "P") AND
+ (count [1] = 0))
+ THEN IF waagerechter oder senkrechter nachbar AND NOT diagonaler nachbar
+ OR(count [int(schiffstypen SUB (pos(schiffstypen, schiff) - 2))]=0)
+ AND noch kein schiff da
+ THEN count [int(schiffstypen SUB (pos(schiffstypen, schiff) - 2))]
+ INCR 1;
+ out(schiff + ""8"");
+ spielfeld [x pos] [y pos] :=schiff
+ FI
+ FI.
+
+
+
+ waagerechter oder senkrechter nachbar :
+ ((spielfeld [sub x(x pos - 1)] [y pos] = schiff) OR
+ (spielfeld [sub x(x pos + 1)] [y pos] = schiff))XOR
+ ((spielfeld [x pos] [sub y(y pos - 1)] = schiff) OR
+ (spielfeld [x pos] [sub y(y pos + 1)] = schiff)).
+
+
+
+ diagonaler nachbar :
+ (spielfeld [sub x(x pos + 1)] [sub y(y pos + 1)] = schiff) OR
+ (spielfeld [sub x(x pos + 1)] [sub y(y pos - 1)] = schiff) OR
+ (spielfeld [sub x(x pos - 1)] [sub y(y pos + 1)] = schiff) OR
+ (spielfeld [sub x(x pos - 1)] [sub y(y pos - 1)] = schiff) .
+
+
+
+ noch kein schiff da :
+ IF spielfeld[x pos] [y pos] <> "" THEN out(bell);FALSE ELSE TRUE FI.
+
+END PROC wenn moeglich vergroessere;
+
+
+
+INT PROC sub x(INT CONST subscription):
+ IF subscription > 11 THEN 11
+ ELIF subscription < 2 THEN 2
+ ELSE subscription
+ FI
+
+END PROC sub x;
+
+
+
+INT PROC sub y(INT CONST subscription):
+ IF subscription > 17 THEN 17
+ ELIF subscription < 8 THEN 8
+ ELSE subscription
+ FI
+
+END PROC sub y;
+
+
+
+PROC spiele eine runde :
+ IF spieler 1 THEN botschaft(name(myself)+" hat alle Schiffe eingegeben."
+ , "Eingabe der Schiffe beendet.")
+ ELSE empfang(mitteilung , TRUE)
+ FI;
+ REP
+ IF dran THEN darstellen("Jetzt schiessen !");
+ abschiessen
+ ELSE rufe gegner
+ FI;
+ dran := NOT dran;
+ UNTIL kein schiff mehr da PER;
+ gegner hat verloren .
+
+
+
+ kein schiff mehr da :
+ (count [5] = 0) CAND (count [4] = 0) CAND (count [3] = 0) CAND
+ (count [2] = 0) CAND (count [1] = 0).
+
+
+
+ abschiessen :
+ REP
+ inchar(eingabe);
+ getcursor(x pos, y pos);
+ IF eingabe = "E" THEN IF spieler 1 THEN
+ botschaft(name(myself)+" hoert auf.","Spiel beendet.");
+ ELSE darstellen ("Spiel beendet.") FI;
+ LEAVE spiele eine runde
+ ELIF eingabe = return THEN schuss gegner;
+ forget(ds);
+ ds := nilspace;
+ CONCR(schuss).x := x pos;
+ CONCR(schuss).y := y pos;
+ schuss := ds;
+ REP send (gegner,0,ds,reply)
+ UNTIL reply = 0 PER;
+ empfang(mitteilung,TRUE);
+ ELIF eingabe = "?" THEN gib die spielregeln aus
+ ELIF (eingabe = back) AND x pos > 3 THEN out (back)
+ ELIF (eingabe = vor) AND x pos < 10 THEN out (vor)
+ ELIF (eingabe = down) AND y pos < 16 THEN out (down)
+ ELIF (eingabe = up) AND y pos > 9 THEN out(up)
+ FI
+ UNTIL eingabe = return PER.
+
+
+
+ elem :
+ spielfeld [sub x(CONCR(schuss).x)] [sub y(CONCR(schuss).y)].
+
+
+
+ gegner hat verloren :
+ botschaft("gegner hat verloren","Sie haben gewonnen.Herzlichen Glueckwunsch meinerseits !").
+
+
+ schuss gegner :
+ botschaft("gegner schiesst","").
+
+
+
+ rufe gegner :
+ empfang(mitteilung,FALSE);
+ IF mitteilung = "gegner schiesst" THEN forget(ds);
+ ds := nilspace;
+ REP wait(ds,reply,source)
+ UNTIL (reply = 0) AND (source
+ = gegner) PER;
+ schuss := ds;
+ IF elem <> "" THEN
+ count[int(schiffstypen SUB
+ (pos(schiffstypen,elem)- 2
+ ))] DECR 1;
+ cursor(CONCR(schuss).x,
+ CONCR(schuss).y);
+ out(" ");
+ IF count[int(schiffstypen SUB (pos(schiff
+ stypen,elem) - 2))] = 0
+ THEN botschaft(elem + " versenkt" +
+ bell, "")
+ ELSE botschaft(elem + " getroffen" +
+ bell,"")
+ FI;
+ elem := ""
+ ELSE botschaft("nicht getroffen","")
+ FI;forget(ds)
+ ELIF mitteilung = "gegner hat verloren" THEN
+ botschaft("Spiel beendet",
+ "Sie haben verloren. Tut mir leid.");
+ LEAVE spiele eine runde
+ ELSE darstellen(mitteilung)
+ FI
+END PROC spiele eine runde ;
+
+
+.leerzeile :
+ out (""5"")
+
+END PACKET schiffe versenken
diff --git a/app/mpg/1987/doc/GDOKKURZ.ELA b/app/mpg/1987/doc/GDOKKURZ.ELA new file mode 100644 index 0000000..f8203f2 --- /dev/null +++ b/app/mpg/1987/doc/GDOKKURZ.ELA @@ -0,0 +1,119 @@ +#type ("hs")##limit (16.0)#
+#type ("prop3.3-24")# #center#*** MPG-GRAPHIK *** #block#
+
+#type ("prop7.5-16")#
+#on ("u")#Einleitung:#off ("u")#
+#type ("prop10-12")#
+
+ Das MPG-Graphik-System ist eine Sammlung von aufein-
+ ander aufbauenden Umgebungs- und Applikationspaketen, in
+ die auch die bisherige EUMEL-Graphik vollstndig integriert
+ ist.
+
+ Folgende Leistungsmerkmale zeichnen die MPG-Graphik aus:
+ - verbesserter und nun auch in der Paket-Hierarchie voll-
+ stndig Endgertunabhngiger EUMEL-Graphik-Kern.
+ - umfassende Dokumentation der EUMEL-Graphik und des
+ MPG-Graphik-Systems.
+ - taskunabhngige und mehrbenutzerfhige Ansteuerung der
+ Endgerte.
+ - normierte Ansteuerung der Endgerte auf unterster
+ Ebene.
+ - indirekte Graphik-Ausgabe.
+ - komfortable Steuerung der Graphik-Ausgabe.
+ - Vollstndige Untersttzung aller von der EUMEL-Graphik
+ vorgesehenen Leistungen:
+ - beliebig breite Linien
+ - frei definierbare Linientypen mit Erhalt des Musters
+ bei verketteten Linien
+ - Ansatzfreie verkettete Linien durch abrundung der
+ Enden.
+ - frei definierbare vektorielle Zeichenstze in beliebiger
+ Gráe und Rotation.
+ - schnelles Clipping an den Kanten der Zeichenflche.
+
+ Desweiteren:
+ - frei definierbare Farben in normierter RGB-Codierung.
+ - automatische Einstellung der EUMEL-Farben auf den
+ Endgerten (abschaltbar).
+ - Automatische Pause nach Abschluá der Ausgabe
+ (abschaltbar, also auch unterbrechungslose Ausgabe
+ mglich).
+ - bereinanderzeichnen mehrerer Zeichnungen mglich.
+ - leichte Anpassung und Integration neuer Endgerte bzw.
+ Endgert-Typen.
+
+#type ("prop7.5-16")#
+#on ("u")#Applikationen:#off ("u")#
+#type ("prop10-12")#
+
+ - der komfortable mengesteuerte Funktionenplotter 'FKT'.
+
+ - die einfach zu programmierende 'TURTLE'-Graphik.
+
+ - der vollintegrierte dynamische Multispool-Manager 'PLOT'.
+
+ - das 'EUCLID'-System zur umfassenden graphischen
+ Funktions- und Kurvendiskussion (in Vorbereitung).
+
+ - der objektorientierte 2D-Graphik-Editor 'GED', auch zur
+ Zeichensatz-Erstellung (in PLanung).
+
+#type ("prop7.5-16")#
+#on ("u")#Zur EUMEL-Graphik:#off ("u")#
+#type ("prop10-12")#
+ - Es wurde die vorletzte Version der EUMEL-Graphik
+ (PICFILE-Typ: 1102) verwendet, da diese einen um-
+ fassenderen Objektumfang (neue Version: keine Hidden-
+ Lines und kein Zeichen in Weltkoordinaten) bietet.
+ Neuere PICFILEs (Typ: 1103) knnen mittels
+ 'GRAPHIK.Convert' in diesen Typ knvertiert werden.
+
+ - Fehler dieser Version (die auch in der neuen Version
+ auftreten) wurden weitgehend beseitigt bzw. in der teil-
+ weise neuerstellten Dokumentation vermerkt.
+
+ - Die Ausgabe von PICTUREs und PICFILEs wurde von den
+ Verwaltungspaketen ('picture' bzw. 'picfile') abgespalten,
+ so daá die Erzeugung von Graphiken auch in der
+ Paket-Hierarchie Endgert-unabhngig mglich ist.
+
+#type ("prop7.5-16")#
+#on ("u")#Zum Graphik-Tasksystem:#off ("u")#
+#type ("prop10-12")#
+ - Jede Task im 'GRAPHIK'-Zweig kann auf jedes Endgert
+ direkt zugreifen, und aufgrund der normierten An-
+ steuerung der Endgerte knnen auch die (schnelleren)
+ Zeichnungs-Primitiva (Gerade ziehen, positionieren usw.)
+ bei Beachtung der Auflsung endgertunabhngig
+ verwendet werden.
+
+ - Die indirekte Ausgabe von PICFILEs ist ber die Task
+ 'PLOT' mglich, dabei kann ber das Netz auch auf
+ Endgerte anderer Stationen zugegriffen werden.
+
+#type ("prop7.5-16")#
+#on ("u")#Zur Ansteuerung der Endgerte:#off ("u")#
+#type ("prop10-12")#
+ Vor der Ausgabe ist mit 'select plotter' das Endgert
+ einzustellen, auf das ausgegeben werden soll.
+ Die vom Graphik-System verwendeten Konstanten
+ ('drawing area' usw.) beziehen sich nunmehr auf das
+ eingestellte Endgert.
+ Bei Verwendung der Zeichnungs-Primitiva ist zu beachten,
+ das diese nur am Endgert-Kanal sinnvoll sind (die ber-
+ einstimmung von Endgert- und Task-Kanal wird aus Zeit-
+ grnden jedoch nicht berprft).
+ Die Ausgabe von PICFILEs erfolgt automatisch richtig, d.h.
+ am Endgert-Kanal direkt, ansonsten indirekt ber die
+ 'PLOT', die zur Ausgabe dynamische Kanal-Server erzeugt.
+
+#type ("prop7.5-16")#
+#on ("u")#Zur Mehrbenutzerfhigkeit:#off ("u")#
+#type ("prop10-12")#
+ Da die Task 'PLOT' fr alle Endgerte auch als Spooler
+ arbeitet, knnen Graphiken als PICFILEs von beliebig vielen
+ Benutzern von jeder Task im Graphik-Zweig aus erstellt
+ und ausgegeben werden (Soweit der Endgert-Kanal nicht
+ direkt genutzt wird), 'PLOT' sorgt dann fr die sequentielle
+ Ausgabe auf dem jeweils zugeordneten Endgert.
diff --git a/app/mpg/1987/doc/GRAPHIK.doc.e b/app/mpg/1987/doc/GRAPHIK.doc.e new file mode 100644 index 0000000..9ea40dd --- /dev/null +++ b/app/mpg/1987/doc/GRAPHIK.doc.e @@ -0,0 +1,2234 @@ +#type ("prop.lq")##limit (16.0)#
+#free(10.0)#
+#headoff##bottomoff#
+
+#type("prop.breit.lq")##center##on("u")#Dokumentation des MPG-Graphik-Systems#off("u")#
+
+#free(1.0)#
+#type("prop")##center#Version 2.1 vom 10.09.87
+
+#free(0.5)#
+#center#(c) 1987 Beat Jegerlehner & Carsten Weinholz
+
+#page#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Inhaltsverzeichnis
+#type("pica.lq")##free(1.0)#
+#type("prop")##limit(16.0)##linefeed(01.0)#
+#type("pica")##on("u")#Inhaltsverzeichnis#off("u")##type("prop.lq")#
+#free(0.5)#
+#type ("prop.lq")##limit (16.0)#
+ Teil 1: Komponenten des Graphik-Systems ................... 1
+ 1.0 GRAPHIK.Basis ................................ 1
+ 2.0 GRAPHIK.Configuration/GRAPHIK.Configurator ... 1
+ 3.0 GRAPHIK.Plot ................................. 1
+ Teil 1.1: Generierung der Graphik ......................... 2
+ Teil 1.2: Tasks des Graphik-Systems ....................... 3
+ 1.0 Task: 'GRAPHIK' .............................. 3
+ 2.0 Task: 'PLOT' ................................. 3
+ 3.0 Task: 'FKT' .................................. 4
+ Teil 2: Operationen der Basisgraphik ...................... 5
+ 1.0 Paket: 'transformation' ...................... 5
+ 2.0 Paket: picture ............................... 8
+ 3.0 Paket: 'picfile' ............................. 13
+ 4.0 Paket: 'devices' ............................. 17
+ Teil 2.1: Operationen des 'device interface' .............. 19
+ 1.0 Paket: 'device interface' .................... 19
+ Teil 2.2: Operationen zur Graphik-Ausgabe ................. 23
+ 2.0 Paket: 'basisplot' ........................... 23
+ 3.0 Paket: 'plot interface' ...................... 27
+ 4.0 Paket: 'plot' ................................ 29
+ Teil 3: Konfigurierung der Graphik ........................ 30
+ Teil 3.1: Der Graphik-Konfigurator ........................ 30
+ Teil 3.2: Erstellung der Konfigurationsdateien ............ 31
+ 1.0 Pseudo-Schlsselworte ........................ 32
+ 2.0 Pseudo-Prozeduren ............................ 34
+ Teil 4: Graphik-Applikationen ............................. 37
+ Teil 4.1: Der Funktionenplotter 'FKT' ..................... 37
+ 1.0 Allgemeines ber FKT ......................... 37
+ 2.0 Das FKT-Menue ................................ 37
+ 3.0 FKT-Menuepunkte .............................. 38
+ Teil 4.2: Die TURTLE-Graphik .............................. 44
+ 1.0 Paket: 'turtlegraphics' ...................... 44
+ Stichwortverzeichnis ....................................... XX
+#page(1)#
+#head on##bottom on#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 1: Komponenten des Graphik-Systems
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 1: Komponenten des Graphik-Systems#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+ Das MPG-Graphik-System besteht aus folgenden Komponenten:
+
+ #ib(1)#1.0 GRAPHIK.Basis#ie(1)#
+
+ 1.1 #ib(2," (1.1)")#PACKET transformation#ie(2,"")#
+ - Transformations- und Umrechnungsprozeduren zur Endgert-
+ unabhngigen Abbildung von PICTURES bzw. PICFILES.
+
+ 1.2 #ib(2," (1.2)")#PACKET picture#ie(2,"")#
+ - Verwaltung des Datentyps PICTURE, der eine Bildebene objekt-
+ orientiert beschreibt.
+
+ 1.3 #ib(2," (1.3)")#PACKET picfile#ie(2,"")#
+ - Verwaltung des Datentyps PICFILE, der ein aus verschiedenen Bild-
+ ebenen (PICTURES) bestehendes Bild und seine (allgemeine) Abbildung
+ auf den Endgerten beschreibt.
+
+ 1.4 #ib(2," (1.4)")#PACKET devices#ie(2,"")#
+ - Allgemeine Verwaltung der verschiedenen Endgerte.
+
+
+ #ib(1)#2.0 GRAPHIK.Configuration/GRAPHIK.Configurator#ie(1)#
+
+ 2.1 #ib(2," (2.1)")#PACKET deviceinterface#ie(2,"")#
+ - Bereitstellung der allgemeinen graphischen Basisoperationen, die
+ fr jedes Endgerat gleichartig vorhanden sind.
+ - Das 'deviceinterface' wird vom 'GRAPHIK.Configurator' bei Bedarf
+ durch geeignetes Zusammenbinden veschiedener Endgert-
+ Konfigurationsdateien automatisch erzeugt.
+
+
+ #ib(1)#3.0 GRAPHIK.Plot#ie(1)#
+
+ 3.1 #ib(2," (3.1)")#PACKET basisplot#ie(2,"")#
+ - Bereitstellung der von der EUMEL-Graphik bentigten
+ Basisoperationen.
+
+ 3.2 #ib(2," (3.2)")#PACKET plotinterface#ie(2,"")#
+ - Paket zur Ansteuerung und Kontrolle der Endgerte.
+
+ 3.3 #ib(2," (3.3)")#PACKET plot#ie(2,"")#
+ - Ausgabeprozeduren fr PICTURES bzw. PICFILES fr alle Endgerte.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 1.1: Generierung der Graphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Es wird zunchst eine Task 'GRAPHIK' (o..) eingerichtet.
+ Das MPG-Graphik-Sytem befindet sich auf der Diskette 'GRAPHIK 2.1':
+
+ - archive ("GRAPHIK 2.1")
+ - fetch ("GRAPHIK.Install",archive)
+ - run ("GRAPHIK.Install")
+
+ 'GRAPHIK.Install' enthlt ein Generierungsprogramm, das die weitere Generierung
+ des Graphik-Systems vornimmt.
+ Existiert auf dem Archiv eine Datei 'GRAPHIK.Configuration', so wird nachge-
+ fragt, ob das Graphiksystem hinsichtlich der anzusteuernden Endgerte neu-
+ konfiguriert('GRAPHIK.Configuration' also in Abhngigkeit von den ebenfalls
+ auf der Diskette vorhandenen Endgert-Konfigurationsdateien neu erstellt
+ werden soll). Fehlt 'GRAPHIK.Configuration', so wird es zwangslufig neu er-
+ stellt (siehe 'Neukonfiguration des Graphik-Systems', S. #to page ("newconf")#).
+ Mit der im Hintergrund ablaufenden Installation des Plotmanagers in der
+ (Sohn-)Task 'PLOT' (siehe 'Funktion von PLOT', S.#to page ("plotmanager")#) steht dann die Graphik allen
+ Sohntasks von 'GRAPHIK' zur Verfgung:
+
+ .
+ .
+ GRAPHIK
+ PLOT
+ FKT
+ EUCLID
+ user
+ usw.
+ .
+ .
+#page#
+#type("pica")##on("u")##ib(1)#Teil 1.2: Tasks des Graphik-Systems#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+ #ib(1)#1.0 Task: 'GRAPHIK'#ie(1)#
+
+ 'GRAPHIK' ist die Ausgangstask des Graphik-Systems; in ihr werden (s.o) die
+ einzelnen Graphikpakete insertiert, und stehen den Sohntasks zur Verfgung
+ (siehe 'Operationen der Basisgraphik', S. #topage("gfuncts")#). Zustzlich kann sie den Plot-
+ manager in der Task 'PLOT' kontrollieren
+
+ #ib(1)#2.0 Task: 'PLOT'#ie(1)##goalpage("plotmanager")#
+
+ 'PLOT' enthlt den Multispool-Manager des Graphik-Systems, der die indirekte
+ Ausgabe von PICFILES auf jedem Endgert der Station ermglicht. Der Manager
+ verwaltet im Gegensatz zum 'PRINTER' aber nicht nur eine Warteschlange bzw.
+ Server sondern mehrere (die Anzahl ist durch die Konstante 'max spools' in
+ 'GRAPHIK.Manager' festgelegt).
+ (Achtung !, eine Task kann nicht mehr als 255 Datenrume, also Eintrge in
+ Warteschlangen verwalten !).
+ Sollte PLOT neben PRINTER zur graphischen Ausgabe auf dem Drucker arbei-
+ ten, so ist in PRINTER 'spool control task (/"PLOT")' einzustellen.
+ Der Plotmanager besitzt eine Kommandoebene, die wie folgt arbeitet:
+ Nach 'continue' erscheint der Prompt 'All-Plotter', der anzeigt, daá nach-
+ folgende Kommandos gleichermassen auf alle Spools/Server wirken; sollen
+ die Kommandos auf nur einen Spool/Server wirken, so ist dieser mit 'select
+ plotter' einzustellen, was durch eine nderung des Prompts auf den
+ Plotternamen angezeigt wird.
+
+ - 2.1 #ib(2," (2.1)")#listspool#ie(2,"")#
+ Gibt Auskunft ber die Inhalte und Aktivitten aller bzw. des
+ gewhlten Spools.
+
+ - 2.2 #ib(2," (2.2)")#clearspool#ie(2,"")#
+ Initialisiert nach Rckfrage alle bzw. den gewhlten Spool;
+ smtliche Eintrge werden gelscht, evtl. laufende Ausgaben
+ abgebrochen (der Server beendet).
+
+ - 2.3 #ib(2," (2.3)")#spool control#ie(2,"")#
+ (TEXT CONST control task)
+ Stellt die Task mit dem Namen 'control task' und alle ihre Shne
+ als privilegiert ein, d.h. Kommandos wie 'start', 'stop' usw. werden
+ von diesen Tasks wie auch von Systemstasks und von 'GRAPHIK'
+ aus zugelassen.
+
+ - 2.4 #ib(2," (2.4)")#stop#ie(2,"")#
+ Unterbricht eine evtl. laufende Ausgabe und unterbindet die
+ weitere Ausgabe von Eintrgen aller bzw. des gewhlten Spools;
+ wobei nach Rckfrage die abgebrochene Ausgabe als erster
+ Eintrag erneut eingetragen wird.
+
+ - 2.5 #ib(2," (2.5)")#start#ie(2,"")#
+ Nimmt die Ausgabe des gewhlten bzw. aller Spools wieder auf.
+
+ - 2.6 #ib(2," (2.6)")#halt#ie(2,"")#
+ Unterbindet die weitere Ausgabe von Eintrgen aller bzw. des
+ gewhlten Spools; evtl. laufende Ausgaben werden jedoch nicht
+ abgebrochen.
+
+ - 2.7 #ib(2," (2.7)")#select plotter#ie(2,"")#
+ Bietet als Auswahl die Endgerte der Station an; die obenge-
+ nannten Operationen wirken danach nur auf den gewhlten Spool,
+ was durch die nderung des Prompts auf den Namen des gewhlten
+ Endgertes angezeigt wird.
+ Der Abbruch der Auswahloperation fhrt dementsprechend wieder
+ zur Einstellung 'All-Plotter'.
+ Das aktuell zu kontrollierende Endgert kann jedoch auch mit
+ den Standard-Auswahloperationen gewhlt werden; diese lassen
+ aber auch die Wahl von Plottern anderer Stationen zu, was im
+ Plotmanager als 'All-Plotter' gewertet wird.
+
+ Folgende Funktionen knnen nur auf einzelne Spools; also nicht auf
+ 'All-Plotter' angewendet werden:
+
+ - 2.8 #ib(2," (2.8)")#killer#ie(2,"")#
+ Bietet im Dialog alle im Spool enthaltenen Eintrge zum Lschen
+ an.
+
+ - 2.9 #ib(2," (2.9)")#first#ie(2,"")#
+ Bietet im Dialog alle dem ersten Eintrag nachfolgenden Eintrge
+ zum Vorziehen an.
+
+ #ib(1)#3.0 Task: 'FKT'#ie(1)#
+
+ Die Task 'FKT' stellt den Funktionenplotter FKT, bzw. dessen menuegesteuerten
+ Monitor als Taskmonitor zur Verfgung.
+ Wird die Task mit dem Menuepunkt
+ 'q' - in die Kommandoebene zurueck
+ verlassen, so werden alle enthaltenen PICFILES gelscht.
+ Der Funktionenplotter wird in 'FKT' mit dem Kommando 'fktmanager' instal-
+ liert; er ist jedoch auch in jeder anderen Task mit dem Kommando 'fktplot'
+ erreichbar.
+
+#page#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 2: Operationen der Basisgraphik
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 2: Operationen der Basisgraphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+#goalpage("gfuncts")#
+ Die Pakete der Basisgraphik sind in der Datei 'GRAPHIK.Basis' enthalten, und
+ realisieren folgende Aufgaben:
+ - Vektorielle Abbildung virtueller Koordinaten unter Verwendung einer
+ Transformationsmatrix auf die konkrete Endgert-Zeichenflche unter
+ Bercksichtigung des eingestellten Teils der Zeichenflche ('viewport')
+ und des Fensters ('window').
+ - Bereitstellung des Datentyps PICTURE, der die gemeinsame Manipulation
+ von Objekten ermglicht.
+ - Bereitstellung des Datentyps PICFILE, der die gemeinsame Manipulation
+ von PICTURES hinsichtlich ihrer Ausgabe ermglicht.
+ - Bereitstellung des Datentyps PLOTTER, der die freie Auswahl von End-
+ gerten ermglicht, und Informationen ber sie liefert.
+
+ Zu den mit '*' gekennzeichneten Beschreibungen vgl. die Beschreibung im
+ Programmierhandbuch.
+
+ #ib(1)#1.0 Paket: 'transformation'#ie(1)#
+
+ 1.1 BOOL PROC #ib(2," (1.1)")#clippedline#ie(2," (PROC)")#
+ (REAL VAR x0, y0, x1, y1)
+ - Intern verwendete Prozedur, welche die in den Variablen ber-
+ gebenen Anfangs- und Endkoordinaten einer Geraden auf die
+ Ausmaáe der aktuellen Endgert-Zeichenflche begrenzt.
+ Es wird zurckgeliefert, ob Teile der bergebenen Geraden inner-
+ halb der Zeichenflche liegen, also gezeichnet werden mssen.
+
+ 1.2 PROC #ib(2," (1.2)")#drawingarea *#ie(2," (PROC)")#
+ (REAL VAR x cm, REAL VAR y cm, REAL VAR xp, REAL yp)
+ - Trgt in die bergebenen Variablen die Ausmaáe der aktuellen
+ Endgert-Zeichenflche in cm und Pixel ein.
+
+ 1.3 PROC #ib(2," (1.3)")#getvalues#ie(2," (PROC)")#
+ (ROW 3 ROW 2 REAL VAR, ROW 2 ROW 2 REAL VAR,
+ ROW 4 REAL VAR, ROW 2 REAL VAR, ROW 3 REAL VAR)
+ - Intern verwendete Prozedur, die in die bergebenen Felder die
+ aktuellen Werte der Transformationsmatrix eintrgt.
+
+ 1.4 BOOL PROC #ib(2," (1.4)")#newvalues#ie(2," (PROC)")#
+ - Intern verwendete Prozedur, die anzeigt, ob die Transformations-
+ matrix verndert wurde.
+
+ 1.5 PROC #ib(2," (1.5)")#oblique *#ie(2," (PROC)")#
+ (REAL CONST a, b)
+ - Stellt fr o.g. Abbildungsfunktion die Projektionsart
+ 'schiefwinklig' ein; 'a;b' ist der Punkt in der X-Y-Ebene, auf den der
+ Einheitsvektor in Z-Richtung abgebildet werden soll.
+
+ 1.6 PROC #ib(2," (1.6)")#orthographic *#ie(2," (PROC)")#
+ - Stellt die Projektionsart 'Paralellprojektion' ein (s.o.).
+
+ 1.7 PROC #ib(2," (1.7)")#perspective *#ie(2," (PROC)")#
+ (REAL CONST x,y,z)
+ - Stellt die Abbildungsart 'perspektivisch' ein; 'x;y;z' gibt den
+ Fluchtpunkt der Zentralperspektive an.
+
+ 1.8 PROC #ib(2," (1.8)")#setdrawingarea#ie(2," (PROC)")#
+ (REAL CONST x cm, y cm, x p, y p)
+ - Intern verwendete Prozedur, die vorm Beginn des Zeichnens dem
+ Transformationspaket die Ausmaáe der Endgert-Zeichenflche
+ bergibt.
+
+ 1.9 PROC #ib(2," (1.9)")#setvalues#ie(2," (PROC)")#
+ (ROW 3 ROW 2 REAL CONST, ROW 2 ROW 2 REAL CONST,
+ ROW 4 REAL CONST, ROW 2 REAL CONST, ROW 3 REAL CONST)
+ - Intern verwendete Prozedur, welche die Transformationsmatrix mit
+ den Werten der bergebenen Felder fllt.
+
+ 1.10 PROC #ib(2," (1.10)")#transform#ie(2," (PROC)")#
+ (REAL CONST x, y, z, xp, yp)
+ - Intern verwendete Prozedur zur Abbildung eines drei-
+ dimensionalen Vektors in virtuellen Koordinaten auf
+ (zweidimensionale) Bildschirmkoordinaten.
+
+ 1.11 PROC #ib(2," (1.11)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha, phi, theta)
+ - Stellt fr o.g. Abbildungsfunktion zustzlich die Drehwinkel der
+ Abbildung in Polarkoordinaten ein.
+ In der derzeitigen Version fehlerhaft !
+
+ 1.12 PROC #ib(2," (1.12)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha, phi)
+ - s.o.; ebenfalls fehlerhaft !
+
+ 1.13 PROC #ib(2," (1.13)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha)
+ - Dreht die Abbildung um den Mittelpunkt der Zeichenflche um
+ 'alpha' Grad !
+
+ 1.14 PROC #ib(2," (1.14)")#viewport *#ie(2," (PROC)")##goalpage("viewport")#
+ (REAL CONST hormin, hormax, vertmin, vertmax)
+ - Definiert den verwendeten Teil der Endgert-Zeichenflche in
+ Welt- oder Gertekoordinaten, bei Verwendung dieser Prozedur ist
+ vorangehend 'window (TRUE)' aufzurufen; damit die neuen Werte
+ auch Bercksichtigung finden.
+
+ 1. Angabe in Weltkoordinaten (cm):
+ 'hor min;vert min' - Position der unteren linken Ecke der ver-
+ wendeten Zeichenflche in cm.
+ 'hor max;vert max' - Position der oberen rechten Ecke der ver-
+ wendeten Zeichenflche in cm.
+
+ 2. Angabe in Gertekoordinaten:
+ Es wird eine Angabe in Gertekoordinaten angenommen, wenn
+ hor max < 2.0 und vert max < 2.0 gilt.
+ Die Werte werden als Bruchteile der Gráe der gesamten Zei-
+ chenflche aufgefaát, wobei fr die horizontalen Werte zu-
+ stzlich das Verhltnis 'Horizontale/Vertikale' (i.d. Regel > 1)
+ bercksichtigt wird.
+ Das bedeutet fr 'vert max' = 'hor max' = 1,
+ daá der obere Rand der spezifizierten Zeichenflche an der
+ Oberkante der Gesamt-Zeichenflche, und der rechte Rand an
+ der rechten Kante des durch die Gesamthhe der Zeichenflche
+ gegebenen Quadrates liegt (unverzerrt).
+ Soll die gesamte Zeichenflche genutzt werden, so ist 'hor min'
+ = 'vert min' = 0 und 'vert max' = 1 zu setzen;
+ 'hor max' dagegen auf das Verhltnis 'Horizontale/Vertikale' !.
+ Die halbe horizontale Verwendung der Zeichenflche ist durch
+ Halbierung des Seitenverhltnisses zu erreichen.
+
+ 1.15 PROC #ib(2," (1.15)")#window *#ie(2," (PROC)")#
+ (REAL CONST xmin, xmax, ymin, ymax, zmin, zmax)
+ - Stellt die Fenstergráe der virtuellen Zeichenflche, zu der die
+ virtuellen Koordinaten in Bezug gesetzt werden sollen, mittels
+ der gegenberliegenden Ecken 'min' und 'max' ein.
+
+ 1.16 PROC #ib(2," (1.16)")#window *#ie(2," (PROC)")#
+ (REAL CONST xmin, xmax, ymin, ymax)
+ - s.o., jedoch fr zweidimensionale Darstellungen.
+
+ 1.17 PROC #ib(2," (1.17)")#window *#ie(2," (PROC)")#
+ (BOOL CONST update)
+ - Die bergabe von TRUE verursacht die interne Neuberechnung der
+ Transformationsmatrix beim nchsten 'set values'; die immer dann
+ notwendig wird, wenn die Zeichenflche oder das mit 'viewport'
+ eingestellte virtuelle Fenster verndert werden soll.
+#page#
+ #ib(1)#2.0 Paket: picture#ie(1)#
+
+ 2.1 #ib(2," (2.1)")#TYPE PICTURE *#ie(2,"")#
+ - Datentyp zur Verwaltung eines einfarbigen Bildes; das aus entwe-
+ der zwei- oder dreidimensionalen Objekten besteht.
+
+ 2.2 OP #ib(2," (2.2)")#:= *#ie(2," (OP)")#
+ (PICTURE VAR dest, PICTURE CONST source)
+ - Zuweisungsoperator fr den Datentyp PICTURE.
+
+ 2.3 PROC #ib(2," (2.3)")#bar *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST width, height, pattern)
+ - Zeichnet in 'pic' an der aktuellen Position ein Rechteck
+ 'width/height' mit dem Muster 'pattern', wobei zu beachten ist, daá
+ die aktuelle X-Position die horizontale Position der vertikalen
+ Symmetrieachse des Rechtecks angibt.
+ Als 'pattern' z.Zt. implementiert:
+ 0 - nicht gefllt
+ 1 - halb gefllt (zeitaufwendig!)
+ 2 - gefllt
+ 3 - horizontal schraffiert
+ 4 - vertikal schraffiert
+ 5 - horizontal und vertikal schraffiert
+ 6 - diagonal rechts schraffiert
+ 7 - diagonal links schraffiert
+ 8 - diagonal rechts und links schraffiert
+
+ 2.4 OP #ib(2," (2.4)")#CAT *#ie(2," (OP)")#
+ (PICTURE VAR dest, PICTURE CONST add)
+ - Fgt die Bilder 'dest' und 'add' in 'dest' zusammen.
+
+ 2.5 PROC #ib(2," (2.5)")#circle *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, rad, INT CONST pattern)
+ - Zeichnet in 'pic' an der Position 'x;y' mit dem Radius 'rad' und dem
+ Muster 'pattern' gefllt ('pattern' z.Zt. wirkungslos)
+
+ 2.6 INT PROC #ib(2," (2.6)")#dim *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert die fr 'pic' eingestellte Dimensionalitt
+ (2 - zweidimensional; 3 - dreidimensional); wobei die Dimensionali-
+ tt mit der ersten Zeichenoperation eingestellt wird.
+
+ 2.7 PROC #ib(2," (2.7)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, z)
+ - Zeichnet in 'pic' von der aktuellen Position einen Gerade zur
+ Position 'x;y'.
+
+ 2.8 PROC #ib(2," (2.8)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, z)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.9 PROC #ib(2," (2.9)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, TEXT CONST text, REAL CONST angle, height, width)
+ - Zeichnet in 'pic' an der aktuellen Position 'text' in der Gráe
+ 'height/width' unter dem Winkel 'angle'.
+
+ 2.10 PROC #ib(2," (2.10)")#draw *#ie(2," (PROC)")#
+ (PICTURE VAR pic, TEXT CONST text)
+ - Zeichnet in 'pic' an der aktuellen Position 'text' in Standardgráe
+ und normaler Ausrichtung.
+
+ 2.11 PROC #ib(2," (2.11)")#draw cm *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x cm, y cm)
+ - Zeichnet in 'pic' eine Gerade zur cm-Position 'x;y', d.h., die Projek-
+ tionseinstellung wird nicht beachtet.
+
+ 2.12 PROC #ib(2," (2.12)")#draw cm r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx cm, dy cm)
+ - Zeichnet in 'pic' eine Gerade zur um 'dx cm;dy cm' verschobenen
+ Zeichenposition, d.h, die Projektionseinstellung wird nicht beach-
+ tet.
+
+ 2.13 PROC #ib(2," (2.13)")#draw r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy, dz)
+ - Zeichnet in 'pic' eine Gerade der Lnge 'dx;dy;dz' relativ zur
+ aktuellen Position.
+
+ 2.14 PROC #ib(2," (2.14)")#draw r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.15 PROC #ib(2," (2.15)")#extrema *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x min, x max, y min, y max, z min, z max)
+ - Trgt in die bergebenen Variablen die grssten und kleinsten
+ Koordinaten aller Objekte in 'pic' ein.
+
+ 2.16 PROC #ib(2," (2.16)")#extrema *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x min, x max, y min, y max)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.17 INT PROC #ib(2," (2.17)")#length *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert die Lnge des Objekt-Verwaltungstextes von 'pic'.
+
+ 2.18 PROC #ib(2," (2.18)")#move *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y, z)
+ - Fhrt den Zeichenstift auf 'pic' an die Position 'x;y;z'.
+
+ 2.19 PROC #ib(2," (2.19)")#move *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x, y)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.20 PROC #ib(2," (2.20)")#move cm *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST x cm, y cm)
+ - Die aktuelle Zeichenposition wird auf 'x cm;y cm' verschoben, wobei
+ die Darstellungsart unbercksichtigt bleibt.
+
+ 2.21 PROC #ib(2," (2.21)")#move cm r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST d xcm, d ycm)
+ - Die aktuelle Zeichenposition wird um 'd xcm;d ycm' verschoben,
+ wobei die Darstellungsart unbercksichtigt bleibt.
+
+ 2.22 PROC #ib(2," (2.22)")#move r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy, dz)
+ - Verschiebt die aktuelle Zeichenposition in 'pic' um 'dx;dy;dz'.
+
+ 2.23 PROC #ib(2," (2.23)")#move r *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.24 PICTURE PROC #ib(2," (2.24)")#nilpicture *#ie(2," (PROC)")#
+ - Initialisierungsfunktion; liefert 'leeres Bild'.
+
+ 2.25 INT PROC #ib(2," (2.25)")#pen *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert den fr 'pic' eingestellten Stift (Nummer 1 - 16).
+
+ 2.26 PROC #ib(2," (2.26)")#pen *#ie(2," (PROC)")#
+ (PICTURE VAR pic, INT CONST no)
+ - Stellt den Stift 'no' fr 'pic' ein, wobei 'no' die Werte 1 - 16 an-
+ nehmen darf.
+
+ 2.27 PICTURE PROC #ib(2," (2.27)")#picture *#ie(2," (PROC)")#
+ (TEXT CONST objects)
+ - Die Objektbeschreibung aller Objekte eines Bildes wird in einem
+ Text verwaltet; mit dieser Prozedur wird ein TEXT im entsprechen-
+ den Format in ein PICTURE verwandelt.
+ Das Format des TEXTes: <INT> Dimension : 2- oder 3-D
+ <INT> Zeichenstift-Nummer
+ <...> Objekteintrge
+
+ Die Objekteintrge haben folgendes Format:
+ <INT> Objektcode <...> Parameter.
+
+ Objektcodes fr: > Die Parameter entsprechen der
+ - draw 1 Parameterfolge der Prozeduren.
+ - move 2
+ - text 3 > Vor dem Text wird als <INT> die
+ - move r 4 Textlnge gehalten.
+ - draw r 5
+ - move cm 6
+ - draw cm 7
+ - move cm r 8
+ - draw cm r 9
+ - bar 10
+ - circle 11
+
+ 2.28 PROC #ib(2," (2.28)")#rotate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST alpha, beta, gamma)
+ - Die Objekte von 'pic' werden gemá den Winkeln 'alpha;beta;gamma'
+ im positiven Sinne um die X-,Y-,Z-Achse gedreht; wobei nur ein
+ Winkel <> 0.0 sein darf.
+
+ 2.29 PROC #ib(2," (2.29)")#rotate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST alpha)
+ - Die Objekte von 'pic' werden gemá dem Winkel 'alpha' im positiven
+ Sinne um die X-Achse gedreht.
+
+ 2.30 PROC #ib(2," (2.30)")#stretch *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST xc, yc, zc)
+ - 'pic' wird um die Faktoren 'xc;yc;zc' gestreckt oder gestaucht:
+ Faktor > 1 -> Streckung
+ Faktor < 1 -> Stauchung
+ Faktor < 0 -> zustzlich Achsenspiegelung
+
+ 2.31 PROC #ib(2," (2.31)")#stretch *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST xc, yc)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.32 TEXT PROC #ib(2," (2.32)")#text *#ie(2," (PROC)")#
+ (PICTURE CONST pic)
+ - Liefert den Objekt-Verwaltungstext von 'pic'(vergleiche
+ 'picture').
+
+ 2.33 PROC #ib(2," (2.33)")#translate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy, dz)
+ - 'pic' wird um 'dx;dy;dz' verschoben.
+
+ 2.34 PROC #ib(2," (2.34)")#translate *#ie(2," (PROC)")#
+ (PICTURE VAR pic, REAL CONST dx, dy)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.35 PROC #ib(2," (2.35)")#where *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x, y, z)
+ - Trgt die aktuelle Zeichenposition in 'pic' in die bergebenen
+ Variablen 'x;y;z' ein.
+
+ 2.36 PROC #ib(2," (2.36)")#where *#ie(2," (PROC)")#
+ (PICTURE CONST pic, REAL VAR x, y)
+ - s.o., jedoch fr zweidimensionale Bilder.
+#page#
+ #ib(1)#3.0 Paket: 'picfile'#ie(1)#
+
+ 3.1 #ib(2," (3.1)")#TYPE PICFILE#ie(2,"")#
+ - Datentyp zur Verwaltung mehrerer Bilder (PICTUREs) und der
+ Darstellungsparameter.(Aktuelle Typnummer: 1102 !).
+
+ 3.2 OP #ib(2," (3.2)")#:= *#ie(2," (OP)")#
+ (PICFILE VAR dest, DATASPACE CONST source)
+ - Assoziiert das PICFILE 'dest' mit dem DATASPACE 'source'.
+
+ 3.3 OP #ib(2," (3.3)")#:= *#ie(2," (OP)")#
+ (PICFILE VAR dest, PICFILE CONST source):
+ - Assoziiert das PICFILE 'dest' mit 'source'; wie bei Files entsteht
+ keine Kopie!
+
+ 3.4 INT PROC #ib(2," (3.4)")#background *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert die auf 'pf' eingestellte Hintergrundfarbe.
+
+ 3.5 PROC #ib(2," (3.5)")#background *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST no)
+ - Stellt die Farbe 'no' als Hintergrundfarbe fr 'pf' ein:
+
+ 3.6 PROC #ib(2," (3.6)")#delete picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Lscht das aktuelle Bild in 'pf'.
+
+ 3.7 PROC #ib(2," (3.7)")#down *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert in 'pf' ein Bild weiter.
+
+ 3.8 PROC #ib(2," (3.8)")#down *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST step)
+ - Positioniert in 'pf' 'step'-Bilder weiter.
+
+ 3.9 BOOL PROC #ib(2," (3.9)")#eof *#ie(2," (PROC)")#
+ (PICFILE CONST)
+ - Liefert zurck, ob das aktuelle Bild auch das letzte des PICFILES
+ ist.
+
+ 3.10 PROC #ib(2," (3.10)")#extrema *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL VAR x min, x max, y min, y max, z min, z max)
+ - Trgt in die bergebenen Variablen die kleinsten bzw. gráten
+ Koordinaten aller Bilder in 'pf' ein.
+
+ 3.11 PROC #ib(2," (3.11)")#extrema *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL VAR x min, x max, y min, y max)
+ - s.o., jedoch fr zweidimensionale PICFILEs.
+
+ 3.12 PROC #ib(2," (3.12)")#get *#ie(2," (PROC)")#
+ (PICFILE VAR pf, FILE VAR source)
+ - Liest die in 'source' enthaltenen Informationen ber Bilder nach
+ 'pf' ein.
+
+ 3.13 PROC #ib(2," (3.13)")#get values *#ie(2," (PROC)")#
+ (PICFILE CONST pf, ROW 3 ROW 2 REAL VAR,ROW 2 ROW 2 REAL VAR,
+ ROW 4 REAL VAR, ROW 2 REAL VAR, ROW 3 REAL VAR)
+ - Trgt die Werte der Transformationsmatrix von 'pf' in die ber-
+ gebenen Variablenfelder ein.
+
+ 3.14 PROC #ib(2," (3.14)")#insert picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Fgt vor das aktuelle Bild von 'pf' ein leeres Bild ein.
+
+ 3.15 BOOL PROC #ib(2," (3.15)")#is first picture *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert zurck, ob das aktuelle auch das erste Bild von 'pf' ist.
+
+ 3.16 PROC #ib(2," (3.16)")#oblique *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST a, b)
+ - Stellt fr 'pf' die Projektionsart 'schiefwinklig' ein; 'a;b' ist der
+ Punkt in der X-Y-Ebene, auf den der Einheitsvektor in Z-Richtung
+ abgebildet werden soll.
+
+ 3.17 PROC #ib(2," (3.17)")#perspective *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST x, y, z)
+ - Stellt fr 'pf' die Projektionsart 'perspektivisch' ein; 'x;y;z' gibt
+ den Fluchtpunkt der Zentralperspektive an.
+
+ 3.18 INT PROC #ib(2," (3.18)")#picture no *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert die Nummer des aktuellen Bildes von 'pf' zurck.
+
+ 3.19 INT PROC #ib(2," (3.19)")#pictures *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Liefert die Anzahl der in 'pf' enthaltenen Bilder zurck.
+
+ 3.20 PROC #ib(2," (3.20)")#put *#ie(2," (PROC)")#
+ (FILE VAR dest, PICFILE CONST pf)
+ - Liest 'pf' nach 'dest' aus.
+
+ 3.21 PROC #ib(2," (3.21)")#put picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf, PICTURE CONST ins)
+ - Fgt das Bild 'ins' vor das aktuelle Bild von 'pf' ein.
+
+ 3.22 PROC #ib(2," (3.22)")#read picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf, PICTURE VAR pic)
+ - Trgt das aktuelle Bild von 'pf' in 'pic' ein.
+
+ 3.23 PROC #ib(2," (3.23)")#selected pen *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST no, INT VAR color, thickness, linetype,
+ BOOL VAR visible)
+ - Trgt in die bergebenen Variablen die fr den Stift 'no' aktuell
+ eingestellten Werte ein, wobei 'no' die Werte 1 - 16 annehmen darf.
+
+ 3.24 PROC #ib(2," (3.24)")#select pen *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST no, INT CONST color, thickness, linetype,
+ BOOL CONST visible)
+ - Stellt fr den Stift 'no' von 'pf' die bergebenen Werte fr Farbe,
+ Stiftbreite, Art des Linenzuges ein, wobei 'no' die Werte 1 - 16
+ annehmen darf.
+ 'visible' = FALSE bedeutet, das die mit diesem Stift gezogenen
+ Linien innerhalb bereits durch das Zeichnen entstandener Flchen
+ nicht gezeichnet werden, die Flchen sie also 'verdecken'.
+ Vordefiniert sind:
+ - color:
+ <0 - nicht standardisierte XOR-Modi
+ 0 - Lschstift
+ 1 - Standardfarbe d. Endgertes (s/w)
+ 2 - rot
+ 3 - blau
+ 4 - grn
+ 5 - schwarz
+ 6 - weiss
+ n - Sonderfarben
+ - thickness:
+ 0 - Standardstrichstrke d. Endgertes
+ n - Strichstrke in 1/10 mm
+ - linetype:
+ 0 - keine Linie
+ 1 - durchgngige Linie
+ 2 - gepunktete Linie
+ 3 - kurz gesrichelte Linie
+ 4 - lang gestrichelte Linie
+ 5 - Strichpunktlinie
+ (Standard-Definitionen, die Linetypes knnen
+ ber 'basisplot' auch verndert werden.)
+
+ 3.25 PROC #ib(2," (3.25)")#set values *#ie(2," (PROC)")#
+ (PICFILE VAR pf, ROW 3 ROW 2 REAL CONST,
+ ROW 2 ROW 2 REAL CONST,
+ ROW 4 REAL CONST,
+ ROW 2 REAL CONST, ROW 3 REAL CONST)
+ - Die bergebenen Felder werden in die Transformationsmatrix von
+ 'pf' bernommen.
+
+ 3.26 PROC #ib(2," (3.26)")#to eof *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert auf das letzte Bild von 'pf'.
+
+ 3.27 PROC #ib(2," (3.27)")#to first pic *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert auf das erste Bild von 'pf'.
+
+ 3.28 PROC #ib(2," (3.28)")#to pic *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST n)
+ - Positioniert auf das 'n'-te Bild von 'pf'.
+
+ 3.29 PROC #ib(2," (3.29)")#up *#ie(2," (PROC)")#
+ (PICFILE VAR pf)
+ - Positioniert in 'pf' ein Bild zurck.
+
+ 3.30 PROC #ib(2," (3.30)")#up *#ie(2," (PROC)")#
+ (PICFILE VAR pf, INT CONST step)
+ - Positioniert in 'pf' 'step'-Bilder zurck.
+
+ 3.31 PROC #ib(2," (3.31)")#view *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST alpha, phi, theta)
+ - Stellt fr die Abbildung von 'pf' zustzlich die Drehwinkel der
+ Abbildung in Polarkoordinaten ein.
+ In der derzeitigen Version fehlerhaft !
+
+ 3.32 PROC #ib(2," (3.32)")#view *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST alpha, phi)
+ - s.o.; in der derzeitigen Version fehlerhaft !
+
+ 3.33 PROC #ib(2," (3.33)")#view *#ie(2," (PROC)")#
+ (REAL CONST alpha)
+ - Dreht das Bild um den Mittelpunkt der Zeichenflche um 'alpha'
+ Grad !
+
+ 3.34 PROC #ib(2," (3.34)")#viewport *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST hor min, hor max, vert min, vert max)
+ - Spezifiziert die Zeichenflche, auf die 'pf' abgebildet werden soll.
+ Siehe dazu auch 'viewport' im 'transformation'-Paket (S. #topage("viewport")#).
+
+ 3.35 PROC #ib(2," (3.35)")#window *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST x min, x max, y min, y max, z min, z max)
+ - Definiert die virtuelle Zeichenflche von 'pf'.
+
+ 3.36 PROC #ib(2," (3.36)")#window *#ie(2," (PROC)")#
+ (PICFILE VAR pf, REAL CONST x min, x max, y min, y max)
+ - s.o., jedoch fr zweidimensionale PICFILEs.
+
+ 3.37 PROC #ib(2," (3.37)")#write picture *#ie(2," (PROC)")#
+ (PICFILE VAR pf, PICTURE CONST new)
+ - berschreibt das aktuelle Bild von 'pf' mit 'new'.
+#page#
+ #ib(1)#4.0 Paket: 'devices'#ie(1)#
+
+ 4.1 #ib(2," (4.1)")#TYPE PLOTTER#ie(2,"")#
+ - Verwaltungstyp zur Reprsentation eines Endgertes hinsichtlich
+ seiner Station, seines Kanals, seines Namens sowie seiner Zeichen-
+ flche. Dabei ist zu beachten, daá der gltige Endgert-
+ Descriptor, der zur Selektion verwendet wird, aus Station, Kanal
+ und Namen besteht; die Namen also nicht eindeutig vergeben
+ werden mssen.
+
+ 4.2 OP #ib(2," (4.2)")#:=#ie(2," (OP)")#
+ (PLOTTER VAR dest, PLOTTER CONST source)
+ - Zuweisungsoperator fr den Datentyp 'PLOTTER'.
+
+ 4.3 BOOL OP #ib(2," (4.3)")#=#ie(2," (OP)")#
+ (PLOTTER CONST left, right)
+ - Vergleichsoperator fr den Datentyp 'PLOTTER'.
+
+ 4.4 INT PROC #ib(2," (4.4)")#actual plotter#ie(2," (PROC)")#
+ - Liefert die interne Verwaltungsnummer des eingestellten End-
+ gertes (Kein Endgert eingestellt -> 0).
+
+ 4.5 INT PROC #ib(2," (4.5)")#channel#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Liefert den Kanal von 'plotter'.
+
+ 4.6 PROC #ib(2," (4.6)")#drawingarea#ie(2," (PROC)")#
+ (REAL VAR x cm, y cm, INT VAR x p, y p)
+ - Trgt in die bergebenen Variablen die Maáe der
+ Zeichenflche des eingestellten Endgertes ein.
+
+ 4.7 PROC #ib(2," (4.7)")#drawingarea#ie(2," (PROC)")#
+ (REAL VAR x cm, y cm, INT VAR x p, y p, PLOTTER CONST plotter)
+ - Trgt in die bergebenen Variablen die Maáe der Zeichenflche
+ von 'plotter' ein.
+
+ 4.8 PROC #ib(2," (4.8)")#install plotter#ie(2," (PROC)")#
+ (TARGET VAR new descriptors)
+ - bergibt dem Verwaltungspacket den zu verwaltenden Satz End-
+ gerte. Wird intern vom 'device interface' verwendet, kann aber
+ auch im nachhinein zur Installation von Endgerten anderer
+ Stationen oder zum Ausblenden von Endgerten dienen. Nachdem
+ die Graphik installiert wurde, knnen jedoch keine neuen sta-
+ tionseigenen Endgerte erzeugt werden (oder nur verwaltungs-
+ seitig, d.h. die Ansteuerung fehlt).
+
+ 4.9 TEXT PROC #ib(2," (4.9)")#name#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Liefert den Namen von 'plotter'
+
+ 4.10 PLOTTER PROC #ib(2," (4.10)")#no plotter#ie(2," (PROC)")#
+ - Liefert den Endgert-Descriptor 'kein Plotter'.
+
+ 4.11 PLOTTER PROC #ib(2," (4.11)")#plotter#ie(2," (PROC)")#
+ - Liefert den Endgert-Descriptor des eingestellten Endgertes.
+
+ 4.12 PLOTTER PROC #ib(2," (4.12)")#plotter#ie(2," (PROC)")#
+ (TEXT CONST descriptor)
+ - Liefert den Endgert-Descriptor des durch 'descriptor' beschrie-
+ benen Endgertes.
+ 'descriptor' hat folgendes Format:
+ <Stationsnummer>/<Kanalnummer>/Endgertname,
+ wobei nicht vorhandene Endgerte abgelehnt werden.
+
+ 4.13 TEXT PROC #ib(2," (4.13)")#plotterinfo#ie(2," (PROC)")#
+ (TEXT CONST descriptor, INT CONST length)
+ - Liefert einen auf die Lnge 'length' eingerichteten TEXT, der
+ 'descriptor' in aufbereiteter Form wiedergibt.
+ Format von 'descriptor' s.o.
+
+ 4.14 THESAURUS PROC #ib(2," (4.14)")#plotters#ie(2," (PROC)")#
+ - Liefert alle vorhandenen Endgerte in Form o.g. Descriptoren.
+
+ 4.15 PROC #ib(2," (4.15)")#select plotter#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Stellt 'plotter' als aktuelles Endgert ein.
+
+ 4.16 PROC #ib(2," (4.16)")#select plotter#ie(2," (PROC)")#
+ (TEXT CONST descriptor)
+ - Stellt das durch 'descriptor' beschriebene Endgert als aktuelles
+ Endgert ein.
+
+ 4.17 PROC #ib(2," (4.17)")#select plotter#ie(2," (PROC)")#
+ - Bietet eine Auswahl aller Endgerte an, und stellt das gewhlte
+ als aktuelles Endgert ein.
+
+ 4.18 INT PROC #ib(2," (4.18)")#station#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Liefert die Stationsnummer von 'plotter' zurck.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 2.1: Operationen des 'device interface'#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+ Das automatisch vom 'GRAPHIK.Configurator' anhand von Konfigurationsda-
+ teien erstellte Paket 'device interface' realisiert die normierte, jedoch von
+ der Zeichenflche des Endgerts abhngige Ansteuerung der verschiedenen
+ Endgerte. Es entspricht dabei dem Paket 'Endgert.Basis' der EUMEL-Graphik,
+ geht aber teilweise ber dessen Leistungen hinaus.Hinweis: Falls diese Lei-
+ stung nicht bereits endgertseitig implementiert ist, wird nicht geclipped;
+ die berschreitung der Zeichengrenzen hat also Undefiniertes zur Folge.
+ Zudem ist die Mehrheit der Prozeduren ausschlieálich nach 'initplot' funk-
+ tionsfhig.
+
+ #ib(1)#1.0 Paket: 'device interface'#ie(1)#
+
+ 1.1 INT PROC #ib(2," (1.1)")#background#ie(2," (PROC)")#
+ - Liefert die Nummer der aktuell fr den Hintergrund eingestellten
+ Farbe zurck.
+
+ 1.2 PROC #ib(2," (1.2)")#background#ie(2," (PROC)")#
+ (INT CONST color no)
+ - Stellt die Farbe 'color no' als Hintergrundfarbe ein.
+
+ 1.3 PROC #ib(2," (1.3)")#box#ie(2," (PROC)")#
+ (INT CONST x1, y1, x2, y2, pattern)
+ - Zeichnet ein Rechteck mit den gegenberliegenden Ecken 'x1;y1'
+ und 'x2;y2', das mit dem Muster 'pattern' gefllt wird, wobei
+ 'pattern' endgertspezifisch ist.
+
+ 1.4 PROC #ib(2," (1.4)")#circle#ie(2," (PROC)")#
+ (INT CONST x, y, rad, from, to)
+ - Zeichnet an der Stelle 'x;y' einen Kreis (bzw. Kreissegment) des
+ Radius 'rad' mit dem Anfangswinkel 'from' und dem Endwinkel 'to'.
+
+ 1.5 PROC #ib(2," (1.5)")#clear#ie(2," (PROC)")#
+ - Initialisiert die Zeichenflche des aktuellen Endgertes, wobei
+ die Zeichenposition auf '0;0' und die Standardfarben
+ gesetzt werden.
+
+ 1.6 PROC #ib(2," (1.6)")#clear#ie(2," (PROC)")#
+ (BOOL CONST onoff)
+ - Die bergabe von FALSE bewirkt, daá alle nachfolgenden Aufrufe
+ von 'clear' wirkungslos sind; mit TRUE werden sie entsprechend
+ wieder aktiviert.
+
+ 1.7 INT PROC #ib(2," (1.7)")#color#ie(2," (PROC)")#
+ (INT CONST color no)
+ - Liefert den fr die Farbe 'color no' eingestellten Farbwert im
+ normierten RGB-Code von 0-999.
+
+ 1.8 INT PROC #ib(2," (1.8)")#colors#ie(2," (PROC)")#
+ - Liefert die Anzahl mglicher Farben fr das aktuelle Endgert.
+
+ 1.9 PROC #ib(2," (1.9)")#draw to#ie(2," (PROC)")#
+ (INT CONST x, y)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur Position
+ 'x;y'.
+
+ 1.10 PROC #ib(2," (1.10)")#endplot#ie(2," (PROC)")#
+ - Wartet auf eine Eingabe des Benutzers und beendet dann die
+ graphische Ausgabe; ggf. durch Umschalten in den Text-Modus.
+ Falls mglich, sollte die ausgegebene Graphik jedoch auf dem
+ Bildschirm erhalten bleiben.
+
+ 1.11 PROC #ib(2," (1.11)")#end plot#ie(2," (PROC)")#
+ (BOOL CONST onoff)
+ - Die bergabe von FALSE bewirkt, daá alle nachfolgenden Aufrufe
+ von 'endplot' wirkungslos sind; mit TRUE werden sie entsprechend
+ wieder aktiviert.
+
+ 1.12 PROC #ib(2," (1.12)")#fill#ie(2," (PROC)")#
+ (INT CONST x, y, INT CONST pattern)
+ - Die Umgebung von 'x;y' wird mit dem Muster 'pattern' gefllt, wobei
+ sowohl 'pattern' als auch die genauen Fll-Bedingungen (Art der
+ Umrahmung usw.) endgertspezifisch sind.
+
+ 1.13 INT PROC #ib(2," (1.13)")#foreground#ie(2," (PROC)")#
+ - Liefert die Nummer der aktuell fr den Vordergrund eingestellten
+ Farbe zurck.
+
+ 1.14 PROC #ib(2," (1.14)")#foreground#ie(2," (PROC)")#
+ (INT CONST color no)
+ - Stellt die Farbe 'color no' als Vordergrundfarbe ein.
+
+ 1.15 PROC #ib(2," (1.15)")#get cursor#ie(2," (PROC)")#
+ (INT VAR x, y, TEXT VAR exit char)
+ - Nach Aufruf dieser Prozedur sollte das Endgert die Eingabe
+ einer Position mittels eines graphischen Cursors (i.d.R.
+ Fadenkreuz) ermglichen. Dieser Modus soll bleibt solange auf-
+ rechterhalten bis eine Taste gedrckt wird; in 'x;y' findet sich
+ dann die Position des Cursors, und in 'exit char' die gedrckte
+ Taste.
+ Diese Prozedur ist jedoch nicht fr das Ein bzw. Ausschalten des
+ graphischen Cursors zustndig, d.h der eingeschaltete Cursor ist
+ stndig sichtbar; bei ausgeschaltetem Cursor kehrt die Prozedur
+ sofort mit 'exit char' = ""0"" zurck.
+
+ 1.16 BOOL PROC #ib(2," (1.16)")#graphik cursor#ie(2," (PROC)")#
+ - Diese Prozedur gibt an, ob graphische Eingabeoperationen und
+ die dazugehrigen Operationen auf dem aktuellen Endgert ver-
+ fgbar sind.
+
+ 1.17 PROC #ib(2," (1.17)")#graphik cursor#ie(2," (PROC)")#
+ (INT CONST x, y, BOOL CONST onoff)
+ - Diese Prozedur schaltet den graphischen Cursor an bzw. aus oder
+ positioniert ihn. Nach dem Einschalten sollte der Cursor perma-
+ nent sichtbar sein. Ein erneutes Einschalten hat die
+ Neupositionierung des Cursors zur Folge.
+
+ 1.18 PROC #ib(2," (1.18)")#home#ie(2," (PROC)")#
+ - Positioniert die aktuelle Zeichenposition auf den Punkt '0;0'; bei
+ eingeschaltetem graphischen Cursor diesen auf die Mitte der
+ Zeichenflche.
+
+ 1.19 PROC #ib(2," (1.19)")#init plot#ie(2," (PROC)")#
+ - Initialisiert das aktuelle Endgert zur graphischen Ausgabe,
+ (schaltet ggf. in den Graphik-Modus), wobei der Bildschirm jedoch
+ mglichst nicht gelscht werden sollte.
+
+ 1.20 PROC #ib(2," (1.20)")#move to#ie(2," (PROC)")#
+ (INT CONST xp, yp)
+ - Die Position 'xp;yp' wird neue Stiftposition; die Wirkung ist unde-
+ finiert bei berschreitung der Bildschrimgrenzen.
+
+ 1.21 PROC #ib(2," (1.21)")#prepare#ie(2," (PROC)")#
+ - Bereitet die Ausgabe auf einem Endgert vor; d.h. die Task wird an
+ den entsprechenden Kanal angekoppelt, und andere Tasks am An-
+ koppeln gehindert (z.B. 'stop' des PRINTER-Servers). Dabei wird die
+ Prozedur erst dann verlassen, wenn die Aktion erfolgreich been-
+ det ist. (z.B. bis zur Freigabe des Kanals).
+
+
+ 1.22 PROC #ib(2," (1.22)")#set color#ie(2," (PROC)")#
+ (INT CONST no, rgb)
+ - Setzt die Farbe von 'no' auf die normierte RGB-Farbkombination
+ 'rgb' (0 - 999).
+
+ 1.23 PROC #ib(2," (1.23)")#setmarker#ie(2," (PROC)")#
+ (INT CONST xp, yp, type)
+ - Zeichnet an der Position 'xp;yp' eine Markierung; wobei die Wir-
+ kung bei berschreitung der Bildschirmgrenzen undefiniert ist.
+ Als 'type' sollten vorhanden sein:
+ 0 - Kreuz '+'
+ 1 - Kreuz diagonal 'x'
+ - weitere beliebig
+
+ 1.24 PROC #ib(2," (1.24)")#setpalette#ie(2," (PROC)")#
+ - Initialisiert die Farben des Endgertes gemá den im Paket ge-
+ setzten Farben.
+
+ 1.25 PROC #ib(2," (1.25)")#setpixel#ie(2," (PROC)")#
+ (INT CONST xp, yp)
+ - Setzt das Pixel 'xp;yp' in der aktuellen Schreibfarbe.
+
+ 1.26 PROC #ib(2," (1.26)")#stdcolors#ie(2," (PROC)")#
+ - Initialisiert die Paket-Intern verwendete Farbtabelle auf die
+ standardmáig fr das Endgert definierten Farben;
+ wobei die Farben jedoch nicht auf dem Endgert eingestellt
+ werden.
+
+ 1.27 PROC #ib(2," (1.27)")#stdcolors#ie(2," (PROC)")#
+ (BOOL CONST onoff)
+ - Die bergabe von FALSE bewirkt, daá alle nachfolgenden Aufrufe
+ von 'stdcolors' wirkungslos sind; mit TRUE werden sie entspre-
+ chend wieder aktiviert.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 2.2: Operationen zur Graphik-Ausgabe#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Die Pakete zur Ausgabe von Graphiken (PICFILES) sind in der Datei
+ 'GRAPHIK.Basis' enthalten, und realisieren folgende Leistungen:
+ - Im Datentyp PICTURE bzw. PICFILE in Codierter Form verwendete Ausgabe-
+ prozeduren auf einzelne Objekte unter Bercksichtigung der Abbil-
+ dungsparameter und Zeichenflche.
+ - Kommunikations- und Kontrolloperationen auf die Task 'PLOT' zur
+ indirekten Ausgabe von PICFILES.
+ - Ausgabeoperationen auf den Datentyp PICTURE bzw. PICFILE unter Be-
+ rcksichtung des eingestellten Endgertes.
+ Wird fr die Angabe von Koordinaten der Typ REAL verwendet, so handelt es
+ sich um virtuelle Koordinaten, d.h. die Ausgabe-Parameter wie 'viewport' und
+ 'window' werden bercksichtigt; bei Verwendung von INT ist die Ausgabe end-
+ gertspezifisch.
+
+ #ib(1)#2.0 Paket: 'basisplot'#ie(1)#
+
+ 2.1 PROC #ib(2," (2.1)")#bar *#ie(2," (PROC)")#
+ (INT CONST x, y, height, width, pattern)
+ - Zeichnet an der Position 'x;y' ein Rechteck der Lnge/Breite
+ 'width/height' mit dem Muster 'pattern', wobei 'x;y' die untere linke
+ Ecke des Rechtecks angibt.
+ Als 'pattern' z.Zt. implementiert:
+ 0 - nicht gefllt
+ 1 - halb gefllt
+ 2 - gefllt
+ 3 - horizontal schraffiert
+ 4 - vertikal schraffiert
+ 5 - horizontal und vertikal schraffiert
+ 6 - diagonal rechts schraffiert
+ 7 - diagonal links schraffiert
+ 8 - diagonal rechts und links schraffiert
+
+ 2.2 PROC #ib(2," (2.2)")#bar *#ie(2," (PROC)")#
+ (REAL CONST height, width, INT CONST pattern)
+ - siehe oben, jedoch mit Ausgangspunkt an der aktuellen Zeichen-
+ position, wobei zu beachten ist, daá die x-Koordinate die horizon-
+ tale Position der vertikalen Symmetrieachse des Rechtecks angibt.
+
+ 2.3 PROC #ib(2," (2.3)")#beginplot#ie(2," (PROC)")#
+ - Leitet die graphische Ausgabe ein, wobei das Endgert in seinen
+ Startzustand versetzt wird, und dem Transformationspaket die
+ Abmessungen der Zeichenflche mitgeteilt werden.
+
+ 2.4 PROC #ib(2," (2.4)")#box *#ie(2," (PROC)")#
+ - Zeichnet eine Umrahmung der gesamten Zeichenflche (Nicht nur
+ des verwendeten Teiles).
+
+ 2.5 PROC #ib(2," (2.5)")#circle *#ie(2," (PROC)")#
+ (REAL CONST rad, from, to, INT CONST pattern)
+ - Zeichnet an aktuellen Position einen Kreis od. ein Kreissegment
+ des Radius 'rad'; beginnend bei 'from' bis zum Endwinkel 'to' und
+ gefllt mit dem Muster 'pattern' ('pattern' z.Zt. nicht
+ implementiert).
+
+ 2.6 PROC #ib(2," (2.6)")#draw *#ie(2," (PROC)")#
+ (INT CONST x, y)
+ - Zeichnet von der aktuellen Position eine Gerade zur Position 'x;y'.
+
+ 2.7 PROC #ib(2," (2.7)")#draw *#ie(2," (PROC)")#
+ (INT CONST x0, y0, x1, y1)
+ - Zieht eine Gerade von der Position 'x0;y0' bis zur Position 'x1;y1'.
+
+ 2.8 PROC #ib(2," (2.8)")#draw *#ie(2," (PROC)")#
+ (REAL CONST x, y, z)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur
+ (transformierten) 3-D Position 'x;y;z'.
+
+ 2.9 PROC #ib(2," (2.9)")#draw *#ie(2," (PROC)")#
+ (REAL CONST x, y)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.10 PROC #ib(2," (2.10)")#draw *#ie(2," (PROC)")#
+ (TEXT CONST text, REAL CONST angle, height, width)
+ - Zeichnet den TEXT 'text' ab der aktuellen Zeichenposition unter
+ dem Winkel 'angle' und in der Hhe/Breite 'height;width'.
+
+ 2.11 PROC #ib(2," (2.11)")#draw *#ie(2," (PROC)")#
+ - s.o., jedoch in Standard-Ausrichtung (0 Grad) und
+ Standard-Hhe/Breite (0.5/0.5).
+
+ 2.12 PROC #ib(2," (2.12)")#draw cm *#ie(2," (PROC)")#
+ (REAL CONST x cm, y cm)
+ - Zeichnet von der aktuellen Position eine Gerade zur cm-Position
+ 'x cm;y cm'.
+
+ 2.13 PROC #ib(2," (2.13)")#draw cm r *#ie(2," (PROC)")#
+ (REAL CONST x cm, REAL CONST y cm)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur um 'x cm;
+ y cm' verschobenen Zielposition.
+
+ 2.14 PROC #ib(2," (2.14)")#draw r *#ie(2," (PROC)")#
+ (REAL CONST dx, dy)
+ - Zieht von der aktuellen Zeichenposition eine Gerade zur um 'dx;dy'
+ Einheiten verschobenen Zielposition.
+
+ 2.15 PROC #ib(2," (2.15)")#draw r *#ie(2," (PROC)")#
+ (REAL CONST dx, dy, dz)
+ - Zeichnet von der aktuellen Zeichenposition eine Gerade zur um
+ 'dx;dy;dz' Einheiten verschobenen und transformierten 3-D Ziel-
+ position.
+
+ 2.16 PROC #ib(2," (2.16)")#hidden lines *#ie(2," (PROC)")#
+ (BOOL CONST visible)
+ - Schaltet die vektorisierte Speicherung aller zuknftigen Aus-
+ gabe ein (FALSE) bzw. aus.Ist dieser Modus eingeschaltet, so werden
+ alle durch vorheriges Zeichnen entstandenen Flchen beim Zeichen
+ bercksichtigt, also nicht bermalt; sie 'verdecken' die weiteren
+ Linien.
+
+ 2.17 PROC #ib(2," (2.17)")#linetype#ie(2," (PROC)")#
+ (INT CONST line no, TEXT CONST bitpattern)
+ - Stellt fr den Linientyp 'line no' das Bitmuster 'bitpattern' ein;
+ wobei der 'bitpattern'-TEXT ausschlieálich aus den Zeichen '0' und
+ '1' bestehen sollte.
+
+ 2.18 PROC #ib(2," (2.18)")#move *#ie(2," (PROC)")#
+ (INT CONST x,y)
+ - Zeichnet von der aktuellen Position eine Gerade zur Position 'x;y'.
+
+ 2.19 PROC #ib(2," (2.19)")#move *#ie(2," (PROC)")#
+ (REAL CONST x, y, z)
+ - Zeichnet von der aktuellen Position eine Gerade zur trans-
+ formierten 3-D-Position 'x;y;z'
+
+ 2.20 PROC #ib(2," (2.20)")#move *#ie(2," (PROC)")#
+ (REAL CONST x, y)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.21 PROC #ib(2," (2.21)")#move cm#ie(2," (PROC)")#
+ (REAL CONST x cm, y cm)
+ - Setzt die aktuelle Zeichenposition auf die cm-Position 'x cm,;y cm'.
+
+ 2.22 PROC #ib(2," (2.22)")#move cm r *#ie(2," (PROC)")#
+ (REAL CONST d x cm, d y cm)
+ - Zeichnet von der aktuellen Position eine Gerade zur um
+ 'd x cm;d y cm' verschobenen Zielposition.
+
+ 2.23 PROC #ib(2," (2.23)")#move r *#ie(2," (PROC)")#
+ (REAL CONST d x, d y, d z)
+ - Zeichnet von der aktuellen Position eine Gerade zur um 'd x;d y;d z'
+ Einheiten verschobenen und transformierten Zielposition.
+
+ 2.24 PROC #ib(2," (2.24)")#move r *#ie(2," (PROC)")#
+ (REAL CONST d x, d y)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.25 PROC #ib(2," (2.25)")#pen *#ie(2," (PROC)")#
+ (INT CONST background, foreground, thickness, linetype)
+ - Aktiviert fr alle folgenden Ausgaben mit virtuellen Koordi-
+ naten den Hintergrund 'background'; die Schreibfarbe
+ 'foreground'; die Zeichenstrke 'thickness' in 1/10 mm und den
+ Linientyp 'linetype' (i.d.R. 1-6). Vergleiche 'select pen'.
+
+ 2.26 PROC #ib(2," (2.26)")#reset *#ie(2," (PROC)")#
+ - Die mit 'hidden lines (FALSE)' vektorisiert abgespeicherte
+ Ausgabe wird gelscht.
+
+ 2.27 PROC #ib(2," (2.27)")#reset linetypes *#ie(2," (PROC)")#
+ - Setzt die Linientypen 1-6 auf Standard-Linientypen: 1 - durch-
+ gngige Linie
+ 2 - gepunktete Linie
+ 3 - kurz gestrichelte Linie
+ 4 - lang gestrichelte Linie
+ 5 - Strichpunktlinie
+
+ 2.28 PROC #ib(2," (2.28)")#reset zeichensatz *#ie(2," (PROC)")#
+ - Setzt den Zeichensatz auf den Standard-Zeichensatz 'ZEICHENSATZ'.
+
+ 2.29 PROC #ib(2," (2.29)")#where *#ie(2," (PROC)")#
+ (REAL VAR x, y, z)
+ - Trgt die aktuelle Zeichenposition als (retransformierte) 3-D
+ Position in die bergeben Variablen ein.
+
+ 2.30 PROC #ib(2," (2.30)")#where *#ie(2," (PROC)")#
+ (REAL VAR x, y)
+ - s.o., jedoch fr zweidimensionale Bilder.
+
+ 2.31 PROC #ib(2," (2.31)")#zeichensatz *#ie(2," (PROC)")#
+ (TEXT CONST zeichenname)
+ - Ldt den Zeichensatz 'zeichenname' zur Verwendung bei Beschrif-
+ tungen.
+#page#
+ #ib(1)#3.0 Paket: 'plot interface'#ie(1)#
+
+ 3.1 THESAURUS OP #ib(2," (3.1)")#ALL#ie(2," (OP)")#
+ (PLOTTER CONST plotter)
+ - Liefert die Namen der z.Zt. im Spool 'plotter' zur indirekten
+ Graphik-Ausgabe gespoolten task-eigenen PICFILES.
+ Bei Aufruf aus 'GRAPHIK' werden die Namen aller zur Ausgabe
+ gespoolten PICFILES geliefert.
+
+ 3.2 PROC #ib(2," (3.2)")#erase#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Lscht nach Rckfrage das im Spool 'plotter' zur indirekten
+ Graphik-Ausgabe gespoolte task-eigene PICFILE 'picname'.
+ Bei Aufruf aus 'GRAPHIK' ist auch das Lschen fremder zur Ausgabe
+ gespoolter PICFILES mglich.
+
+ 3.3 PROC #ib(2," (3.3)")#erase#ie(2," (PROC)")#
+ (THESAURUS CONST piclist, PLOTTER CONST plotter)
+ - Lscht im Dialog alle in 'piclist' und im Spool 'plotter' zur in-
+ direkten Graphik-Ausgabe gespoolten task-eigenen PICFILES.
+ Bei Aufruf aus 'GRAPHIK' ist auch das Lschen fremder zur Ausgabe
+ gespoolter PICFILES mglich.
+
+ 3.4 BOOL PROC #ib(2," (3.4)")#exists#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Liefert zurck, ob z.Zt. im Spool 'plotter' ein task-eigenes PICFILE
+ 'picname' zur indirekten Graphik-Ausgabe gespoolt wird.
+ Bei Aufruf aus 'GRAPHIK' kann auch die Existenz fremder zur Aus-
+ gabe gespoolter PICFILES erfragt werden.
+
+ 3.5 PROC #ib(2," (3.5)")#first#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Zieht das im Spool 'plotter' zur indirekten Ausgabe gespoolte
+ PICFILE 'picname' an die erste Stelle der Warteschlange. Der Auf-
+ ruf ist nur aus 'GRAPHIK' zulssig.
+
+ 3.6 PROC #ib(2," (3.6)")#generate plotmanager#ie(2," (PROC)")#
+ - Erzeugt die Task 'PLOT', in der dann im Hintergrund der Plot-
+ manager insertiert wird. Dabei darf 'PLOT' zuvor nicht existieren,
+ und in der Task muá die Datei 'GRAPHIK.Manager' vorhanden sein.
+
+ 3.7 PROC #ib(2," (3.7)")#halt#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Unterbindet die weitere indirekte Graphik-Ausgabe aus dem Spool
+ 'plotter'; eine aktuell laufende Ausgabe wird jedoch nicht ab-
+ gebrochen. Der Aufruf ist nur aus 'GRAPHIK' zulssig.
+
+ 3.8 PROC #ib(2," (3.8)")#list#ie(2," (PROC)")#
+ (FILE VAR list file, PLOTTER CONST plotter)
+ - Erzeugt in 'list file' eine Inhalts/Aktivittsbersicht des Spools
+ 'plotter'.
+
+ 3.9 PROC #ib(2," (3.9)")#list#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Zeigt eine Inhalts/Aktivittsbersicht des Spools 'plotter'.
+
+ 3.10 THESAURUS PROC #ib(2," (3.10)")#picfiles#ie(2," (PROC)")#
+ - Liefert eine Liste der Namen aller in der Task enthaltenen
+ PICFILES.
+
+ 3.11 PROC #ib(2," (3.11)")#save#ie(2," (PROC)")#
+ (TEXT CONST picname, PLOTTER CONST plotter)
+ - Sendet das PICFILE 'picname' zwecks indirekter Graphik-Ausgabe
+ zum Spool 'plotter'.
+
+ 3.12 PROC #ib(2," (3.12)")#save#ie(2," (PROC)")#
+ (THESAURUS CONST piclist, PLOTTER CONST plotter)
+ - Sendet alle in 'piclist' namentlich enthaltenen PICFILES zwecks
+ indirekter Graphik-Ausgabe zum Spool 'plotter'.
+
+ 3.13 PROC #ib(2," (3.13)")#start#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Nimmt die zuvor mit 'halt','wait for halt','stop' oder spoolseitig
+ unterbrochene indirekte Graphik-Ausgabe des Spools 'plotter'
+ wieder auf. Der Aufruf ist nur aus 'GRAPHIK' zulssig.
+
+ 3.14 PROC #ib(2," (3.14)")#stop#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Unterbricht sofort die aktuell laufende Ausgabe des Spools
+ 'plotter', und unterbindet weitere Ausgaben. Nach Rckfrage wird
+ das PICFILE, das aktuell ausgegeben wurde, erneut an erster
+ Steller der Warteschlange eingetragen.
+
+ 3.15 PROC #ib(2," (3.15)")#wait for halt#ie(2," (PROC)")#
+ (PLOTTER CONST plotter)
+ - Unterbindet die weitere Ausgabe der
+ gespoolten PICFILES, und wartet bis die aktuell laufende Ausgabe
+ beendet ist.
+#page#
+ #ib(1)#4.0 Paket: 'plot'#ie(1)#
+
+ 4.1 PROC #ib(2," (4.1)")#plot *#ie(2," (PROC)")#
+ (PICTURE CONST picture)
+ - Ausgabe der Objektebene 'picture', unter Verwendung des in
+ 'picture' angegebenen Stiftes gemá seiner aktuellen Einstellung
+ im 'basisplot'.Nur fr Direkt-Ausgaben verwendbar.
+
+ 4.2 PROC #ib(2," (4.2)")#plot *#ie(2," (PROC)")#
+ (PICFILE CONST pf)
+ - Ausgabe des Bildes 'pf' unter vollstndiger Bercksichtung der in
+ 'pf' mit 'select pen';'window';'viewport' usw. eingestellten
+ Ausgabeparameter. Nur fr Direkt-Ausgaben verwendbar.
+
+ 4.3 PROC #ib(2," (4.3)")#plot *#ie(2," (PROC)")#
+ (TEXT CONST picfile name)
+ - Direkte oder indirekte Ausgabe des Bildes 'picfile name'.
+ Bei direkter Ausgabe wird obiges 'plot' verwendet; bei indirekter
+ Ausgabe wird das PICFILE an den aktuell eingestellten Spool zur
+ graphischen Ausgabe gesendet.
+#page#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 3: Konfigurierung der Graphik
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 3: Konfigurierung der Graphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+#type("pica")##on("u")##ib(1)#Teil 3.1: Der Graphik-Konfigurator#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+#goalpage("newconf")#
+ Die MPG-EUMEL-Graphik besitzt eine normierte Schnittstelle zu allen graphischen
+ Endgerten. Diese wird vom Programm 'GRAPHIK.Configurator' aus verschiede-
+ nen Dateien, die einer gewissen Syntax zu gengen haben, zu einem Paket
+ namens 'device interface' zusammengefgt. Diese Dateien enthalten verschie-
+ dene Informationen und endgertspezifische ELAN-Prozeduren, die zur
+ Erzeugung graphischer Primitiva wie Gerade, Kreis, Rechteck und zur Be-
+ rechnung der konkreten Abbildung graphischer Objekte sowie zur Realisa-
+ tion von Eingaben bentigt werden. Das Konfigurationsprogramm erkennt
+ diese Dateien an der Namensendung '.GCONF', und bietet diese zu
+ Programmbeginn zur Auswahl an.
+ Dann werden die gewhlten Dateien inhaltlich untersucht und die relevan-
+ ten Informationen, Rmpfe der bentigten Prozeduren sowie alle vom Benut-
+ zer zustzlich eingetragenen globalen Objekte (globale Variablen,
+ LET-Objekte, zustzlich bentigte Prozeduren usw.) vom Programm extrahiert
+ und zwischengespeichert.
+ Im letzten Schritt erstellt das Programm schlieálich das Paket 'device
+ interface' in der Datei 'GRAPHIK.Configuration', indem die zwischengespei-
+ cherten Texte sinnvoll zusammengefgt werden.
+ Die bentigten Konfigurationsdateien sind relativ einfach zu erstellen, da
+ sich der Programmierer ausschlieálich mit der Realisation der geforderten
+ Leistungen auf einem Endgert-Typ befassen kann, da die programmseitige
+ Einbindung ins Graphiksystem vom Konfigurationsprogramm vorgenommen
+ wird.
+#page#
+#type("pica")##on("u")##ib(1)#Teil 3.2: Erstellung der Konfigurationsdateien#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Namensgebung: "<Endgertname><Kanalangaben>.GCONF"
+ Konfigurationsdateien zur Anbindung eines Endgert-Types auf der
+ eigenen Station enthalten die bentigten ELAN-Quelltexte zur Realisa-
+ tion der geforderten Leistungen und weitere Verwaltungs- und Berech-
+ nungsoperationen.
+ Das Konfigurationsprogramm erkennt die relevanten Daten bzw. Quelltexte
+ dieser Dateien an verschiedenen Pseudo-Schlsselworten bzw. Pseudo-
+ Prozedurdeklarationen, wobei die Namensgebung hinsichtlich des Pro-
+ zedurnamens, der Parameter sowie ihrer Namen vollstndig festgelegt ist.
+ Daher ist es unzulssig, Parameternamen zu ndern oder Delimiter
+ (Semikolon, Doppelpunkt) fortzulassen.
+ Derartige Fehler werden jedoch i.d.R. vom Konfigurationsprogramm
+ erkannt und gemeldet, wohingegen Fehler in den Prozedurrmpfen, den
+ zustzlichen Prozeduren bzw. das Fehlen zustzlich bentigter Pro-
+ zeduren nicht erkannt, sondern erst beim Compilieren des Gesamt-Paketes
+ vom ELAN-Compiler gemeldet werden.
+ (Die Korrektur im Gesamt-Paket sollte unterlassen werden, vielmehr ist
+ der Fehler in der entsprechenden Konfigurationsdatei zu beheben, falls
+ nicht einfach die Einbindung eines zustzlichen Paketes vergessen
+ wurde.)
+ Zudem ist zu beachten, daá die bentigten Prozedurrmpfe vom Kon-
+ figurationsprogramm in Refinements umgewandelt werden, und zustz-
+ liche Objekte (Prozeduren, LET-Objekte, Variablen) einfach mit ein-
+ gebunden werden, so daá:
+ - Globale und lokale Variablen eindeutig fr alle! Konfigurations-
+ dateien benannt werden mssen.
+ (Zweckmssig: ... VAR endgertname variablenname)
+ - Zustzliche Prozeduren und LET-Objekte ebenso eindeutig benannt
+ werden mssen.
+ - berflssige Delimiter, die aber vom ELAN-Compiler nicht bemngelt
+ werden (z.B. Punkt am Ende des Prozedurrumpfes) nicht vorkommen
+ drfen.
+ - Nicht realisierbare Pseudo-Prozeduren mit leerem Rumpf enthalten
+ sein mssen (z.B. Vordergrund/Hintergrund od. Farben bei
+ Monochrom-Endgerten)
+ - Prozedur-Kpfe bzw. -Enden allein in einer Zeile und an ihrem Anfang
+ stehen mssen.
+
+ Namensgebung: "ENVIRONMENT.GCONF"
+ Dient zur verwaltungsseitigen Einbindung von Endgerten anderer
+ Stationen, da fr diese Endgerte nur die Verwaltungsinformationen
+ bentigt werden, weil die konkrete Anpassung auf der anderen Station
+ erfolgt.
+ Die in 'ENVIRONMENT.GCONF' zeilenweise enthaltenen Informationen werden
+ dem Benutzer bei der Auswahl der Konfigurationsdateien mit angeboten; er
+ kann sie aber auch 'von Hand' in die THESAURUS-Auswahl einfgen.
+
+ Namensgebung: "Dateizweck" (also beliebig)
+ Darberhinaus existieren weitere Dateien, die globale Prozeduren und
+ weitere Objekte enthalten, die fr verschiedene Endgert-Anpassungen
+ ntzlich sein knnen, wie z.B. unten beschriebene Dateien:
+ - 'std primitives'
+ Enthlt Prozeduren zur softwareseitigen Emulation von zwar gefor-
+ derten, hardwareseitig aber eventuell nicht bereitgestellten
+ Leistungen wie 'circle' und 'box'.
+ - 'matrix printer'
+ Enthlt Prozeduren zur Erzeugung von Geraden und Fllmustern auf
+ einer Bitmatrix, die zur graphischen Ausgabe auf Druckern bentigt
+ wird.
+ - 'terminal plot'
+ Enthlt grundlegende Prozeduren zur (behelfsmáigen) Ausgabe von
+ Graphiken auf Ascii-Terminals (Zeichenorientiert, nicht graphikfhig)
+
+ Folgende Pseudo-Schlsselworte bzw. Pseudo-Prozeduren werden vom
+ Konfigurationsprogramm erkannt und behandelt:
+
+ #ib(1)#1.0 Pseudo-Schlsselworte#ie(1)#
+
+ 1.1 #ib(2," (1.1)")#COLORS#ie(2,"")#
+ Syntax: COLORS "RGB-Kombinationen";
+ - Dient der Definition der Standard-Farben.
+ - "RGB-Kombinationen": (TEXT) Pro Farbe 3-ziffrige RGB-
+ (Rot-Grn-Blau)-
+ Kombinationen in normierter
+ Notation
+ (jeder Farbanteil wird durch
+ die Ziffern 0-9 dargestellt;
+ sollte das Endgert dieser
+ Notation nicht gengen, so ist
+ eine anteilige Umrechnung
+ vorzunehmen).
+ Die erste RGB-Kombination
+ wird fr die Hintergrundfarbe
+ verwendet (i.d.R. 000), bei
+ monochromen Endgerten ist
+ also "000999" einzusetzen.
+
+ 1.2 #ib(2," (1.2)")#EDITOR#ie(2,"")#
+ Syntax: EDITOR;
+ - Schlsselwort, das dem Konfigurationsprogramm anzeigt, daá
+ folgende Eingabeprozeduren vorhanden sind:
+ - 'graphik cursor'
+ - 'get cursor'
+ - 'set marker'
+ Fehlt das Schlsselwort, so knnen o.g. Pseudo-Prozeduren weg-
+ gelasssen werden, brauchen also nicht mit leerer Leistung
+ implementiert werden.
+
+ 1.3 #ib(2," (1.3)")#INCLUDE#ie(2,"")#
+ Syntax: INCLUDE "Name der Includedatei";
+ - Schlsselwort, mit dem weitere Dateien in die Konfigurationsdatei
+ textuell eingebunden werden knnen (s.o).
+
+ 1.4 #ib(2," (1.4)")#LINK#ie(2,"")#
+ Syntax: LINK <Station>/<Kanal>, .... ;
+ - Dient zur Anbindung mehrerer Endgerte an einen Endgert-Typ,
+ die hier genannten Kanle werden eigenstndig verwaltet, aber
+ wie das bei 'PLOTTER' definierte Endgert angesteuert; wobei fr
+ alle Endgerte der gleiche Name gilt, sie also durch die Kanal-
+ nummer unterschieden werden.
+ Durch Kommata getrennt, knnen mit dieser Anweisung beliebig
+ viele Endgerte zustzlich angebunden werden.
+ - <Station> : (INT) Stationsnummer des Endgertes
+ (eigene Station)
+ - <Kanal> : (INT) Kanalnummer des Endgertes
+
+ 1.5 #ib(2," (1.5)")#PLOTTER#ie(2,"")#
+ Syntax: PLOTTER "Endgertname",<Station>,<Kanal>,
+ <Xpixel>,<Ypixel>,<Xcm>,<Ycm>;
+ - Dient zur Erkennung als Endgert-Konfigurationsdatei, und zur
+ bergabe der verwaltungsseitig bentigten
+ Endgert-Spezifikationen:
+ - "Endgertname": (TEXT) Name des Endgertes
+ - <Station> : (INT) Stationsnummer des Endgertes
+ (eigene Station)
+ - <Kanal> : (INT) Kanalnummer des Endgertes
+ Jedes Endgert wird ber diese drei Werte eindeutig identifiziert,
+ der Endgertname kann also mehrfach verwendet werden.
+ - <Xpixel> : (INT) X-Rasterkoordinate des letzten
+ Pixels in X-Richtung (i.d.R
+ adressierbare Pixel - 1)
+ - <Ypixel> : (INT) Y-Rasterkoordinate des letzten
+ Pixels in Y-Richtung (s.o.)
+ - <Xcm> : (REAL) Breite der Zeichenflche in cm.
+ - <Ycm> : (REAL) Hhe der Zeiuchenflche in cm.
+ (Mglichst genau ausmessen od. berechnen, um Verzerrungen zu
+ vermeiden)
+ 'PLOTTER' muá als erstes in der Konfigurationsdatei stehen!
+
+ #ib(1)#2.0 Pseudo-Prozeduren#ie(1)#
+
+ 2.1 PROC #ib(2," (2.1)")#background#ie(2," (PROC)")#
+ Syntax: PROC background (INT VAR type):
+ - Stellt die Hintergrundfarbe 'type' ein. Ist bei monochromen End-
+ gerten mit leerer Leistung zu implementieren.In 'type' ist die
+ tatschlich eingestellte Hintergrundfarbe angegeben, womit die
+ erbrachte Leistung kontrolliert werden kann.
+
+ 2.2 PROC #ib(2," (2.2)")#box#ie(2," (PROC)")#
+ Syntax: PROC box (INT CONST x1, y1, x2, y2, pattern):
+ - Zeichnet ein Rechteck mit den gegenberliegenden Ecken
+ 'x1;y1/x2;y2'. Sollte das Endgert diese Leistung nicht erbringen,
+ so muá 'std box' aus 'std.GCONF' mit gleichen Parametern aufge-
+ rufen werden.
+ 'pattern' als Fllmuster kann endgertspezifisch implementiert
+ werden, wobei von System nur 'pattern' = 0 verwendet wird, was ein
+ ungeflltes Rechteck anfordert.
+
+ 2.3 PROC #ib(2," (2.3)")#circle#ie(2," (PROC)")#
+ Syntax: PROC circle (INT CONST x, y, rad, from, to):
+ - Zeichnet einen Kreis oder ein Kreissegment an den Raster-
+ Koordinaten 'x;y', die auch neue Zeichenposition werden. 'rad' gibt
+ den Radius und 'from,to' den Start bzw. Endwinkel im mathematisch
+ positivem Sinne an.
+ Sollte das Endgert diese Leistung nicht erbringen, so muá 'std
+ circle' aus 'std.GCONF' mit gleichen Parametern aufgerufen werden.
+
+ 2.4 PROC #ib(2," (2.4)")#clear#ie(2," (PROC)")#
+ Syntax: PROC clear:
+ - Lscht den Bildschirm bzw. initialisiert das Ausgabe-Raster.
+ Die Zeichenposition wird '0;0' und die Standardfarben werden
+ eingestellt.
+
+ 2.5 PROC #ib(2," (2.5)")#drawto#ie(2," (PROC)")#
+ Syntax: PROC drawto (INT CONST x, y):
+ - Zieht von der aktuellen Zeichenposition eine Gerade zu den Ko-
+ ordinaten 'x;y', die Zeichenposition wird entsprechend gendert.
+
+ 2.6 PROC #ib(2," (2.6)")#endplot#ie(2," (PROC)")#
+ Syntax: PROC endplot:
+ - Schlieát die Graphik-Ausgabe auf einem Endgert ab; evtl. Wechsel
+ in den Text-Modus, ggf. Cursor einschalten.
+ Bei Terminals sollte der Bildschirm nicht gelscht werden.
+
+ 2.7 PROC #ib(2," (2.7)")#fill#ie(2," (PROC)")#
+ Syntax: PROC fill (INT CONST x, y, pattern):
+ - Zustzliche vom System nicht verwendete Leistung zum Fllen von
+ Polygonen (rundum geschlossen), wobei die genau erbrachte Lei-
+ stung und die Bedingungen endgertspezifisch sind.
+
+ 2.8 PROC #ib(2," (2.8)")#foreground#ie(2," (PROC)")#
+ Syntax: PROC foreground (INT VAR type):
+ - Stellt die Vordergrundfarbe 'type' ein. Ist bei monochromen
+ Endgerten mit leerer Leistung zu implementieren.In 'type' ist die
+ tatschlich eingestellte Hintergrundfarbe angegeben, womit die
+ erbrachte Leistung kontrolliert werden kann.
+
+ 2.9 PROC #ib(2," (2.9)")#get cursor#ie(2," (PROC)")#
+ Syntax: PROC get cursor (INT VAR x, y, TEXT VAR exit char):
+ - Wartet auf eine Eingabe vom Endgert, wobei der Cursor beweglich
+ bleiben muá. Wird eine Taste gedrckt, so wird deren Code in 'exit
+ char' und die aktuelle Position des Cursors in 'x;y' eingetragen.
+ Der Cursor sollte nur innerhalb dieser Prozedur beweglich sein,
+ aber immer sichtbar bleiben (falls er eingeschaltet ist).
+
+ 2.10 PROC #ib(2," (2.10)")#graphik cursor#ie(2," (PROC)")#
+ Syntax: PROC graphik cursor (INT CONST x, y, BOOL CONST on):
+ - Schaltet einen endgertseitig vorhandenen graphischen Cursor
+ (i.d.R Fadenkreuz) ein oder aus bzw. setzt ihn auf eine bestimmte
+ Position.
+ Mit 'on' = TRUE wird der Cursor dauerhaft! eingeschaltet bzw. neu
+ positioniert, falls er bereits eingeschaltet war.
+ Mit 'on' = FALSE wird er grundstzlich abgeschaltet.
+ Durch Einschalten des Cursors wird die Wirkung von 'home'
+ verndert:
+ normal - 'home' positioniert die Zeichenposition auf
+ '0;0'
+ cursor - 'home' positioniert die Zeichenposition und
+ den graphischen Cursor auf die Mitte der
+ Zeichenflche.
+
+ 2.11 PROC #ib(2," (2.11)")#home#ie(2," (PROC)")#
+ Syntax: PROC home:
+ - Die Zeichenposition wird auf '0;0' eingestellt; ist ein graphischer
+ Cursor eingeschaltet, so sollte dieser, sowie die Zeichenposition,
+ jedoch auf den Mittelpunkt der Zeichenflche gesetzt werden.
+
+ 2.12 PROC #ib(2," (2.12)")#initplot#ie(2," (PROC)")#
+ Syntax: PROC initplot:
+ - Bereitet die Graphik-Ausgabe auf einem Endgert vor; evtl.
+ Wechsel in den Graphik-Modus, ggf. Cursor abschalten.
+ Bei Terminals sollte der Bildschirm nicht gelscht werden.
+
+ 2.13 PROC #ib(2," (2.13)")#moveto#ie(2," (PROC)")#
+ Syntax: PROC moveto (INT CONST x, y):
+ - Die Zeichenposition wird auf die Koordinaten 'x;y' gesetzt, bei
+ berschreitung der Zeichenflche ist die Wirkung undefiniert.
+
+ 2.14 PROC #ib(2," (2.14)")#prepare#ie(2," (PROC)")#
+ Syntax: PROC prepare:
+ - Bereitet die Ausgabe auf einem Kanal vor.
+ Die eigene Task sollte an den Kanal angekoppelt, und andere Tasks
+ ggf. am Ankoppeln gehindert bzw. abgekoppelt werden (z.B. der
+ PRINTER-Server bei Drucker-Graphik). Es darf erst nach erfolg-
+ reichem Abschluá der Aktion zurckgekehrt werden.
+
+ 2.15 PROC #ib(2," (2.15)")#set marker#ie(2," (PROC)")#
+ Syntax: PROC set marker (INT CONST x, y, type):
+ - Zeichnet an der Position 'x;y', die auch neue Zeichenposition wird,
+ eine Markierung. Folgende Markierungsarten knnen systemseitig
+ verwendet werden:
+ 0 - Kreuz '+'
+ 1 - Kreuz diagonal 'x'
+ Weitere Typen knnen endgertspezifisch implementiert werden.
+
+ 2.16 PROC #ib(2," (2.16)")#setpalette#ie(2," (PROC)")#
+ Syntax: PROC setpalette:
+ - Stellt die aktuell eingestellten RGB-Kombinationen auf dem End-
+ gert ein. Dazu sind die vom Konfigurationsprogramm
+ hinzugefgten Prozeduren 'colors' und 'color' zu verwenden:
+ INT PROC colors
+ - Liefert die Anzahl der fr das Endgert mglichen Farben
+ (abgeleitet aus den mit 'COLOR' angebenen
+ Standard-Kombinationen).
+ INT PROC color (INT CONST no)
+ - Liefert die normierte RGB-Kombination der fr 'no' ein-
+ gestellten Farbe (0 - 999). Die Rckgabe von 'maxint' (32767)
+ bedeutet: Farbe nicht initialisiert oder existiert nicht.
+
+ 2.17 PROC #ib(2," (2.17)")#setpixel#ie(2," (PROC)")#
+ Syntax: PROC setpixel (INT CONST x, y):
+ - Setzt ein Pixel an den Raster-Koordinaten 'x;y'.
+#page#
+#bottom#
+#right#Seite %
+#end#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Teil 4: Graphik-Applikationen
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Teil 4: Graphik-Applikationen#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+
+#type("pica")##on("u")##ib(1)#Teil 4.1: Der Funktionenplotter 'FKT'#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Mit diesem Programmpaket kann man fr beliebige reelle und reellwertige
+ Funktionen Graphen erstellen. Diese Graphen werden im System gespeichert.
+
+ Zur Ausgabe der erstellten Graphen stehen alle graphikfhigen Endgerte
+ zur Verfgung.
+
+ #ib(1)#1.0 Allgemeines ber FKT#ie(1)#
+ Zu einer Zeichnung, wie sie mit 'FKT' erstellt werden kann, gehren
+ folgende Eigenschaften:
+ - Der Name der Zeichnung (zum Wiederfinden)
+ - Das Format
+ - Der Graph mit den Achsen bzw. dem Rahmen.
+
+ Es knnen beliebig viele Zeichnungen angelegt und aufbewahrt werden,
+ wobei der Name aller Zeichnungen mit "PICFILE." beginnt.
+
+ Es wird von FKT zwischen den Definitions- und Wertebereich einerseits
+ und dem Format anderseits unterschieden:
+ - Der Definitionsbereich wird vom Benutzer gewhlt. Er gibt das
+ Intervall an, ber dem der Graph gezeichnet wird. Der
+ Wertebereich wird vom Rechner automatisch ermittelt.
+ - Das Format besteht aus der Angabe von vier Werten, die Auskunft
+ geben ber die maximale Ausdehnung der Koordinatenachsen, wobei
+ die Zeichnung auf den Endgerten stets so abgebildet wird, daá sie
+ unverzerrt in maximaler Gráe (also im grátmglichen Quadrat)
+ gezeichnet wird.
+
+ Der Funktionenplotter FKT ist in allen Sohntasks von 'GRAPHIK' verfg-
+ bar, zustzlich existiert die Task 'FKT', in der das FKT-Menue als
+ Kommandoebene verwendet wird.
+
+ #ib(1)#2.0 Das FKT-Menue#ie(1)#
+ Das Menue des Funktionenplotters ist wie folgt aufgebaut:
+ - in der obersten Zeile wird der eingegebene Funktionsterm angezeigt
+ - die nachfolgende Zeile zeigt in eckigen Klammern den Definitions-
+ bereich und die Schachtelung des Intervalles, ber dem der Graph
+ gezeichnet wird.
+ - dann folgt ebenfalls in eckigen Klammern der von FKT selbst zu
+ ermittelnde Wertebereich der Funktion innerhalb des zuvor
+ definierten Intervalles.
+ Wird kein Funktionsterm angezeigt, oder erscheinen in den eckigen
+ Klammern Sternchen, so wurde noch kein Funktionsterm bzw.
+ Definitionsbereich eingegeben, oder der Wertebereich noch nicht
+ ermittelt.
+ - Der Bereich zwischen o.g Anzeige und der Auflistung der Menuepunkte
+ ist der Dialogbereich, in dem weitere Anfragen an den Benutzer oder
+ auch Fehlermeldungen erscheinen.
+ - Unterhalb der Bildschirmmitte werden die unten beschriebenen
+ Menuepunkte zur Auswahl aufgefhrt.
+ - Dann folgt der Endgert-Auswahlbereich, das Endgert, auf dem eine
+ Zeichnung ausgegeben werden soll, kann mit den Tasten 'Links' bzw.
+ 'Rechts' eingestellt werden, wobei der Name des aktuell eingestellten
+ Endgertes invertiert erscheint.
+ - Als unterste Zeile der FKT-Tapete folgt der Eingabebereich, hier wird
+ der Benutzer zur Eingabe eines bei den Menuepunkten genannten
+ Buchstabens aufgefordert, und dieser bei einem zulssigen
+ Tastendruck dort angezeigt.
+
+ #ib(1)#3.0 FKT-Menuepunkte#ie(1)#
+
+ Jede Eingabe oder Operation kann durch Drcken der Taste 'ESC'
+ abgebrochen werden, die Eingabe wird dann ignoriert, und im Dialog-
+ bereich erscheint die Fehlermeldung 'F E H L E R : Abgebrochen'.
+
+ 3.1 #ib(2," (3.1)")#(f) Funktionsterm eingeben#ie(2,"")#
+ Im Dialogbereich wird die Eingabe des Funktionsterms erwartet, wobei
+ als Variable im Term 'x' verwendet werden muá.
+ Es stehen alle mathematischen Funktionen des EUMEL-Systems zur
+ Verfgung, sofern sie reelle Werte (REAL) zurckliefern.
+ Beispiele von Funktionstermen (alternative Mglichkeiten in eckigen,
+ Erklrungen in runden Klammern):
+
+ 2*x
+ [2x]
+ 2x*x + 3x - 5
+ [2.0*x*x + 3.0*x - 5.0]
+ 0.7 * sqrt (x) (sqrt : Quadratwurzel aus)
+ log10 (x) (log10 : 10-er Logar.)
+ ln (3x) (ln : Nat. Logar.)
+ 2**x (** : Potenzieren)
+ exp (1/x)
+ [e**(1/x)] (exp : Expon.Fktn)
+ arctan (pi*x) (arctan: arkus tangens )
+ sin (x) (sin : Sinus in Radiant )
+ sind (x) (sind : Sinus in Altgrad )
+ 1/(x*x+1)
+
+ Die Klammern drfen dabei NICHT weggelassen werden, es sind nur
+ runde Klammern zulssig, auch geschachtelt, wie z.B. in:
+
+ log10 (abs (sin (x) + 5)) (abs : Absolutbetrag )
+
+ Ein Dezimalkomma gibt es nicht, sondern nur den Dezimalpunkt.
+
+ Beispiele von abschnittsweise definierten Funktionen:
+
+ IF x < 5 THEN x*x ELSE sqrt (x - 5) END IF
+ IF x = 0 THEN 0 ELSE 1/x END IF
+ IF x < 0 THEN x ELIF x = 0 THEN 1 ELSE x*x END IF
+
+ Die sog. Schlsselworte "IF" "THEN" "ELIF" "ELSE" "END IF" mssen
+ dabei immer in der angegebenen Form (alle, in der angegebenen Reihen-
+ folge, vollstndig aus Groábuchstaben) auftauchen.
+
+ IF --+--> THEN --+--> ELSE --> END IF
+ | |
+ | |
+ +--- ELIF --+
+
+
+ Es knnen bei IF auch mehrere Bedingungen mit logischem OR oder AND
+ verknpft werden:
+
+ IF x <= 0 OR x > 100 THEN 0 ELSE x*x END IF
+
+ Hat die Funktion eine Definitionslcke an einer bereits bekannten
+ Stelle, so kann dies im Term auf folgende Art bercksichtigt werden,
+ z.B.:
+
+ IF x = 0 THEN luecke ELSE 1/x END IF
+ IF x < -0.05 THEN -1/x ELIF x > 0.05 THEN 1/x ELSE luecke END IF
+
+ Taucht eine unvorhergesehene Definitionslcke auf, so wird beim
+ Erstellen des Wertebereichs eine entspr. Fehlermeldung ausgegeben.
+ Dann muá entweder der Funktionsterm durch Fallunterscheidung (s.o.)
+ angepaát, oder der Definitionsbereich gendert werden.
+
+ Graphen mit Definitionslcken knnen auch in zwei oder mehr Teilen
+ erstellt werden, nmlich jeweils ber den zusammenhngenden
+ Definitionsintervallen, die keine Lcke enthalten. Dazu muá jeweils
+ die Zeichnung ergnzt (siehe '(z) Zeichnung anfertigen') werden.
+
+ Fehlerquelle: Der Funktionsterm ist fehlerhaft.
+ Es tauchen z.B. dem Rechner unbekannte Operationen auf,
+ Multiplikationszeichen fehlen, andere Symbole als 'x' wurden
+ fr die Variable benutzt, 'END IF' fehlt o..
+
+ 3.2 #ib(2," (3.2)")#(d) Definitionsbereich waehlen#ie(2,"")#
+ Im Dialogbereich wird die Eingabe von Unter- und Obergrenze erwartet,
+ wobei Untergrenze < Obergrenze gilt, ansonsten wird die Eingabe der
+ Obergrenze nochmals gefordert.
+ Erscheinen in der zug. Informationszeile Sterne, so ist die gewhlte
+ Genauigkeit zu groá und sollte umgewhlt werden.
+
+ Fehlerquelle: Der Funktionsterm ist noch nicht vorhanden.
+
+ 3.3 #ib(2," (3.3)")#(w) Wertebereich ermitteln lassen#ie(2,"")#
+ Es werden automatisch der gráte und kleinste Funktionswert
+ ermittelt, also die tatschlichen Grenzen des Wertebereichs.
+ Erscheinen in der zug. Informationszeile Sterne, so ist die gewhlte
+ Genauigkeit zu groá und sollte umgewhlt werden.
+
+ 3.4 #ib(2," (3.4)")#(z) Zeichnung anfertigen#ie(2,"")#
+ Eine Zeichnung kann auf allen zur Verfgung stehenden Gerten
+ ausgegeben werden, wenn sie erzeugt ist.
+ Mit diesem Menuepunkt werden die Zeichnungen nur erstellt, d.h. der
+ Graph erscheint noch nicht auf einem Ausgabegert.
+ Diese Zeichnungen werden dann im System aufbewahrt und knnen
+ somit mehrfach ausgegeben werden.
+
+ Im Dialogbereich wird zunchst der Name der Zeichnung angefordert,
+ dieser beginnt grundstzlich mit dem Prefix 'PICFILE.', das nicht
+ verndert werden kann.
+ Dabei wird als Ergnzung des Namens der Funktionsterm angeboten, so
+ daá die Zeichnung z.B. 'PICFILE.sin(x)' heiát.
+ Dieser Teil des Namens kann aber frei verndert werden.
+ Existiert bereits eine Zeichnung gleichen Namens, so erscheint im
+ Dialogbereich eine Anfrage, wie verfahren werden soll, wobei
+ folgende Mglichkeiten genannt werden:
+
+ - <l> : Die alte Zeichnung wird gelscht.
+ - <n> : Der Name wird erneut zur nderung angeboten.
+ - <e> : Die neue Zeichnung, welche hiernach erstellt wird, wird an die
+ schon existierende Zeichnung angahngt. Dies ist vorteil-
+ haft, wenn mehrere od. abschnittsweise definierte Graphen
+ auf in eine Zeichnung kommen sollen.
+ Die Eingabe anderer Buchstaben wird ignoriert.
+
+ Ansonsten wird eine Zeichnung erstellt, die unter dem eingegebenen
+ Namen abgelegt wird.
+
+ Danach wird im Dialogbereich erfragt, ob und wie das Format der
+ Zeichnung gendert werden soll.
+ Nachdem die Zeichnung erstellt wurde, was durch den
+ Sttzpunkt-Zhler angezeigt wird, muá noch die Farbe, in der der
+ Graph gezeichnet werden soll eingegeben werden.
+
+ Fehlerquelle: Wertebereich ist noch nicht bestimmt (siehe 4).
+ Unzulessiges Format: ymax ist kleiner oder gleich
+ ymin, bzw. xmax ist kleiner
+ oder gleich xmin.
+
+ 3.5 #ib(2," (3.5)")#(a) Ausgabe der Zeichnung auf Endgert#ie(2,"")#
+ Im Dialogbereich wird der Name der auszugebenden Zeichnung erfragt,
+ wobei die zuletzt bearbeitete Zeichnung angeboten wird.
+ Die Wahl von '?' als Namen der Zeichnung ('PICFILE.?') fhrt zu einer
+ Auswahl aller vorhanden Bilder, von denen eines zur Ausgabe
+ ausgewhlt werden kann.
+ Danach kann wie oben nochmals das Format variiert werden.
+ Dann wird im Dialogbereich die berschrift der Zeichnung erfragt,
+ wobei der Funktionsterm angeboten wird. Die berschrift erscheint
+ zentriert am oberen Rand.
+ Je nach Lage des Ursprungs (innerhalb od. auáerhalb der Zeichnung)
+ kann die Ausgabe mit Koordinatensystem od. mit Rahmen gewhlt
+ werden, liegt der Ursprung nicht innerhalb der Zeichnung, so wird
+ grundstzlich der Rahmen verwendet.
+ Zum Abschluá wird dann die Farbgebung von Koordinatensystem bzw.
+ Rahmen sowie der berschrift erfragt, dann wird die Zeichnung auf
+ dem im unteren Teil eingestelltem Endgert ausgegeben.
+
+ 3.6 #ib(2," (3.6)")#(t) Wertetafel erstellen lassen#ie(2,"")#
+ In dem gewhlten Definitionsbereich kann eine Wertetafel erstellt
+ werden, die in einer von Ihnen gewnschten Schrittweite ermittelte
+ Funktionswerte zeigt.
+ Zunchst wird die Schrittweite erfragt, dann die von FKT formatiert
+ erstellte Wertetafel gezeigt.
+ Diese befindet sich in einer Datei, die den Namen des zugehrigen
+ Funktionsterms trgt, existiert diese bereits, so wird die Wertetafel
+ ergnzt.
+ Enthlt diese Tafel Sterne, so mssen Sie die Genauigkeit umwhlen
+ und die Tafel neu erstellen lassen.
+ Nach Verlassen der Anzeige wird noch gefragt, ob die Wertetafel
+ gedruckt, und ob sie aufbewahrt werden soll.
+
+ Fehlerquelle: Definitionsbereich bzw. Funktionsterm ist noch nicht
+ gewhlt.
+ Die Schrittweite wurde zu klein gewhlt. Sie muá so
+ groá sein, daá nicht mehr als 512 Werte zu berechnen
+ sind.
+
+ 3.7 #ib(2," (3.7)")#(l) Zeichnungen auflisten#ie(2,"")#
+ Es wird eine Namesliste aller vorhandenen Zeichnungen gezeigt.
+
+ 3.8 #ib(2," (3.8)")#(?) Hilfestellung#ie(2,"")#
+ Es wird eine Kurzanleitung gezeigt.
+
+ 3.9 #ib(2," (3.9)")#(q) in die Kommandoebene zurck#ie(2,"")#
+ Die Arbeit mit dem Funktionsplotter wird beendet, in normalen Tasks
+ erscheint die Ebene, aus der 'FKT' mit 'fktplot' aufgerufen wurde.
+ Wird die Task 'FKT' mit 'q' verlassen, so wird dagegen die Task
+ abgekoppelt und alle in ihr enthaltenen Zeichnungen gelscht!
+
+ 3.10 #ib(2," (3.10)")#(s) Anzahl der Sttzpunkte waehlen#ie(2,"")#
+ Bei der Ermittlung des Wertebereiches und beim Erstellen des Funk-
+ tionsgraphen ist es wegen der Endlichkeit des Computers nicht mg-
+ lich, alle Punkte des Definitionsbereiches zu benutzen. Deshalb wird
+ der Definitionsbereich diskretisiert, d.h. es wird eine endliche An-
+ zahl von Sttzpunkten ausgesucht. Diese Sttzpunkte liegen gleich-
+ verteilt ber dem Definitionsbereich. Die Mindestanzahl ist 2, d.h. als
+ Sttzpunkte werden nur die beiden Randwerte zugelassen. Aus
+ technischen Grnden ist die Hchstgrenze 512.
+
+ Fehlerquelle: Zahl der Sttzpunkte ist fehlerhaft.
+ Nur ganze Zahlen aus dem Intervall [2;512] zulssig.
+
+ 3.11 #ib(2," (3.11)")#(n) Nachkommastellenzahl whlen#ie(2,"")#
+ Hier kann die Zahl der angezeigten Nachkommastellen eingestellt
+ werden (intern wird immer hchstmgliche Genauigkeit verwendet).
+ Maximal sind neun Nachkommastellen zulssigt, jedoch kann die
+ Genauigkeit zu groá fr das Anzeigeformat werden; dann erscheinen
+ in der Anzeige Sterne (*************).
+ Es gilt grundstzlich:
+ Anzahl Vorkommastellen + Anz. Nachkommastellen = 12.
+
+ 3.12 #ib(2," (3.12)")#(e) Arbeit beenden#ie(2,"")#
+ Die Arbeit mit 'FKT' wird abgeschlossen, die Task vom Terminal
+ abgekoppelt. Fr jede Task bleibt dabei FKT das laufende Programm,
+ d.h. nach erneutem Ankoppeln erscheint wieder die FKT-Tapete. In der
+ Task FKT bleiben die Zeichnungen bei Verlassen mit 'e' erhalten (im
+ Gegensatz zum Verlassen mit 'q').
+
+ 3.13 #ib(2," (3.13)")#(L) Zeichnungen loeschen#ie(2,"")#
+ Es erscheint eine Namensliste aller in der Task enthaltenen
+ Zeichnungen. Die dann ausgewhlten Zeichnungen werden nach noch-
+ maliger Rckfrage gelscht.
+
+ 3.14 #ib(2," (3.14)")#(A) Zeichnungen archivieren#ie(2,"")#
+ Nach Aufruf dieses Menuepunktes knnen Zeichnungen zu anderen
+ Tasks geschickt, oder auch auf Diskette geschrieben werden.
+ Dazu wird der MPG-Dateimanager 'dm' verwendet.
+
+ 3.15 #ib(2," (3.15)")#(b) Zeichnungen beschriften#ie(2,"")#
+ Mit diesem Menuepunkt knnen Zeichnungen frei beschriftet werden.
+ Zunchst wird im Dialogbereich erfragt, wie mit bereits bestehenden
+ Beschriftungen verfahren werden soll:
+
+ - <e> : Die nachfolgenden Texte werden zustzlich zu den schon
+ vorhandenen Beschriftungen angefgt.
+ - <l> : Die vorhandenen Beschriftungen werden gelscht, und es wird
+ zum Menue zurckgekehrt.
+ - <a> : Die Operation wird abgebrochen.
+
+ Nun wird die Farbgebung aller Beschriftungen erfragt,
+ danach wird das aktuelle Format der Zeichnung gezeigt, was bei der
+ Positionierung hilfreich sein kann.
+ Nach der nun geforderten Eingabe des Beschriftungstextes wird die
+ Positionierung der Beschriftung in zwei Weisen angeboten:
+ - in cm : Die nachfolgend einzugebenden Werte werden als
+ cm-Angabe relativ zur unteren linken Ecke der Zeichnung
+ aufgefaát.
+ - in REAL: Die nachfolgend einzugebenden Werte werden als
+ Koordinatenangabe im Koordinatensystem der erstellten
+ Zeichnung aufgefaát ('0;0' demnach im Ursprung) Nach
+ Eingabe o.g. Werte wird noch die Texthhe und Breite erfragt, wobei die
+ eingegebenen Werte als mm-Angaben aufgefát werden (Standard: 5 * 5
+ mm).
+ Anschlieáend wird erfragt, ob noch weitere Beschriftungen
+ vorgenommen werden sollen.
+
+ Fehlerquelle: Zeichnung existiert nicht.
+#page#
+
+#type("pica")##on("u")##ib(1)#Teil 4.2: Die TURTLE-Graphik#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+
+ Die TURTLE-Graphik bietet die Mglichkeit, sehr einfach zweidimensionale
+ Zeichnungen zu erstellen. Sie basiert auf dem in LOGO verwendeten Modell, in
+ dem eine Zeichenposition in jeweils eine bestimmte Richtung vorwrts bzw.
+ rckwrts bewegt werden kann, und die Zeichenrichtung verndert werden
+ kann.Bei den Bewegungen, die vornehmlich relativ zur alten Position bzw.
+ Zeichenrichtung ausgefhrt werden, kann dann eine Linie hinterlassen
+ werden. Diese Art der Graphik eignet sich insbesondere fr Programm-
+ gesteuerte Zeichnungen, wie z.B. die rekursiven 'Sierpinski' - bzw. 'Hilbert'-
+ "Funktionen".
+
+ Die Koordinaten bewegen sich im Intervall von [-500.0,500.0].
+ (0,0) liegt dabei in der Bildschirmmitte und ist auch die Anfangsposition.
+ Der Anfangswinkel ist 0. Winkel werden in Grad angegeben.
+
+ #ib(1)#1.0 Paket: 'turtlegraphics'#ie(1)#
+
+ 1.1 REAL PROC #ib(2," (1.1)")#angle#ie(2," (PROC)")#
+ - liefert den momentanen Winkel zwischen Zeichenrichtung und
+ X-Achse.
+
+ 1.2 PROC #ib(2," (1.2)")#turnto#ie(2," (PROC)")#
+ (REAL CONST w)
+ - Die Zeichenrichtung wird absolut auf den Winkel 'w' als Winkel
+ zwischen Zeichenrichtung und X-Achse eingestellt.
+
+ 1.3 PROC #ib(2," (1.3)")#forward#ie(2," (PROC)")#
+ (REAL CONST s)
+ - Die Zeichenposition wird in Zeichenrichtung um die Strecke 's'
+ verschoben, wobei ggf. gezeichnet wird.
+
+ 1.4 PROC #ib(2," (1.4)")#penup#ie(2," (PROC)")#
+ - Der Zeichenstift wird abgehoben, Bewegungen erzeugen keine
+ Linien mehr.
+
+ 1.5 PROC #ib(2," (1.5)")#forward to#ie(2," (PROC)")#
+ (REAL CONST x,y)
+ - Die Zeichenposition wird absolut auf die Position 'x;y' gesetzt, die
+ Zeichenrichtung wird nicht verndert.
+
+ 1.6 PROC #ib(2," (1.6)")#endturtle#ie(2," (PROC)")#
+ - Wurde die Graphik im Direktmodus ('begin turtle' ohne Parameter),
+ also auch sofort sichtbar erzeugt, so wird die Graphikausgabe in
+ blicher Weise beendet, sonst nunmehr das erzeugte PICFILE
+ ausgegeben.
+
+ 1.7 PROC #ib(2," (1.7)")#pendown#ie(2," (PROC)")#
+ - Der Zeichenstift wird gesenkt, Bewegungen erzeugen Linien.
+
+ 1.8 PROC #ib(2," (1.8)")#beginturtle#ie(2," (PROC)")#
+ (TEXT CONST picfile name)
+ - ffnet ein PICFILE 'picfile name', in das alle Aktionen eingetragen
+ werden. Auf dem Bildschirm geschieht nichts. Ist das Picfile schon
+ vorhanden, werden die Aktionen hinzugefgt.
+
+ 1.9 PROC #ib(2," (1.9)")#beginturtle#ie(2," (PROC)")#
+ - Leitet die direkte graphische Ausgabe einer TURTLE-Graphik ein,
+ alle Aktionen werden sofort auf dem Bildschirm sichtbar.
+
+ 1.10 PROC #ib(2," (1.10)")#turn#ie(2," (PROC)")#
+ (REAL CONST w)
+ - Dreht die Zeichenposition um 'w'-Grad im mathematisch positiven
+ Sinne.
+
+ 1.11 BOOL PROC #ib(2," (1.11)")#pen#ie(2," (PROC)")#
+ - Liefert zurck, ob der Zeichenstift oben (FALSE) oder unten (TRUE)
+ ist, also ob Bewegungen Linien hervorrufen oder nicht.
+
+ 1.12 PROC #ib(2," (1.12)")#getturtle#ie(2," (PROC)")#
+ - In die bergebenen Variablen wird die aktuelle Zeichenposition
+ absolut eingetragen.
+#page#
+ Diese Dokumentation und die einzelnen Programme wurden mit grátmglicher
+ Sorgfalt erstellt bzw. weiterentwickelt.
+ Dennoch kann keine Fehlerfreiheit garantiert oder die Haftung fr evtl. aus
+ Fehlern resultierende Folgen bernommen werden.
+ Fr Hinweise auf Fehler sind die Autoren stets dankbar.
+#page#
+#bottom off#
+#head#
+#type("prop")##center#Dokumentation des MPG-Graphik-Systems
+#type("8.5.klein")##center#Stichwortverzeichnis
+#type("pica.lq")##free(1.0)#
+#end#
+#type("pica")##on("u")##ib(1)#Stichwortverzeichnis#ie(1)##off("u")##type("prop.lq")#
+#free(0.5)#
+(a) Ausgabe der Zeichnung auf Endgert ........... 41 (3.5)
+actual plotter (PROC) ............................ 17 (4.4)
+ALL (OP) ......................................... 27 (3.1)
+angle (PROC) ..................................... 44 (1.1)
+(A) Zeichnungen archivieren ...................... 42 (3.14)
+background * (PROC) .............................. 13 (3.4), 13 (3.5), 19 (1.1),
+ 19 (1.2), 34 (2.1)
+bar * (PROC) ..................................... 8 (2.3), 23 (2.1), 23 (2.2)
+beginplot (PROC) ................................. 23 (2.3)
+beginturtle (PROC) ............................... 45 (1.9), 45 (1.8)
+box (PROC) ....................................... 19 (1.3), 23 (2.4), 34 (2.2)
+(b) Zeichnungen beschriften ...................... 42 (3.15)
+CAT * (OP) ....................................... 8 (2.4)
+channel (PROC) ................................... 17 (4.5)
+circle (PROC) .................................... 8 (2.5), 19 (1.4), 24 (2.5),
+ 34 (2.3)
+clear (PROC) ..................................... 19 (1.5), 19 (1.6), 34 (2.4)
+clearspool ....................................... 3 (2.2)
+clippedline (PROC) ............................... 5 (1.1)
+color (PROC) ..................................... 19 (1.7)
+COLORS ........................................... 32 (1.1)
+colors (PROC) .................................... 20 (1.8)
+(d) Definitionsbereich waehlen ................... 39 (3.2)
+delete picture * (PROC) .......................... 13 (3.6)
+dim * (PROC) ..................................... 8 (2.6)
+down * (PROC) .................................... 13 (3.7), 13 (3.8)
+draw cm * (PROC) ................................. 9 (2.11), 24 (2.12)
+draw cm r * (PROC) ............................... 9 (2.12), 24 (2.13)
+drawingarea * (PROC) ............................. 5 (1.2), 17 (4.6), 17 (4.7)
+draw * (PROC) .................................... 8 (2.8), 8 (2.7), 9 (2.10),
+ 9 (2.9), 24 (2.6), 24 (2.9),
+ 24 (2.8), 24 (2.7), 24 (2.11),
+ 24 (2.10)
+draw r * (PROC) .................................. 9 (2.13), 9 (2.14), 24 (2.14),
+ 25 (2.15)
+drawto (PROC) .................................... 20 (1.9), 34 (2.5)
+(e) Arbeit beenden ............................... 42 (3.12)
+EDITOR ........................................... 33 (1.2)
+end plot (PROC) .................................. 20 (1.10), 20 (1.11), 34 (2.6)
+endturtle (PROC) ................................. 44 (1.6)
+eof * (PROC) ..................................... 13 (3.9)
+erase (PROC) ..................................... 27 (3.3), 27 (3.2)
+exists (PROC) .................................... 27 (3.4)
+extrema * (PROC) ................................. 9 (2.16), 9 (2.15), 13 (3.11),
+ 13 (3.10)
+(f) Funktionsterm eingeben ....................... 38 (3.1)
+fill (PROC) ...................................... 20 (1.12), 34 (2.7)
+first ............................................ 4 (2.9)
+first (PROC) ..................................... 27 (3.5)
+foreground (PROC) ................................ 20 (1.14), 20 (1.13), 35 (2.8)
+forward (PROC) ................................... 44 (1.3)
+forward to (PROC) ................................ 44 (1.5)
+generate plotmanager (PROC) ...................... 27 (3.6)
+get cursor (PROC) ................................ 20 (1.15), 35 (2.9)
+get * (PROC) ..................................... 14 (3.12)
+getturtle (PROC) ................................. 45 (1.12)
+getvalues (PROC) ................................. 5 (1.3), 14 (3.13)
+graphik cursor (PROC) ............................ 20 (1.16), 21 (1.17), 35 (2.10)
+halt ............................................. 4 (2.6)
+halt (PROC) ...................................... 27 (3.7)
+hidden lines * (PROC) ............................ 25 (2.16)
+(?) Hilfestellung ................................ 41 (3.8)
+home (PROC) ...................................... 21 (1.18), 35 (2.11)
+INCLUDE .......................................... 33 (1.3)
+init plot (PROC) ................................. 21 (1.19), 35 (2.12)
+insert picture * (PROC) .......................... 14 (3.14)
+install plotter (PROC) ........................... 17 (4.8)
+is first picture * (PROC) ........................ 14 (3.15)
+killer ........................................... 4 (2.8)
+length * (PROC) .................................. 9 (2.17)
+linetype (PROC) .................................. 25 (2.17)
+LINK ............................................. 33 (1.4)
+list (PROC) ...................................... 27 (3.8), 28 (3.9)
+listspool ........................................ 3 (2.1)
+(l) Zeichnungen auflisten ........................ 41 (3.7)
+(L) Zeichnungen loeschen ......................... 42 (3.13)
+move cm (PROC) ................................... 10 (2.20), 25 (2.21)
+move cm r * (PROC) ............................... 10 (2.21), 25 (2.22)
+move * (PROC) .................................... 9 (2.19), 9 (2.18), 25 (2.18),
+ 25 (2.19), 25 (2.20)
+move r * (PROC) .................................. 10 (2.23), 10 (2.22),
+ 25 (2.23), 25 (2.24)
+move to (PROC) ................................... 21 (1.20), 35 (2.13)
+name (PROC) ...................................... 17 (4.9)
+newvalues (PROC) ................................. 5 (1.4)
+nilpicture * (PROC) .............................. 10 (2.24)
+(n) Nachkommastellenzahl whlen .................. 42 (3.11)
+no plotter (PROC) ................................ 17 (4.10)
+oblique * (PROC) ................................. 5 (1.5), 14 (3.16)
+:= (OP) .......................................... 8 (2.2), 13 (3.2), 13 (3.3),
+ 17 (4.3), 17 (4.2)
+orthographic * (PROC) ............................ 5 (1.6)
+PACKET basisplot ................................. 1 (3.1)
+PACKET deviceinterface ........................... 1 (2.1)
+PACKET devices ................................... 1 (1.4)
+PACKET picfile ................................... 1 (1.3)
+PACKET picture ................................... 1 (1.2)
+PACKET plot ...................................... 1 (3.3)
+PACKET plotinterface ............................. 1 (3.2)
+PACKET transformation ............................ 1 (1.1)
+pendown (PROC) ................................... 44 (1.7)
+pen * (PROC) ..................................... 10 (2.25), 10 (2.26),
+ 26 (2.25), 45 (1.11)
+penup (PROC) ..................................... 44 (1.4)
+perspective * (PROC) ............................. 6 (1.7), 14 (3.17)
+picfiles (PROC) .................................. 28 (3.10)
+picture no * (PROC) .............................. 14 (3.18)
+picture * (PROC) ................................. 11 (2.27)
+pictures * (PROC) ................................ 14 (3.19)
+plot * (PROC) .................................... 29 (4.3), 29 (4.2), 29 (4.1)
+PLOTTER .......................................... 33 (1.5)
+plotterinfo (PROC) ............................... 18 (4.13)
+plotter (PROC) ................................... 18 (4.11), 18 (4.12)
+plotters (PROC) .................................. 18 (4.14)
+prepare (PROC) ................................... 21 (1.21), 36 (2.14)
+put picture * (PROC) ............................. 14 (3.21)
+put * (PROC) ..................................... 14 (3.20)
+(q) in die Kommandoebene zurck .................. 41 (3.9)
+read picture * (PROC) ............................ 14 (3.22)
+reset linetypes * (PROC) ......................... 26 (2.27)
+reset * (PROC) ................................... 26 (2.26)
+reset zeichensatz * (PROC) ....................... 26 (2.28)
+rotate * (PROC) .................................. 11 (2.28), 11 (2.29)
+(s) Anzahl der Sttzpunkte waehlen ............... 42 (3.10)
+save (PROC) ...................................... 28 (3.12), 28 (3.11)
+selected pen * (PROC) ............................ 15 (3.23)
+select pen * (PROC) .............................. 15 (3.24)
+select plotter ................................... 4 (2.7)
+select plotter (PROC) ............................ 18 (4.16), 18 (4.15), 18 (4.17)
+set color (PROC) ................................. 21 (1.22)
+setdrawingarea (PROC) ............................ 6 (1.8)
+set marker (PROC) ................................ 21 (1.23), 36 (2.15)
+setpalette (PROC) ................................ 21 (1.24), 36 (2.16)
+setpixel (PROC) .................................. 21 (1.25), 36 (2.17)
+setvalues (PROC) ................................. 6 (1.9), 15 (3.25)
+spool control .................................... 3 (2.3)
+start ............................................ 4 (2.5)
+start (PROC) ..................................... 28 (3.13)
+station (PROC) ................................... 18 (4.18)
+stdcolors (PROC) ................................. 22 (1.26), 22 (1.27)
+stop ............................................. 3 (2.4)
+stop (PROC) ...................................... 28 (3.14)
+stretch * (PROC) ................................. 11 (2.31), 11 (2.30)
+text * (PROC) .................................... 11 (2.32)
+to eof * (PROC) .................................. 15 (3.26)
+to first pic * (PROC) ............................ 16 (3.27)
+to pic * (PROC) .................................. 16 (3.28)
+transform (PROC) ................................. 6 (1.10)
+translate * (PROC) ............................... 12 (2.33), 12 (2.34)
+turn (PROC) ...................................... 45 (1.10)
+turnto (PROC) .................................... 44 (1.2)
+(t) Wertetafel erstellen lassen .................. 41 (3.6)
+TYPE PICFILE ..................................... 13 (3.1)
+TYPE PICTURE * ................................... 8 (2.1)
+TYPE PLOTTER ..................................... 17 (4.1)
+up * (PROC) ...................................... 16 (3.30), 16 (3.29)
+viewport * (PROC) ................................ 7 (1.14), 16 (3.34)
+view * (PROC) .................................... 6 (1.13), 6 (1.12), 6 (1.11),
+ 16 (3.32), 16 (3.31), 16 (3.33)
+wait for halt (PROC) ............................. 28 (3.15)
+where * (PROC) ................................... 12 (2.35), 12 (2.36),
+ 26 (2.30), 26 (2.29)
+window * (PROC) .................................. 7 (1.15), 7 (1.16), 7 (1.17),
+ 16 (3.35), 16 (3.36)
+write picture * (PROC) ........................... 16 (3.37)
+(w) Wertebereich ermitteln lassen ................ 40 (3.3)
+zeichensatz * (PROC) ............................. 26 (2.31)
+(z) Zeichnung anfertigen ......................... 40 (3.4)
+
diff --git a/app/mpg/1987/doc/PLOTBOOK.ELA b/app/mpg/1987/doc/PLOTBOOK.ELA new file mode 100644 index 0000000..12f881c --- /dev/null +++ b/app/mpg/1987/doc/PLOTBOOK.ELA @@ -0,0 +1,660 @@ +#type ("basker12")##limit (16.0)##block#
+
+#head#
+#type ("triumb18")#
+#center#EUMEL-Grafik-System
+#type ("basker12")#
+#end#
+ #on("italics")#gescheit, gescheiter,
+ gescheitert#off("italics")#
+
+#type ("basker14")#
+#on("bold")#Beschreibung der Graphik-Prozeduren#off("bold")#
+#type ("basker12")#
+
+ #on("italics")#Zweidimensionale PICTURE brauchen weniger Speicherplatz als dreidimen-
+ sionale. Daher werden in einigen Fehlermeldungen unterschiedliche Gráen
+ angegeben.#off("italics")#
+
+#on("underline")#Picture-Prozeduren#off("underline")#
+PICTURE
+
+
+:=
+ OP := (PICTURE VAR l, PICTURE CONST r)
+ Zweck: Zuweisung
+
+CAT
+ OP CAT (PICTURE VAR l, PICTURE CONST r)
+ Zweck: Aneinanderfgen von zwei PICTURE.
+ Fehlerflle:
+ * left dimension <> right dimension
+ Es knnen nur PICTURE mit gleicher Dimension angefgt werden.
+ * Picture overflow
+ Die beiden PICTURE berschreiten die maximale Gráe eines
+ PICTURE.
+
+nilpicture
+ PICTURE PROC nilpicture
+ Zweck: Die Prozedur liefert ein leeres PICTURE zur Initialisierung.
+
+draw
+ PROC draw (PICTURE VAR p, TEXT CONST text)
+ Zweck: Der angegebene Text wird gezeichnet. Der Anfang ist dabei die aktuelle
+ Stiftposition, die nicht verndert wird.
+ Fehlerflle:
+ * Picture overflow
+ Der Text paát nicht mehr in das PICTURE.
+
+ PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle,
+ height, bright)
+ Zweck: Der angegebene Text wird unter dem Winkel #on("italics")#angle#off("italics")# gegenber der
+ Waagerechten mit der Zeichenhhe #on("italics")#hight#off("italics")# und der Breite #on("italics")#bright#off("italics")# gezeich-
+ net. Der Anfang ist dabei die aktuelle Stiftposition, die nicht verndert
+ wird.
+ Fehlerflle:
+ * Picture overflow
+ Der Text paát nicht mehr in das PICTURE.
+
+ PROC draw (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y, z).
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC draw (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y).
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+draw r PROC draw r (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Zeichnen einer Linie der Lnge (x, y, z) relativ zur aktuellen Position.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC draw r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie der Lnge (x, y) relativ zur aktuellen Position.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+draw cm
+ PROC draw cm (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie von der aktuellen Position zur Position (x, y) cm.
+ Dabei werden die angegebenen Projektionsparameter nicht beachtet,
+ sondern die Angaben in #on("bold")#Zentimeter#off("bold")# berechnet.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+draw cm r
+ PROC draw cm r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Zeichnen einer Linie der Lnge (x, y) cm relativ zur aktuellen Position.
+ Dabei werden die angegebenen Projektionsparameter nicht beachtet,
+ sondern die Angaben in #on("bold")#Zentimeter#off("bold")# berechnet.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+move
+ PROC move (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Die aktuelle Position wird auf (x, y, z) gesetzt.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC move (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird auf (x, y) gesetzt.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+move r
+ PROC move r (PICTURE VAR p, REAL CONST x, y, z)
+ Zweck: Die aktuelle Position wird um (x, y, z) erhht.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is two dimensional
+
+ PROC move r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird um (x, y) erhht.
+ Position.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+
+move cm
+ PROC move cm (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird auf (x, y) cm gesetzt. Dabei werden die an-
+ gegebenen Projektionsparameter nicht beachtet, sondern die Angaben in #on("bold")#
+ Zentimeter#off("bold")# berechnet.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+move cm r
+ PROC move cm r (PICTURE VAR p, REAL CONST x, y)
+ Zweck: Die aktuelle Position wird um (x, y) cm erhht. Dabei werden die an-
+ gegebenen Projektionsparameter nicht beachtet, sondern die Angaben in #on("bold")#
+ Zentimeter#off("bold")# berechnet.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+
+bar
+ PROC bar (PICTURE VAR p, REAL CONST width, hight, INT CONST
+ pattern):
+ Zweck: Die Prozedur zeichnet an der aktuellen Position einen Balken mit dem
+ Muster #on("italics")#pattern#off("italics")#: 0 = Leerer Balken
+ 1 = Gepunkteter Balken
+ 2 = Gefllter Balken
+ 3 = Horizontale Linien
+ 4 = Vertikale Linien
+ 5 = Gekreuzte Linien
+ 6 = Diagonale Linien von Links nach Rechts
+ 7 = Diagonale Linien von Rechts nach Links
+ 8 = Gekreuzte diagonale Linien.
+ Die aktuelle Stiftposition wird dabei nicht verndert.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+ * Unknown pattern
+ Das angegebene Muster liegt nicht im Bereich 0-8
+
+circle
+ PROC circle (PICTURE VAR p, REAL CONST from, to, INT CONST
+ pattern)
+ Zweck: Die Prozedur zeichnet an der aktuellen Position ein Kreissegment vom
+ Winkel #on("italics")#from#off("italics")# bis #on("italics")#to#off("italics")# (im Gradmaá) mit dem Muster #on("italics")#pattern#off("italics")# (s.o.). Die
+ aktuelle Stiftposition wird dabei nicht verndert.
+ Fehlerflle:
+ * Picture overflow
+ Zu viele Befehle in einem PICTURE
+ * Picture is three dimensional
+ * Unknown pattern
+ Das angegebene Muster liegt nicht im Bereich 0-8
+
+dim
+ INT PROC dim (PICTURE CONST pic)
+ Zweck: Liefert die Dimension eines PICTURE.
+
+pen
+ INT PROC pen (PICTURE CONST p)
+ Zweck: Liefert den virtuellen Stift des PICTURE
+
+ PROC pen (PICTURE VAR p, INT CONST pen)
+ Zweck: Setzen des (virtuellen) Stiftes eines PICTURE. Bei pen=0 wird das
+ Picture nicht gezeichnet.
+ Fehlerflle:
+ * pen out of range
+ Der gewnschte Stift ist kleiner als 0 oder gráer als 16.
+
+extrema
+ PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y
+ max)
+ Zweck: Die Prozedur liefert die gráten und kleinsten Werte des PICTURE.
+ Fehlerflle:
+ * Picture is three dimensional
+
+ PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y
+ max, z min, z max)
+ Zweck: Die Prozedur liefert die gráten und kleinsten Werte des PICTURE.
+ Fehlerflle:
+ * Picture is two dimensional
+
+where
+ PROC where (PICTURE CONST p, REAL VAR x, y, z)
+ Zweck: Die Prozedur liefert die aktuelle Stiftposition (Angaben mit #on("italics")#cm#off("italics")# werden
+ dabei nicht bercksichtigt).
+ Fehlerflle:
+ * Picture is two dimensional
+
+ PROC where (PICTURE CONST p, REAL VAR x, y, z)
+ Zweck: Die Prozedur liefert die aktuelle Stiftposition (Angaben mit #on("italics")#cm#off("italics")# werden
+ dabei nicht bercksichtigt).
+ Fehlerflle:
+ * Picture is three dimensional
+
+rotate:
+ PROC rotate (PICTURE VAR p, REAL CONST angle)
+ Zweck: Das PICTURE wird um den Punkt (0, 0) um den Winkel #on("italics")#angle#off("italics")# (im
+ Gradmaá) im mathematisch positiven Sinn gedreht.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verndert.
+
+ PROC rotate (PICTURE CONST p, REAL CONST phi, theta, lambda ) :
+ PICTURE 1-397
+ Zweck: Das PICTURE wird um den Winkel #on("italics")#lambda#off("italics")# um die Drehachse #on("italics")#(phi,
+ theta)#off("italics")# gedreht.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verndert.
+
+stretch
+ PROC stretch (PICTURE VAR pic, REAL CONST sx, sy)
+ Zweck: Das PICTURE wird in X-Richtung um den Faktor #on("italics")#sx#off("italics")#, in Y-Rich-
+ tung um den Faktor #on("italics")#sy#off("italics")# gestreckt (bzw. gestaucht). Dabei bewirkt der
+ Faktor
+ s > 1 eine Streckung
+ 0 < s < 1 eine Stauchung
+ s < 0 zustzlich eine Achsenspiegelung.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verndert.
+ Fehlerflle:
+ * Picture is three dimensional
+
+ PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz)
+ Zweck: s. o.
+ Fehlerflle:
+ * Picture is two dimensional
+
+translate
+ PROC translate (PICTURE VAR p, REAL CONST dx, dy)
+ Zweck: Das PICTURE wird um #on("italics")#dx#off("italics")# und #on("italics")#dy#off("italics")# verschoben.
+ Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")#
+ verndert.
+ Fehlerflle:
+ * Picture is three dimensional
+
+ PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz)
+ Zweck: s. o.
+ Fehlerflle:
+ * Picture is two dimensional
+
+plot PROC plot (PICTURE CONST p)
+ Zweck: Das Picfile wird gezeichnet.
+ Achtung: Es wird kein #on("italics")#begin plot#off("italics")# oder #on("italics")#end plot#off("italics")# durchgefhrt. Es wird
+ auch kein Stift gsetzt und die Projektionsparameter bleiben
+ unverndert.
+
+
+#on("underline")#Graphische PICFILE-Prozeduren#off("underline")#
+plot
+ PROC plot (TEXT CONST name)
+ Zweck: Der PICFILE mit dem Namen #on("italics")#name#off("italics")# wird entsprechend der angegebenen
+ Darstellungsart gezeichnet. Diese Parameter (#on("italics")#perspective, orthographic,
+ oblique, view, window etc.#off("italics")#) mssen vorher eingestellt werden.
+ Fehlerflle:
+ * PICFILE does not exist
+ Es existiert kein PICFILE mit dem Namen #on("italics")#name#off("underline")#
+
+ PROC plot (PICFILE VAR p)
+ Zweck: Der PICFILE #on("italics")#p#off("italics")# wird entsprechend der angegebenen Darstellungsart ge-
+ zeichnet. Diese Parameter mssen vorher eingestellt werden:
+
+ #on("bold")#zweidimensional:#off("bold")#
+ obligat: #on("italics")#window#off("italics")# (zweidimensional)
+ optional: #on("italics")#view#off("italics")# (zweidimensional)
+ #on("italics")#viewport#off("italics")#
+ #on("italics")#select pen#off("italics")#
+
+ #on("bold")#dreidimensional:#off("bold")#
+ obligat: #on("italics")#window#off("italics")# (dreidimensional)
+ optional: #on("italics")#view#off("italics")# (dreidimensional)
+ #on("italics")#orthographic | perspective | oblique#off("italics")#
+ #on("italics")#viewport#off("italics")#
+ #on("italics")#select pen#off("italics")#
+
+
+select pen
+ PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line
+ type,
+ BOOL VAR hidden lines) Zweck: Fr die
+ Darstellung des Bildes #on("italics")#p#off("italics")# soll dem #on("italics")#virtuellen#off("italics")# Stift #on("italics")#pen#off("italics")# ein realer Stift
+ zugeordnet werden, der mglichst die Farbe #on("italics")#colour#off("italics")# und die Dicke #on("italics")#thick-
+ ness#off("italics")# hat und dabei Linien mit dem Typ #on("italics")#line type#off("italics")# zeichnet. Es wird die
+ beste Annherung fr das Ausgabegert genommen.
+ Wenn #on("italics")#hidden lines#off("italics")# auf TRUE gesetzt wird, werden bei dreidimensionalen
+ Zeichnungen die verdeckten Linien mitgezeichnet, ansonsten werden sie
+ unterdrckt. Um sicherzustellen, das der Algorithmus auch funktioniert,
+ mssen die Linien allerdings von vorn nach hinten gezeichnet werden. Es
+ ist also nicht mglich, das Bild so zu drehen, das die hinteren Linien
+ zuerst gezeichnet werden.
+ Dabei gelten folgende Vereinbarungen:
+
+ #on("bold")#Farbe:#off("bold")# Negative Farben werden XOR gezeichnet (dunkel wird hell und
+ hell wird dunkel), Farbe 0 ist der Lschstift und positive Farben
+ berschreiben (ersetzen) den alten Punkt mit folgenden Werten:
+
+ 1 Standardfarbe des Endgertes
+ 2 rot
+ 3 blau
+ 4 grn
+ 5 schwarz
+ 6 weiá
+ > 6 nicht normierte Sonderfarben
+
+
+ #on("bold")#Dicke:#off("bold")# 0 Standardstrichstrke des Endgertes, ansonsten Strichstrke in
+ 1/10 mm.
+
+
+ #on("bold")#Linientyp:#off("bold")#
+ 0 keine sichtbare Linie
+ 1 durchgngige Linie
+ 2 gepunktete Linie
+ 3 kurz gestrichelte Linie
+ 4 lang gestrichelte Linie
+ 5 Strichpunktlinie
+ > 5 nicht normierte Linie
+
+ #on("bold")#Verdeckte Linien:#off("bold")#
+ TRUE Verdeckte Linien werden mitgezeichnet
+ FALSE Verdeckte Linien werden unterdrckt (nur bei drei-
+ dimensionalen PICTURE)
+
+ Die hier aufgefhrten Mglichkeiten mssen nicht an allen graphischen
+ Endgerten vorhanden sein. Der gerteabhngige Graphik-Treiber whlt
+ jeweils die bestmgliche Annherung.
+
+ Fehlerflle:
+ * pen out of range
+ #on("italics")#pen#off("italics")# muss im Bereich 1-16 sein.
+
+background
+ PROC background (PICFILE VAR p, INT CONST colour)
+ Zweck: Der Hintergrund wird auf die Farbe #on("italics")#colour#off("italics")# (s.o.) gesetzt wenn mglich.
+
+ INT PROC background (PICFILE CONST p):
+ Zweck: Liefert die eingestellte Hintergrundfarbe.
+
+view
+ PROC view (PICFILE VAR p, REAL CONST alpha)
+ Zweck: Setzt den Winkel der Y-Achse zur Senkrechten auf #on("italics")#alpha#off("italics")# Grad, falls
+ diese nicht senkrecht zur Betrachtungsebene steht.
+
+ PROC view (PICFILE VAR p, REAL CONST phi, theta)
+ Zweck: Dreidimensionale Bilder werden hufig nicht direkt von vorne dargestellt,
+ sondern fr die Betrachtung gedreht. Mit der Prozedur #on("italics")#view#off("italics")# kann die
+ Betrachtungsrichtung durch die Polarwinkel #on("italics")#phi#off("italics")# und #on("italics")#theta#off("italics")# (im Gradmass)
+ angegeben werden. Voreingestellt ist #on("italics")#phi#off("italics")# = 0 und #on("italics")#theta#off("bold")# = 0, d.h. senk-
+ recht von oben.
+
+ Im Gegensatz zu #on("italics")#rotate#off("italics")# hat #on("italics")#view#off("italics")# keine Wirkung auf das eigentliche Bild
+ (PICFILE), sondern nur auf die gewhlte Darstellung. So addieren sich
+ zwar aufeinanderfolgende #on("italics")#Rotationen#off("italics")#, #on("italics")#view#off("italics")# aber geht immer von der
+ Nullstellung aus. Auch kann das Bild durch eine #on("italics")#Rotation#off("italics")# ganz oder
+ teilweise aus oder in das Darstellungsfenster (#on("italics")#window#off("italics")# gedreht werden. Bei
+ #on("italics")#view#off("italics")# verndern sich die Koordinaten der Punkte nicht, d. h. das Fenster
+ wird mitgedreht.
+
+ PROC view (PICFILE VAR p, REAL CONST x, y, z)
+ Zweck: Wie oben, nur werden die Winkel nicht in Polarkoordinaten angegeben,
+ sondern es wird die Blickrichtung als Vektor in Karthesischen Koordina-
+ ten angegeben. (Die Lnge darf ungleich 1 sein).
+
+viewport
+ PROC viewport (PICFILE VAR p, REAL CONST hormin, hormax, vertmin,
+ vertmax) : 1-709
+ Zweck: Die Zeichenflche auf dem Endgert, auf dem das Bild dargestellt werden
+ soll, wird spezifiziert. Dabei wird sowohl die Gráe als auch die relative
+ Lage der Zeichenflche definiert. Der linke untere Eckpunkt der physi-
+ kalischen Zeichenflche des Gertes hat die Koordinaten (0, 0). Die
+ definierte Zeichenflche erstreckt sich
+
+ #on("italics")#hormin - hormax#off("italics")# in der Horizontalen,
+ #on("italics")#vertmin - vertmax#off("italics")# in der Vertikalen.
+
+ So liegt der linke untere Eckpunkt dann bei (#on("italics")#hormin, hormax#off("italics")#), der rechte
+ obere Eckpunkt bei (#on("italics")#hormax, vertmax#off("italics")#).
+
+ Damit sowohl gerteunabhngige als auch maástabgetreue Zeichnungen
+ mglich sind, knnen die Koordinaten in zwei Arten spezifiziert werden:
+ a) #on("bold")#Gertekoordinaten#off("bold")#
+ Die Koordinaten knnen Werte von 0.0 bis 2.0 annehmen. Dabei
+ hat die krzere Seite der physikalischen Zeichenflche definitionsge-
+ má die Lnge 1.0.
+ b) #on("bold")#Absolute Koordinaten#off("bold")#
+ Die Werte werden in #on("italics")#cm#off("italics")# angegeben. Dabei mssen die Maximal-
+ werte aber gráer als 2.0 sein, da sonst Fall a) angenommen wird.
+
+ Voreingestellt ist
+
+ viewport (0.0, 1.0, 0.0, 1.0)
+
+ d.h. das grátmgliche Quadrat, beginnend mit der linken unteren Ecke
+ der physikalischen Zeichenflche. In vielen Fllen wird diese Einstellung
+ ausreichen, so daá der Anwender kein eigenes #on("italics")#viewport#off("italics")# definieren muss.
+
+ Der Abbildungsmaástab wird durch das Zusammenspiel von #on("italics")#viewport#off("italics")# und
+ #on("italics")#window#off("italics")# festgelegt (s. dort). Dabei ist insbesondere darauf zu achten, daá
+ winkeltreue Darstellung nur bei gleichen X- und Y-Maástab mglich
+ ist. Da man oft quadratische Fenster (#on("italics")#window#off("italics")#) verwendet, wurde als
+ Standardeinstellung auch ein quadratisches #on("italics")#viewport#off("italics")# gewhlt.
+
+ Hinweis: Mit der Prozedur #on("italics")#check limit#off("italics")# aus dem PACKET #on("italics")#basis plot#off("italics")# kann die
+ berprfung der Grenzen des eingestellten #on("italics")#viewport#off("italics")#-Bereiches ein-
+ bzw. ausgeschaltet werden. Bei eingeschateter berprfung, werden
+ Linien, die den Bereich berschreiten, am Rand abgetrennt.
+
+
+window
+ PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max)
+ Zweck: Fr die Darstellung eines zweidimensionalen Bildes wird das darzustel-
+ lende Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im In-
+ tervall [#on("italics")#x min, x max#off("italics")#] und deren Y-Koordinaten im Bereich [#on("italics")#y min, y
+ max#off("italics")#] liegen, gehren zum definierten Fenster.Vektoren, die auáerhalb
+ dieses Fensters liegen, gehen ber die durch #on("italics")#viewport#off("italics")# Flche hinaus
+ (s.dort).
+
+ Der Darstellungsmaástab ergibt sich als
+
+ #ub# x max - x min #ue#
+ horizontale Seitenlnge der Zeichenflche
+
+
+ #ub# y max - y min #ue#
+ vertikale Seitenlnge der Zeichenflche
+
+ PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max,
+ z min, z max)
+
+ Zweck: Fr die darstellung eines dreidimensionalen Bildes wird das darzustellende
+ Fenster definiert. Alle Bildpunkte, deren X-Koordinaten im Intervall [#on("italics")#x
+ min, x max#off("italics")#], deren Y-Koordinaten im Bereich [#on("italics")#y min, y max#off("italics")#] und
+ deren Z-Koordinaten im Bereich [#on("italics")#z min, z max#off("italics")#] liegen, gehren zum
+ definierten Fenster. Dieses dreidimensionale Fenster (#on("italics")#Quader#off("italics")#) wird ent-
+ sprechend der eingestellten Projektionsart (orthographisch, perspektivisch
+ oder schiefwinklig) und den Betrachtungswinkeln (s. #on("italics")#view#off("italics")#) auf die spezi-
+ fizierte Zeichenflche abgebildet.
+ Anders als im zweidimensionalen Fall ist das Problem der Maástabe
+ nicht mehr nur durch das Zusammenspiel von #on("italics")#window#off("italics")# und #on("italics")#viewport#off("italics")# zu
+ beschreiben. Hier spielen auch die Projektionsart und Darstellungswinkel
+ herein.
+
+oblique:
+ PROC oblique (PICFILE VAR p, REAL CONST a, b)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#schiefwinklig#off("underline")# als gewnschte
+ Projektionsart eingestellt. Dabei ist (#on("italics")#a, b#off("italics")#) der Punkt auf der X-Y-
+ Ebene, auf den der Einheitsvektor der Z-Richtung abgebildet werden
+ soll.
+
+orthographic
+ PROC orthographic (PICFILE VAR p)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#orthographisch#off("underline")# als gewnschte
+ Projektionsart eingestellt. Bei der orthographischen Projektion wird ein
+ dreidimensionaler Krper mit parallelen Strahlen senkrecht auf der Pro-
+ jektionsebene dabgebildet.
+
+perpective
+ PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz)
+ Zweck: Bei dem (dreidimensionalen) Bild #on("italics")#p#off("italics")# wir #on("underline")#perspectivisch#off("underline")# als gewnschte
+ Projektionsart eingestellt. Der Punkt (#on("italics")#cx, 1/cy, cz#off("underline")#) ist der Fluchtpunkt der
+ Projektion, d. h. alle Parallen zur Z-Achse schneiden sich in diesem
+ Punkt.
+
+extrema
+ PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max)
+ Zweck: Die Prozedur liefert die gráten und kleinsten Werte des PICFILE.
+
+ PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z
+ min,z max) : 1-651
+ Zweck: Die Prozedur liefert die gráten und kleinsten Werte des PICFILE.
+
+
+#on("underline")#Prozeduren zur Manipulation von PICFILE#off("underline")#
+:=
+ OP := (PICFILE VAR p, DATASPACE CONST d)
+ Zweck: Assoziert die PICFILE Variable #on("italics")#p#off("italics")# mit dem Datenraum #on("italics")#d#off("italics")# und initialisiert
+ die Variable, wenn ntig.
+ Fehlerflle:
+ * dataspace is no PICFILE
+ Der anzukoppelnde Datenraum hat einen unzulssigen Typ
+
+picture file
+ DATASPACE PROC picture file (TEXT CONST name)
+ Zweck: Assoziaten eines benannten Datenraumes mit einem PICFILE (s.o.).
+
+put
+ PROC put (FILE VAR f, PICFILE VAR p)
+ Zweck: Schreibt den Inhalt eines PICFILE in ein FILE. Die Informationen
+ werden im internen Format abgelegt.
+
+get
+ PROC get (PICFILE VAR p, FILE VAR f)
+ Zweck: Liest den Inhalt eines PICFILE aus einem FILE. Die Informationen
+ mssen mit #on("italics")#put#off("italics")# geschrieben worden sein.
+ Fehlerfall:
+ * Picfile overflow
+ Es knnen nur maximal 1024 Picture (Stze) in einem PICFILE abgelegt
+ werden.
+
+to first pic
+ PROC to first pic (PICFILE VAR p)
+ Zweck: Positioniert auf das erste PICTURE.
+
+to eof
+ PROC to last pic (PICFILE VAR p)
+ Zweck: Positioniert hinter das letzte PICTURE.
+
+to pic
+ PROC to pic (PICFILE VAR p, INT CONST pos)
+ Zweck: Positioniert auf das PICTURE Nummer #on("italics")#pos#off("italics")#.
+ Fehlerflle:
+ * Position underflow
+ Es wurde eine Position kleiner Null angegeben. * Position after
+ eof Es wurde versucht, hinter das Ende eines PICFILE zu positionieren
+
+up
+ PROC up (PICFILE VAR p)
+ Zweck: Positioniert genau ein PICTURE zurck.
+ Fehlerfall:
+ * Position underflow
+ Es wurde versucht, vor das erste PICTURE zu positionieren
+
+ PROC up (PICFILE VAR p, INT CONST n)
+ Zweck: Positioniert genau #on("italics")#n#off("italics")# Picture zurck.
+ Fehlerfall:
+ * Position underflow
+ Es wurde versucht, vor das erste PICTURE zu positionieren
+
+down
+ PROC down (PICFILE VAR p)
+ Zweck: Positioniert genau ein PICTURE vorwrts.
+ Fehlerfall:
+ * Position after eof
+ Es wurde versucht, hinter das Ende eines PICFILE zu positionieren
+
+ PROC down (PICFILE VAR p, INT CONST n)
+ Zweck: Positioniert genau #on("italics")#n#off("italics")# Picture vorwrts.
+ Fehlerfall:
+ * Position after eof
+ Es wurde versucht, hinter das Ende eines PICFILE zu positionieren
+
+is first picture
+ BOOL PROC is first picture (PICFILE CONST p)
+ Zweck: Liefert genau dann #on("italics")#TRUE#off("italics")#, wenn das erste PICTURE erreicht ist.
+
+eof
+ BOOL PROC eof (PICFILE CONST p)
+ Zweck: Liefert genau dann #on("italics")#TRUE#off("italics")#, wenn das Ende eines PICFILE erreicht ist.
+
+picture no
+ INT PROC picture no (PICFILE CONST p)
+ Zweck: Liefert die Nummer des aktuellen PICTURE.
+
+pictures
+ INT PROC pictures (PICFILE CONST p)
+ Zweck: Liefert die Anzahl PICTURE eines PICFILE.
+
+delete picture
+ PROC delete picture (PICFILE VAR p)
+ Zweck: Lscht das aktuelle PICTURE
+
+insert picture
+ PROC insert picture (PICFILE VAR p)
+ Zweck: Fgt ein PICTURE #on("underline")#vor#off("underline")# der aktuellen Position ein.
+
+read picture
+ PROC read picture (PICFILE CONST p, PICTURE VAR pic)
+ Zweck: Liest das aktuelle PICTURE.
+
+write picture
+ PROC write picture (PICFILE VAR p, PICTURE CONST pic)
+ Zweck: Schreibt das PICTURE #on("italics")#pic#off("italics")# auf der aktuellen Position.
+
+put picture
+ PROC write picture (PICFILE VAR p, PICTURE CONST pic)
+ Zweck: Schreibt das PICTURE #on("italics")#pic#off("italics")# hinter das letzte PICTURE des PICFILE.
+ Die aktuelle Position wird nicht verndert.
+
+#page#
+ #on("italics")#Wo wir sind, da klappt nichts,
+ aber wir knnen nicht berall sein !#off("italics")#
+
+#type ("basker14")#
+#on("bold")#Kurzbeschreibung des Graphik-Editors#off("bold")#
+#type ("basker12")#
+
+In der Kommondozeile werden folgende Informationen angezeigt:
+
+#on("revers")#LEN nnnnn <...Name...> DIM n PEN nn Picture nnnn
+#off("revers")#
+
+
+Folgende Kommandos stehen zur Verfgung:
+
+ PICTURE PROC pic neu
+ PICFILE PROC picfile neu
+ PROC neu zeichnen
+
+ OP UP n (n PICTURE up)
+ OP DOWN n (n PICTURE down)
+ OP T n (to PICTURE n)
+
+ PROC oblique (REAL CONST a, b)
+ PROC orthographic
+ PROC perspective (REAL CONST cx, cy, cz)
+ PROC window (BOOL CONST dev)
+ PROC window (REAL CONST x min, x max, y min, y max)
+ PROC window (REAL CONST x min, x max, y min, y max, z min, z max)
+ PROC viewport (REAL CONST h min, h max, v min, v max)
+ PROC view (REAL CONST alpha)
+ PROC view (REAL CONST phi, theta)
+ PROC view (REAL CONST x, y, z)
+
+ PROC pen (INT CONST n)
+ PROC select pen (INT CONST pen, colour, thickness, line type, BOOL CONST
+ hidden)
+ PROC background (INT CONST colour)
+
+ PROC extrema pic
+ PROC extrema picfile
+ PROC selected pen
+
+ PROC rotate (REAL CONST angle)
+ PROC rotate (REAL CONST phi, theta, lambda )
+ PROC stretch (REAL CONST sx, sy)
+ PROC stretch (REAL CONST sx, sy, sz)
+ PROC translate (REAL CONST dx, dy)
+ PROC translate (REAL CONST dx, dy, dz)
diff --git a/app/mpg/1987/src/ATPLOT.ELA b/app/mpg/1987/src/ATPLOT.ELA new file mode 100644 index 0000000..4799ab0 --- /dev/null +++ b/app/mpg/1987/src/ATPLOT.ELA @@ -0,0 +1,438 @@ +PACKET at plot DEFINES (* at plot *)
+ (* Datum : 14:05:86 *)
+ begin plot, (* Geaendert: 30.05:86 *)
+ end plot, (* Autoren : BJ & CW *)
+ clear, (* MPG Bielefeld *)
+
+ pen,
+ background,
+ foreground,
+ thickness,
+ linetype,
+
+ move,
+ draw,
+ bar, circle,
+ drawing area,
+ range, set range:
+
+LET max x = 719,
+ max y = 347,
+ x pixel = 720,
+ y pixel = 348,
+ x cm = 24.5,
+ y cm = 18.5;
+
+INT VAR thick :: 0, (* Normale Linien *)
+ ltype :: 1,
+ x max :: max x, (* Zeichenfenster *)
+ y max :: max y,
+ x min :: 0,
+ y min :: 0,
+ old x :: 0,
+ old y :: 0;
+
+ROW 5 ROW 4 INT CONST nibble :: ROW 5 ROW 4 INT: (* Bitmuster fuer Linien*)
+ (ROW 4 INT : ( 4369, 4369, 4369, 4369), (* durchgezogen *)
+ ROW 4 INT : ( 17, 17, 17, 17), (* gepunktet *)
+ ROW 4 INT : ( 4369, 0, 4369, 0), (* kurz gestrichelt *)
+ ROW 4 INT : ( 4369, 4369, 0, 0), (* lang gestrichelt *)
+ ROW 4 INT : ( 4369, 4369, 4096, 1)); (* gestrichpunktet *)
+
+PROC begin plot:
+ INT VAR return;
+ REP (* Fehler? Ab und zu versagt der *)
+ control (-5,512+0,0,return); (* Graphik-Aufruf !!!!!! *)
+ UNTIL return <> -1 PER;
+ IF return <> 0
+ THEN errorstop ("Graphik nicht ansprechbar")
+ FI
+END PROC begin plot;
+
+PROC end plot:
+ INT VAR return;
+ pause;
+ control (-5,2,0,return);
+END PROC end plot;
+
+PROC clear:
+ begin plot
+END PROC clear;
+
+PROC pen (INT CONST backgr, foregr, thickn, linety):
+ INT VAR dummy;
+ background (backgr, dummy);
+ thickness (thickn, dummy);
+ linetype (linety, dummy);
+ foreground (foregr, dummy)
+END PROC pen;
+
+PROC background (INT CONST desired, INT VAR realized):
+ realized := 0
+END PROC background;
+
+PROC foreground (INT CONST desired, INT VAR realized):
+ IF desired < 2 OR desired = 5 (* 0 = loeschen, 1 = setzen, 5 = schwarz *)
+ THEN realized := desired
+ ELSE realized := 1
+ FI;
+ IF realized = 0
+ THEN INT VAR return;
+ control ( -9,0,0,return);
+ control (-10,0,0,return)
+ ELSE linetype (ltype,return) (* Alten Typ wiederherstellen *)
+ FI
+END PROC foreground;
+
+PROC linetype (INT CONST desired, INT VAR realized):
+ IF desired > 5
+ THEN realized := 1
+ ELSE realized := desired
+ FI;
+ INT VAR return;
+ ltype := realized;
+ control ( -9,nibble [realized][2], nibble [realized][1], return);
+ control (-10,nibble [realized][4], nibble [realized][3], return);
+ IF realized = 1
+ THEN control (-11,0,0,return)
+ ELSE control (-11,1,0,return)
+ FI
+END PROC linetype;
+
+PROC thickness (INT CONST desired, INT VAR realized):
+ thick := int ( real (desired) / 200.0 * (* Angabe in 1/10 mm *)
+ real (x pixel) / x cm); (* Unrechnung in X Punkte *)
+ realized := thick * 2 + 1 (* Rueckgabe in Punkten *)
+END PROC thickness;
+
+PROC move (INT CONST x,y):
+ old x := x; (* Kein direktes move, da clipping ! *)
+ old y := y
+END PROC move;
+
+PROC draw (INT CONST x,y):
+ draw (old x,old y,x,y);
+END PROC draw;
+
+PROC draw (INT CONST x0,y0,x1,y1):
+ IF thick = 0
+ THEN line (x0,y0,x1,y1)
+ ELSE draw thick line (x0,y0,x1,y1)
+ FI;
+ move (x1,y1)
+END PROC draw;
+
+PROC draw thick line (INT CONST x1,y1,x2,y2):
+ INT VAR x0 :: x1,
+ y0 :: y1,
+ x :: x2,
+ y :: y2;
+ swap if neccessary;
+ REAL VAR xr0 :: real(x0), (* Unwandlung in *)
+ yr0 :: real(y0) / (x cm * real(y pixel)) * (* 1:1-Koordinaten*)
+ (y cm * real(x pixel)),
+ xr1 :: real(x),
+ yr1 :: real(y) / (x cm * real(y pixel)) *
+ (y cm * real(x pixel));
+ INT VAR line counter;
+ control(-11,1,0,line counter);
+ IF is vertical line
+ THEN draw vertical line
+ ELSE draw line
+ FI;
+ move(x1,y1).
+
+ swap if neccessary:
+ IF x < x0 OR (x = x0 AND y < y0)
+ THEN INT VAR dummy :: x0;
+ x0 := x;
+ x := dummy;
+ dummy := y0;
+ y0 := y;
+ y := dummy
+ FI.
+
+ is vertical line:
+ x = x0.
+
+ draw vertical line:
+ INT VAR i;
+ FOR i FROM - thick UPTO thick REP
+ INT VAR return;
+ control(-11, 1,line counter,return); (* Einheitliches Muster ! *)
+ line (xr0+real(i),yr0-real(thick),xr0+real(i),yr1+real(thick))
+ PER.
+
+ draw line:
+ REAL VAR m :: (yr1 - yr0) / (xr1 - xr0),
+ dx :: real(thick)/sqrt(1.0+m**2),
+ dy :: m * dx,
+ xn,
+ yn,
+ diff,
+ dsx :: dy,
+ dsy :: -dx,
+ x incr :: -real(sign(dsx)),
+ y incr :: -real(sign(dsy));
+ xr0 INCR -dx;
+ yr0 INCR -dy;
+ xr1 INCR dx;
+ yr1 INCR dy;
+ xn := xr0 + dsx;
+ yn := yr0 + dsy;
+ REP
+ control (-11, 1,line counter,return);
+ line(xn,yn,xr1 - xr0 + xn,yr1 - yr0 + yn);
+ diff := (2.0*dsy *(xn - (xr0 - dy)) - 2.0 * dsx * (yn - (yr0 + dx)))
+ * real(sign(m));
+ IF diff < 0.0
+ THEN xn INCR x incr
+ ELIF diff > 0.0
+ THEN yn INCR y incr
+ ELSE xn INCR x incr;
+ yn INCR y incr
+ FI
+ UNTIL int(xn - xr0 + dy) = 0 AND int(yn - yr0 - dx) = 0 PER
+
+END PROC draw thick line;
+
+PROC line (REAL CONST x0,y0,x1,y1): (* 1:1-Koordinaten -> Geraetek. *)
+ line (int(x0),int(y0 * (x cm * real(y pixel)) / (y cm * real(x pixel))),
+ int(x1),int(y1 * (x cm * real(y pixel)) / (y cm * real(x pixel))))
+END PROC line ;
+
+PROC line (INT CONST x0,y0,x1,y1): (* Normale Linie mit clipping *)
+ REAL VAR dx :: real(xmax - xmin) / 2.0,
+ dy :: real(ymax - ymin) / 2.0,
+ rx0 :: real(x0-x min) - dx,
+ ry0 :: real(y0-y min) - dy,
+ rx1 :: real(x1-x min) - dx,
+ ry1 :: real(y1-y min) - dy;
+ INT VAR cx0,
+ cy0,
+ cx1,
+ cy1;
+ calculate cells;
+ IF (cx0*cx1 = 1) OR (cy0 * cy1 = 1)
+ THEN (* Linie ausserhalb *)
+ ELSE do clipping
+ FI.
+
+ do clipping:
+ IF cx0 <> 0
+ THEN REAL VAR next x :: real(cx0) * dx;
+ ry0 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx0) + ry0;
+ rx0 := next x
+ FI;
+ calculate cells;
+ IF cy0 <> 0
+ THEN REAL VAR next y :: real(cy0) * dy;
+ rx0 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry0) + rx0;
+ ry0 := next y
+ FI;
+ IF cx1 <> 0
+ THEN next x := real(cx1) * dx;
+ ry1 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx1) + ry1;
+ rx1 := next x
+ FI;
+ calculate cells;
+ IF cy1 <> 0
+ THEN next y := real(cy1) * dy;
+ rx1 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry1) + rx1;
+ ry1 := next y
+ FI;
+ IF (rx1 = rx0) AND (ry1 = ry0)
+ THEN LEAVE line
+ FI;
+ draw std line (int (rx0+dx) + x min,int (ry0+dy) + y min,
+ int (rx1+dx) + x min,int (ry1+dy) + y min).
+
+ calculate cells:
+ cx0 := 0;
+ cy0 := 0;
+ cx1 := 0;
+ cy1 := 0;
+ IF abs(rx0) > dx
+ THEN cx0 := sign(rx0)
+ FI;
+ IF abs(rx1) > dx
+ THEN cx1 := sign(rx1)
+ FI;
+ IF abs(ry0) > dy
+ THEN cy0 := sign(ry0)
+ FI;
+ IF abs(ry1) > dy
+ THEN cy1 := sign(ry1)
+ FI
+
+END PROC line;
+
+PROC draw std line (INT CONST x0,y0,x1,y1): (* Terminallinie ziehen *)
+ INT VAR return;
+ control(-7,x0,max y - y0,return); (* move *)
+ control(-6,x1,max y - y1,return) (* draw *)
+END PROC draw std line;
+
+PROC drawing area (REAL VAR x c, y c, INT VAR x pix, y pix):
+ x pix := x pixel;
+ y pix := y pixel;
+ x c := x cm;
+ y c := y cm
+END PROC drawing area;
+
+PROC range (INT CONST hmin,hmax,vmin,vmax): (* Zeichenflaeche setzen *)
+ x min := max (0, min (max x,h min));
+ x max := max (0, min (max x,h max));
+ y min := max (0, min (max y,v min));
+ y max := max (0, min (max y,v max))
+END PROC range;
+
+PROC set range ( INT CONST hmin, hmax, vmin, vmax):
+ range( hmin, hmax, vmin, vmax )
+ENDPROC set range;
+
+(* Textausgabe von C. Indenbirken *)
+(* Erweitert um stufenlose Rotierbarkeit der Zeichen *)
+
+LET ZEICHENSATZ = ROW 255 TEXT;
+ZEICHENSATZ VAR zeichen;
+INT CONST char x :: 6, char y :: 10;
+
+zeichensatz ("ZEICHENSATZ");
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
+ zeichen := new zeichen;
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC draw char (INT CONST char no,REAL CONST x, y,REAL CONST x size,
+ y size, direction):
+ TEXT CONST character :: zeichen [char no];
+ INT VAR n :: 1, x0, y0, x1, y1;
+ INT CONST len :: length (character);
+ REAL CONST sindir :: sind(direction),
+ cosdir :: cosd(direction);
+ WHILE n < len
+ REP value (character, n, x0, y0, x1, y1);
+ REAL VAR xr0 :: real(x0),
+ yr0 :: real(y0),
+ xr1 :: real(x1),
+ yr1 :: real(y1);
+ transform (xr0, yr0, x, y, x size, y size, sindir,cosdir);
+ transform (xr1, yr1, x, y, x size, y size, sindir,cosdir);
+ draw (int(xr0),int(yr0 * (x cm * real(y pixel)) /
+ (y cm * real(x pixel))),
+ int(xr1),int(yr1 * (x cm * real(y pixel)) /
+ (y cm * real(x pixel))));
+ n INCR 4
+ PER .
+
+END PROC draw char;
+
+PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1):
+ x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1));
+ x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3));
+END PROC value;
+
+INT PROC val (INT CONST n):
+ IF n > 127
+ THEN -256 OR n
+ ELSE n FI
+END PROC val;
+
+PROC transform (REAL VAR x, y,REAL CONST x0, y0,REAL CONST x size, y size,
+ sindir,cosdir):
+ REAL CONST old x :: x, old y :: y;
+ REAL CONST dx :: x size / real(char x) * old x * cosdir -
+ y size / real(char y) * old y * sindir,
+ dy :: y size / real(char y) * old y * cosdir +
+ x size / real(char x) * old x * sindir;
+
+ x := x0 + dx;
+ y := y0 + dy
+END PROC transform;
+
+PROC draw text (REAL CONST x pos, y pos,TEXT CONST msg, REAL CONST angle,
+ REAL CONST height, width):
+ INT VAR i;
+ REAL VAR x :: x pos, y :: y pos,
+ x step :: cosd (angle)*width,
+ y step :: sind (angle)*width;
+ FOR i FROM 1 UPTO length (msg)
+ REP IF control char
+ THEN execute control char
+ ELSE execute normal char FI
+ PER .
+
+control char:
+ akt char < ""32"" .
+
+execute control char:
+ SELECT code (akt char) OF
+ CASE 1: home
+ CASE 2: right
+ CASE 3: up
+ CASE 7: out (""7"")
+ CASE 8: left
+ CASE 10: down
+ CASE 13: return
+ ENDSELECT .
+
+home:
+ x := x pos;
+ y := y pos .
+
+right:
+ x INCR x step; y INCR y step .
+
+up:
+ x INCR y step; y INCR x step .
+
+left:
+ x DECR x step; y DECR y step .
+
+down:
+ x DECR y step; y DECR x step .
+
+return:
+ x := x pos .
+
+execute normal char:
+ draw char (code (akt char), x, y, height, width,
+ angle);
+ x INCR x step;
+ y INCR y step .
+
+akt char:
+ msg SUB i .
+
+END PROC draw text;
+
+PROC draw (TEXT CONST msg):
+ draw (msg,0.0,5.0,5.0)
+END PROC draw;
+
+PROC draw (TEXT CONST msg,REAL CONST angle,REAL CONST heigth,width):
+ REAL CONST xr :: real(old x),
+ yr :: real(old y) / (x cm * real(y pixel)) *
+ (y cm * real(x pixel));
+ draw text (xr,yr,msg,angle,heigth * real(x pixel) / x cm / 10.0,
+ width * real(x pixel) / x cm / 10.0)
+ (* heigth mm --> x punkte *)
+END PROC draw;
+
+PROC draw (TEXT CONST msg , REAL CONST winkel, INT CONST hoehe, breite):
+ draw ( msg, winkel, real(hoehe), real(breite) )
+ENDPROC draw;
+
+PROC bar ( INT CONST xmin, ymin, xmax, ymax, pattern ) :
+ (* zur Zeit leer *)
+ENDPROC bar;
+
+PROC circle ( INT CONST x,y, rad, REAL CONST from, to, INT CONST pattern):
+ (* zur Zeit leer *)
+ENDPROC circle;
+
+END PACKET at plot
diff --git a/app/mpg/1987/src/B108PLOT.ELA b/app/mpg/1987/src/B108PLOT.ELA new file mode 100644 index 0000000..1ca301e --- /dev/null +++ b/app/mpg/1987/src/B108PLOT.ELA @@ -0,0 +1,642 @@ +PACKET basis108 plot DEFINES (* M. Staubermann, 22.06.86 *)
+ drawing area, (* 1.8.0: 09.11.86 *)
+ begin plot, (* SHard 8: 07.02.87 *)
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+ get cursor ,
+
+ testbit, fill, trans,
+ full screen,(* FALSE:Mit Text in den letzten 4 Zeilen *)
+ visible page, work page,
+ ctrl word, (* Zugriff auf control word *)
+ zeichensatz ,
+ get screen ,
+ put screen :
+
+LET max x = 279 ,
+ max y = 191 ,
+
+ hor faktor = 11.2 , { xpixel/cm }
+ vert faktor = 11.29412 , { ypixel/cm }
+
+
+ delete = 0 ,
+ std = 1 ,
+ black = 5 ,
+ white = 6 ,
+ yellow = 7 ,
+{ lilac = 8 , }
+
+ durchgehend = 1 ,
+ gepunktet = 2 ,
+ kurz gestrichelt = 3 ,
+ lang gestrichelt = 4 ,
+ strichpunkt = 5 ,
+
+ onoff bit = 0 ,
+ visible page bit = 1 ,
+ work page bit = 2 ,
+ and bit = 3 ,
+ xor bit = 4 ,
+ size bit = 5 ,
+ pattern bit = 6 ,
+ color bit = 7 ;
+
+
+LET PEN = STRUCT (INT back, fore, thick, line) ,
+ POS = STRUCT (INT x, y) ,
+ ZEICHENSATZ = STRUCT (ROW 255 TEXT char, INT width, height) ,
+ BLOCK = ROW 256 INT ;
+
+INT CONST ctrl clr :: -3 ,
+ ctrl fill :: -4 ,
+ ctrl move :: -5 ,
+ ctrl draw :: -6 ,
+ ctrl test :: -7 ,
+ ctrl ctrl :: -8 ,
+ ctrl trans:: -9 ;
+
+ZEICHENSATZ VAR zeichen; (* 4KB *)
+
+PEN VAR stift ;
+POS VAR pos ;
+INT VAR r, i, n, work page nr, visible page nr,
+ line pattern, control word := 0 ;
+
+visible page (0) ;
+work page (0) ;
+
+clear ;
+zeichensatz ("ZEICHEN 6*10") ;
+
+PROC zeichensatz (TEXT CONST name) :
+
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name) ;
+ zeichen := new zeichen
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht")
+ FI
+
+END PROC zeichensatz;
+
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+
+ x cm := 25.0 ;
+ y cm := 17.0 ;
+ x pixel := max x ;
+ y pixel := max y
+
+END PROC drawing area;
+
+
+PROC begin plot :
+ setbit (control word, onoff bit) ;
+ graphic control
+ENDPROC begin plot ;
+
+
+PROC end plot :
+ resetbit (control word, onoff bit) ;
+ graphic control
+ENDPROC end plot ;
+
+
+PROC ctrl word (INT CONST word) :
+ control word := word ;
+ graphic control
+ENDPROC ctrl word ;
+
+
+INT PROC ctrl word :
+ control word
+ENDPROC ctrl word ;
+
+
+PROC full screen (BOOL CONST true) :
+
+ IF true
+ THEN resetbit (control word, size bit)
+ ELSE setbit (control word, size bit)
+ FI ;
+ graphic control
+
+ENDPROC full screen ;
+
+
+PROC fill (INT CONST muster) :
+(********************************************************************)
+(* *)
+(* FILL (muster nummer) *)
+(* Fllt eine beliebig (sichtbar) umrandete Flche mit *)
+(* dem angegebenen Muster. *)
+(* *)
+(* Das Muster ist eine 8 x 8 Matrix, die sich auf allen pos MOD 8*)
+(* -Adressen wiederholt. *)
+(* Im NAND-Modus wird mit dem inversen Muster gefllt, die Flche*)
+(* muá dann aber mit unsichtbaren Pixels begrenzt werden. *)
+(* *)
+(* Folgende Muster sind mglich: *)
+(* 0 = 'solid' (alles gefllt) *)
+(* 1 = 'lrs2' (jeder zweite Punkt, Zeilenweise versetzt) *)
+(* 2 = 'row4' (jede 4. Zeile wird gefllt) *)
+(* 3 = 'row2' (jede 2. Zeile wird gefllt) *)
+(* 4 = 'col4' (jede 4. Spalte wird gefllt) *)
+(* 5 = 'col2' (jede 2. Spalte wird gefllt) *)
+(* 6 = 'grid4' (jede 4. Spalte/Zeile wird gefllt) *)
+(* 7 = 'grid2' (jede 2. Spalte/Zeile wird gefllt) *)
+(* 8 = 'ls4' (Schraffur links unten --> rechts oben, jede 4.) *)
+(* 9 = 'rs4' (Schraffur rechts unten --> links oben, jede 4.) *)
+(* 10 = 'lrs4' (Schrges Gitter wie 8 und 9 zusammen) *)
+(* 11 = 'point2'(In jeder 2. Zeile jeder 2. Punkt) *)
+(* 12 = 'wall4' (Mauer, ein Ziegelstein 4 Pixel hoch) *)
+(* 13 = 'basket'(Korb/Netz) *)
+(* 14 = 'wave4' (Wellenlinie 4 Pixel hoch) *)
+(* 15 = 'wave8' (Wellenlinie 8 Pixel hoch) *)
+(* *)
+(* Falls die zu fllende Flche zu komplex wird, kann es vorkommen,*)
+(* daá der interne Stack berluft. In diesem Fall wird nicht die *)
+(* gesamte Flche gefllt wird. *)
+(* *)
+(********************************************************************)
+ control (ctrl fill, muster, 0, r)
+
+ENDPROC fill ;
+
+
+PROC trans (INT CONST from, to) :
+(********************************************************************)
+(* *)
+(* TRANS (from page, to page) *)
+(* Kopiert den Inhalt der Graphikseite 'from page' in die *)
+(* Seite 'to page'. Folgende Seitennummern sind mglich: *)
+(* *)
+(* 0 : Seite 0 kann mit 'visible page (0)' angezeigt werden *)
+(* 1 : Seite 1 kann mit 'visible page (1)' angezeigt werden *)
+(* 2 : Seite 2 kann nicht sichtbar werden (Hilfsspeicher-Seite) *)
+(* 3 : hnlich Seite 2, wird aber bei 'FILL' noch als Arbeits- *)
+(* seite benutzt (wird dann berschrieben!) *)
+(* *)
+(********************************************************************)
+
+ control (ctrl trans, from, to, r)
+ENDPROC trans ;
+
+
+BOOL PROC testbit (INT CONST x, y) :
+(********************************************************************)
+(* *)
+(* TEST (x pos, y pos) --> Byte *)
+(* Testet den Status eines bestimmten Pixels. *)
+(* *)
+(* Die Pixelposition wird mit xpos/ypos beschrieben. *)
+(* Als Result wird zurckgeliefert: *)
+(* 255, falls xpos/ypos auáerhalb des sichtbaren Fensters *)
+(* liegt. *)
+(* Bit 0 = 1: Pixel sichtbar *)
+(* Bit 0 = 0: Pixel unsichtbar *)
+(* Bit 7 = 1: Pixelfarbe ist hell (gelb) *)
+(* Bit 7 = 0: Pixelfarbe ist dunkel (violett) *)
+(* *)
+(********************************************************************)
+
+ control (ctrl test, x, y, r) ;
+ bit (r, 0)
+ENDPROC testbit ;
+
+
+PROC clear :
+(********************************************************************)
+(* *)
+(* CLR (seite, muster) *)
+(* Fllt die angegebene Seite mit dem angegebenen Muster *)
+(* *)
+(* Bit 7 des Musters bestimmt die Farbe (0 = dunkel, 1 = hell) *)
+(* Die anderen 7 Bits werden Spalten- und Zeilenweise wiederholt.*)
+(* (128 lscht die Seite mit unsichtbaren Punkten) *)
+(* *)
+(********************************************************************)
+
+ pos := POS : (0, 0) ;
+ stift := PEN : (std, std, std, durchgehend) ;
+ pen (std, std, std, durchgehend) ; (* Standard pen *)
+ control (ctrl clr, work page nr, control word AND 128, r) ;
+
+END PROC clear;
+
+
+PROC pen (INT CONST background, foreground, thickness, linetype) :
+(********************************************************************)
+(* *)
+(* CTRL (flags, linienmuster) *)
+(* Setzt verschiedene Graphikmodi. *)
+(* *)
+(* Die Bits im ersten Parameter sind folgendermaáen zugeordnet. *)
+(* *)
+(* Bit 0 : *)
+(* 0 = Textmodus einschalten, Graphikmodus ausschalten *)
+(* 1 = Graphikmodus einschalten, Textmodus ausschalten *)
+(* Bit 1 : *)
+(* 0 = Seite 0 als sichtbare Seite whlen *)
+(* 1 = Seite 1 als sichtbare Seite whlen *)
+(* Bit 2 : *)
+(* 0 = Seite 0 als bearbeitete Seite whlen *)
+(* 1 = Seite 1 als bearbeitete Seite whlen *)
+(* Bit 3, 4 : Verknpfung Patternbit: 0 1 *)
+(* 0 OR setzen unverndert *)
+(* 1 NAND lschen unverndert *)
+(* 2 XOR invertieren unverndert *)
+(* 3 COPY lschen setzen *)
+(* Bit 5 : *)
+(* 0 = Der gesmate Bildschirm zeigt die Graphikseite ('full') *)
+(* 1 = In den letzten 32 Graphikzeilen erscheint die Textseite *)
+(* Bit 6 : *)
+(* 0 = Das im zweiten Parameter bergebene Wort wird als 16-Bit *)
+(* Linienmuster eingestellt. Modus siehe Bit 3/4. *)
+(* 1 = Das alte (bzw. voreingestellte) Linienmuster wird benutzt*)
+(* Bit 7 : *)
+(* 0 = Als Punkthelligkeit wird 'dunkel' (bzw. Violett) eingest.*)
+(* 1 = Als Punkthelligkeit word 'hell' (bzw. Gelb) eingestellt *)
+(* Bit 8..11 : *)
+(* 0 = Default-Strichdicke (1) *)
+(* 1..15 = Strichdicke (Es werden 2*s-1 Linien parallel ge- *)
+(* zeichnet.) *)
+(* *)
+(* Der zweite Parameter enthlt das 16-Bit Linienmuster. Dieses *)
+(* wird beim zeichnen einer Linie zyklisch Bitweise abgetastet. *)
+(* Je nach Status des Bits im Linienmuster wird eine Punkt- *)
+(* aktion ausgefhrt, deren Wirkung im 1. Parameter mit den Bits *)
+(* 3 und 4 spezifiziert wird. *)
+(* *)
+(********************************************************************)
+
+ INT CONST farbe := abs (foreground) ;
+ set thickness ;
+ set linetype ;
+ set colour ;
+ graphic control ;
+ stift := PEN : (background, foreground, abs (thickness), linetype) .
+
+set colour :
+ IF farbe = std OR farbe = yellow OR farbe = white
+ THEN set bit (control word, color bit)
+ ELSE reset bit (control word, color bit)
+ FI ;
+ IF farbe = delete OR farbe = black
+ THEN set bit (control word, and bit) ; (* RESET *)
+ reset bit (control word, xor bit)
+ ELIF foreground < 0 AND thickness >= 0
+ THEN set bit (control word, xor bit) ; (* XOR *)
+ reset bit (control word, and bit)
+ ELIF foreground < 0 (* AND thickness < 0 *)
+ THEN set bit (control word, xor bit) ; (* COPY *)
+ set bit (control word, and bit)
+ ELSE reset bit (control word, xor bit) ; (* SET *)
+ reset bit (control word, and bit)
+ FI .
+
+set thickness :
+ control word := (control word AND 255) + 256 * abs (thickness) .
+
+set linetype:
+ reset bit (control word, pattern bit) ; (* Pattern neu definieren *)
+ SELECT linetype OF
+ CASE durchgehend : line pattern := -1
+ CASE gepunktet : line pattern := 21845
+ CASE kurz gestrichelt : line pattern := 3855
+ CASE lang gestrichelt : line pattern := 255
+ CASE strichpunkt : line pattern := 4351
+ OTHERWISE : line pattern := line type
+ END SELECT .
+
+END PROC pen;
+
+
+PROC move (INT CONST x, y) :
+(********************************************************************)
+(* *)
+(* MOVE (x pos, y pos) *)
+(* Setzt den (unsichtbaren) Graphikcursor auf xpos/ypos. *)
+(* *)
+(* Der nchste 'draw' zeichnet eine Linie beginnend bei xpos/ypos*)
+(* *)
+(********************************************************************)
+
+ control (ctrl move, x, y, r) ;
+ pos := POS:(x, y)
+
+END PROC move;
+
+
+PROC draw (INT CONST x, y) :
+(********************************************************************)
+(* *)
+(* DRAW (x pos, y pos) *)
+(* Zeichnet eine Linie zur angegebeben Position xpos/ypos. *)
+(* *)
+(* Die eingestellten Parameter Helligkeit, Linientyp, Bitver- *)
+(* knpfung und Dicke werden beachtet. *)
+(* Der nchste 'draw' zeichnet eine Linie beginnend bei xpos/ypos*)
+(* *)
+(********************************************************************)
+
+ control (ctrl draw, x, y, r) ;
+ pos := POS : (x, y) .
+
+END PROC draw;
+
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+{ x fak = width * hor faktor / max width
+ y fak = heigth * vert faktor / max height
+ x' = x fak * ( x * cos phi + y * sin phi) + x pos
+ y' = y fak * (-x * sin phi + y * cos phi) + y pos
+ x step = x fak * max width * cos phi
+ y step =-y fak * max height * sin phi }
+
+ REAL CONST sin a :: sind (angle) ,
+ cos a :: cosd (angle) ,
+ x fak :: character width ,
+ y fak :: character height ;
+ INT CONST xstep :: character x step ,
+ ystep :: character y step ;
+
+ REAL VAR x off r, y off r ;
+ INT VAR x pos := pos.x ,
+ y pos := pos.y ,
+ x off, y off, i ;
+
+ POS VAR old pos := pos;
+ FOR i FROM 1 UPTO length (record) REP
+ draw character i
+ PER ;
+ pos := old pos .
+
+character width:
+ IF width = 0.0
+ THEN 1.0
+ ELSE hor faktor * width / real (zeichen.width)
+ FI .
+
+character x step:
+ int (hor faktor * width * cos a + 0.5) .
+
+character height:
+ IF height = 0.0
+ THEN 1.0
+ ELSE vert faktor * height / real (zeichen.height)
+ FI .
+
+character y step:
+ int (- vert faktor * height * sin a + 0.5) .
+
+draw character i:
+ IF code (record SUB i) < 32
+ THEN steuerzeichen
+ ELSE normale zeichen
+ FI .
+
+steuerzeichen:
+ SELECT code (record SUB i) OF
+ CASE 2 : x pos INCR x step ; y pos INCR y step
+ CASE 3 : x pos DECR x step
+ CASE 7 : out (""7"")
+ CASE 8 : x pos DECR x step ; y pos DECR y step
+ CASE 10 : y pos INCR y step
+ CASE 13: x pos := pos.x ; y pos := pos.y
+ END SELECT .
+
+normale zeichen:
+ TEXT CONST char :: zeichen.char [code (record SUB i)] ;
+ INT CONST char len :: LENGTH char DIV 2 ;
+ IF char len < 2
+ THEN LEAVE normale zeichen
+ FI ;
+ x off r := real ((char ISUB 1) AND 15) ;
+ y off r := real ((char ISUB 2) AND 15) ;
+ move (int (0.5 + x fak * (x off r * cos a + y off r * sin a)) + x pos,
+ int (0.5 + y fak * (x off r *-sin a + y off r * cos a)) + y pos) ;
+
+ n := 3 ;
+ WHILE n <= char len REP
+ x off := char ISUB n ;
+ n INCR 1 ;
+ y off := char ISUB n+1 ;
+ n INCR 1 ;
+ BOOL CONST to draw := ((x off OR y off) AND 16384) = 0 ;
+ x off r := real (x off AND 15) ;
+ y off r := real (y off AND 15) ;
+ IF to draw
+ THEN
+ draw (int (0.5 + x fak * (x off r * cos a + y off r * sin a)) + x pos,
+ int (0.5 + y fak * (x off r *-sin a + y off r * cos a)) + y pos)
+ ELSE
+ move (int (0.5 + x fak * (x off r * cos a + y off r * sin a)) + x pos,
+ int (0.5 + y fak * (x off r *-sin a + y off r * cos a)) + y pos)
+ FI
+ PER ;
+
+ x pos INCR x step ;
+ y pos INCR y step .
+
+END PROC draw ;
+
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+ get cursor (t, x, y, -1, -1, -1, -1)
+END PROC get cursor;
+
+
+PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1) :
+ get cursor (t, x, y, x0, y0, x1, y1, FALSE)
+ENDPROC get cursor ;
+
+
+PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1,
+ BOOL CONST only one key):
+ BOOL VAR hop key := FALSE ;
+ t := "" ;
+ check;
+ init cursor;
+ REP set cursor;
+ get step;
+ set cursor;
+ move cursor
+ UNTIL only one key PER ;
+ graphic control .
+
+init cursor:
+ control (ctrl ctrl, 17 + (control word AND 134), -1, r) ;
+ INT VAR delta := 1 ;
+ x := pos.x ;
+ y := pos.y .
+
+set cursor:
+ IF x0 >= 0 AND y0 >= 0
+ THEN control (ctrl move, x0, y0, r);
+ control (ctrl draw, x, y, r)
+ FI;
+ IF x1 >= 0 AND y1 >= 0
+ THEN control (ctrl move, x1, y1, r);
+ control (ctrl draw, x, y, r)
+ FI;
+ control (ctrl move, x - 4, y, r);
+ control (ctrl draw, x + 4, y, r);
+ control (ctrl move, x, y + 4, r);
+ control (ctrl draw, x, y - 4, r) .
+
+get step:
+ hop key := t = ""1"" ;
+ t := incharety (1);
+ IF t <> ""
+ THEN delta INCR 1
+ ELSE delta := 1 ;
+ inchar (t)
+ FI .
+
+move cursor:
+ IF hop key
+ THEN hop mode
+ ELSE single key
+ FI ;
+ check .
+
+single key :
+ SELECT code (t) OF
+ CASE 1 :
+ CASE 2, 54 : x INCR delta (* right, '6' *)
+ CASE 3, 56 : y INCR delta (* up, '8' *)
+ CASE 8, 52 : x DECR delta (* left, '4' *)
+ CASE 10, 50 : y DECR delta(* down, '2' *)
+ CASE 55 : x DECR delta ; y INCR delta (* '7' *)
+ CASE 57 : x INCR delta ; y INCR delta (* '9' *)
+ CASE 49 : x DECR delta ; y DECR delta (* '1' *)
+ CASE 51 : x INCR delta ; y DECR delta (* '3' *)
+ OTHERWISE leave get cursor ENDSELECT .
+
+hop mode :
+ SELECT code (t) OF
+ CASE 1 : t := "" ; x := 0 ; y := max y ;
+ CASE 2, 54 : x := max x
+ CASE 3, 56 : y := max y
+ CASE 8, 52 : x := 0
+ CASE 10, 50 : y := 0
+ CASE 55 : x := 0 ; y := max y
+ CASE 57 : x := max x ; y := max y
+ CASE 49 : x := 0 ; y := 0
+ CASE 51 : x := max x ; y := 0
+ OTHERWISE t := ""1"" + t ; leave get cursor ENDSELECT .
+
+leave get cursor:
+ control (ctrl move, pos.x, pos.y, r);
+ graphic control ;
+ LEAVE get cursor .
+
+check :
+ IF x < 0
+ THEN x := 0 ; out (""7"")
+ ELIF x > max x
+ THEN x := max x ; out (""7"") FI ;
+
+ IF y < 0
+ THEN y := 0 ; out (""7"")
+ ELIF y > max y
+ THEN y := max y ; out (""7"") FI .
+
+END PROC get cursor;
+
+
+.graphic control :
+ control (ctrl ctrl, control word, line pattern, r) .
+
+
+PROC get screen (TEXT CONST name, INT CONST screen nr):
+ IF exists (name)
+ THEN get screen (old (name), screen nr)
+ ELSE get screen (new (name), screen nr)
+ FI ;
+END PROC get screen;
+
+
+PROC get screen (DATASPACE CONST to ds, INT CONST screen nr) :
+(********************************************************************)
+(* *)
+(* BLOCKIN/BLOCKOUT (0, seiten nummer * 16 + block) *)
+(* 512 Bytes in/aus dem Graphikspeicher transportieren. *)
+(* *)
+(* Der zweite Parameter sollte zwischen 0..63 liegen. Als Seiten *)
+(* sind also sowohl die 'displayable' 0 und 1, sowie 'temporary' *)
+(* 2 und 3 erlaubt. *)
+(* *)
+(********************************************************************)
+
+ INT CONST page :: screen nr * 16 ;
+ BOUND ROW 16 BLOCK VAR screen := to ds ;
+ FOR i FROM 0 UPTO 15 REP
+ blockin (screen (i+1), 0, page + i, r)
+ PER
+
+END PROC get screen;
+
+
+PROC put screen (TEXT CONST name, INT CONST screen nr):
+ IF exists (name)
+ THEN put screen (old (name), screen nr)
+ ELSE errorstop ("Der Datenraum """ + name + """ existiert nicht") FI
+END PROC put screen;
+
+
+PROC put screen (DATASPACE CONST from ds, INT CONST screen nr) :
+
+ BOUND ROW 16 BLOCK VAR screen :: from ds ;
+ INT CONST page :: screen nr * 16 ;
+ FOR i FROM 0 UPTO 15 REP
+ block out (screen (i+1), 0, page + i, r)
+ PER
+
+END PROC put screen;
+
+
+PROC work page (INT CONST nr) :
+
+ work page nr := nr ;
+ IF bit (nr, 0)
+ THEN setbit (control word, work page bit)
+ ELSE reset bit (control word, work page bit)
+ FI ;
+ graphic control
+
+ENDPROC work page ;
+
+
+PROC visible page (INT CONST nr) :
+
+ visible page nr := nr ;
+ IF bit (nr, 0)
+ THEN setbit (control word, visible page bit)
+ ELSE reset bit (control word, visible page bit)
+ FI ;
+ graphic control
+
+ENDPROC visible page ;
+
+
+INT PROC visible page :
+ visible page nr
+ENDPROC visible page ;
+
+
+INT PROC work page :
+ work page nr
+ENDPROC work page ;
+
+
+END PACKET basis108 plot ;
diff --git a/app/mpg/1987/src/BASISPLT.ELA b/app/mpg/1987/src/BASISPLT.ELA new file mode 100644 index 0000000..366f4a6 --- /dev/null +++ b/app/mpg/1987/src/BASISPLT.ELA @@ -0,0 +1,781 @@ +PACKET basis plot DEFINES (* Autor: H. Indenbirken *)
+ (* Stand: 30.12.84 *)
+(********************** Hardwareunabhngiger Teil *************************
+* *
+* *
+* Im Harwareunabhngigen Paket 'transformation' werden folgende *
+* Prozeduren definiert: *
+* Procedure : Bedeutung *
+* -------------------------------------------------------------------*
+* transform : Sie Prozedur projeziert einen dreidimensionalen *
+* Vektor (x,y,z) auf einen zweidimensionalen (h,v)*
+* set values : Mit dieser Prozedur werden die Projektionspara- *
+* meter gesetzt. *
+* size: Weltkoordinatenbereich *
+* ((xmin,xmax),(ymin,ymax),(zmin,zmax)) *
+* limits: Zeichenflche *
+* ((h min, h max), (v min, v max)) *
+* Bei Werten < 2.0 werden die Werte als *
+* Prozente interpretiert, ansonsten als *
+* cm-Grssen. *
+* get values : bergibt die aktuellen Werte *
+* new values : Vermerkt neue Werte *
+* *
+* *
+* drawing area : bergibt die aktuelle Zeichengráe in Pixel. *
+* *
+* angles : a) alpha: Winkel der Y-Achse in Grad *
+* b) (x, y, z): karth. Projektionswinkel *
+* oblique : Schiefwinklige Projektion mit dem *
+* Normalenvektor (a, b). *
+* perspective : Perspektive mit dem Betrachtungsstandort *
+* (x, y, z). *
+* window : siehe set values, size *
+* viewport : siehe set values, limit *
+* view : siehe set values, angle *
+* oblique : Schiefwinklige Projektion *
+* orthographic : Orthografische Projektion *
+* perspective : Perspektivische Projektion *
+* *
+* *
+* box : Rahmen um die aktuelle Zeichenflche *
+* reset : Lscht alte verdeckte Linien *
+* hidden lines : Unterdrckt verdeckte Linien *
+* *
+* move : Positioniert auf (x, y, [z]) in Weltkoordinaten *
+* draw : Zeichnet eine Linie bis zum Punkt (x, y, [z]). *
+* move r : Positioniert (x, y, [z]) weiter *
+* draw r : Zeichnet (x, y, [z]) weiter *
+* move cm : Positioniert auf (x cm, y cm). *
+* draw cm : Zeichnet eine Linie bis (x cm, y cm) *
+* move cm r : Positioniert (x cm, y cm) weiter *
+* draw cm r : Zeichnet (x cm, y cm) weiter *
+* *
+* bar : Balken mit (hight, width, pattern) *
+* circle : Kreis(segment) mit (radius, from, to, pattern) *
+* *
+* where : Gibt die aktuelle Stiftposition (x, y, [z]) *
+* *
+* get cursor : Graphische Eingabe *
+* *
+* *
+****************************************************************************)
+
+ transform,
+ set values,
+ get values,
+ new values,
+ drawing area,
+
+ window,
+ viewport,
+ view,
+ oblique,
+ orthographic,
+ perspective,
+
+ box,
+ reset,
+ hidden lines,
+
+ move,
+ draw,
+ move r,
+ draw r,
+ move cm,
+ draw cm,
+ move cm r,
+ draw cm r,
+ bar,
+ circle,
+
+ where:
+
+BOOL VAR new limits :: TRUE, values new :: TRUE,
+ perspective projektion :: FALSE;
+INT VAR pixel hor, pixel vert;
+REAL VAR display hor, display vert, (* Anzahl der Pixel *)
+ size hor, size vert; (* Groesse des Bildschirms *)
+drawing area (size hor, size vert, pixel hor, pixel vert);
+display hor := real (pixel hor); display vert := real (pixel vert);
+
+REAL VAR h min limit :: 0.0, h max limit :: display hor,
+ v min limit :: 0.0, v max limit :: display vert,
+ h min :: 0.0, h max :: size hor,
+ v min :: 0.0, v max :: size vert,
+ hor relation :: display hor/size hor,
+ vert relation :: display vert/size vert,
+ relation :: size hor/size vert;
+
+ROW 5 ROW 5 REAL VAR p :: ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (1.0, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 1.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0));
+
+ROW 3 ROW 2 REAL VAR size d :: ROW 3 ROW 2 REAL :
+ (ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0)),
+ last size :: size d;
+ROW 2 ROW 2 REAL VAR limits d :: ROW 2 ROW 2 REAL :
+ (ROW 2 REAL : (0.0, relation),
+ ROW 2 REAL : (0.0, 1.0));
+ROW 4 REAL VAR angles d :: ROW 4 REAL : (0.0, 0.0, 0.0, 0.0);
+ROW 2 REAL VAR oblique d :: ROW 2 REAL : (0.0, 0.0);
+ROW 3 REAL VAR perspective d :: ROW 3 REAL : (0.0, 0.0, 0.0);
+REAL VAR size hor d := size hor, size vert d := size vert;
+INT VAR pixel hor d := pixel hor, pixel vert d := pixel vert;
+
+INT VAR i, j, k;
+
+BOOL OP = (ROW 3 ROW 2 REAL CONST l, r):
+ FOR i FROM 1 UPTO 3
+ REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2]
+ THEN LEAVE = WITH FALSE FI
+ PER;
+ TRUE
+END OP =;
+
+BOOL OP = (ROW 2 ROW 2 REAL CONST l, r):
+ FOR i FROM 1 UPTO 2
+ REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2]
+ THEN LEAVE = WITH FALSE FI
+ PER;
+ TRUE
+END OP =;
+
+BOOL OP = (ROW 2 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2]
+END OP =;
+
+BOOL OP = (ROW 3 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3]
+END OP =;
+
+BOOL OP = (ROW 4 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3] AND l [4] = r [4]
+END OP =;
+
+PROC oblique (REAL CONST a, b) :
+ set values (size d, limits d, angles d, ROW 2 REAL : (a, b), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC oblique;
+
+PROC orthographic :
+ set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC orthographic;
+
+PROC perspective (REAL CONST cx, cy, cz) :
+ set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (cx, cy, cz))
+END PROC perspective;
+
+PROC window (BOOL CONST dev) :
+ new limits := dev
+END PROC window;
+
+PROC window (REAL CONST x min, x max, y min, y max) :
+ window (x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (REAL CONST x min, x max, y min, y max, z min, z max) :
+ set values (ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max),
+ ROW 2 REAL : (y min, y max),
+ ROW 2 REAL : (z min, z max)),
+ limits d, angles d, oblique d, perspective d)
+END PROC window;
+
+PROC viewport (REAL CONST h min, h max, v min, v max) :
+ set values (size d, ROW 2 ROW 2 REAL : (ROW 2 REAL : (h min, h max),
+ ROW 2 REAL : (v min, v max)),
+ angles d, oblique d, perspective d)
+END PROC view port;
+
+PROC view (REAL CONST alpha) :
+ set values (size d, limits d, ROW 4 REAL : (alpha, angles d(2), angles d (3), angles d (4)),
+ oblique d, perspective d)
+END PROC view;
+
+PROC view (REAL CONST phi, theta) :
+ set values (size d, limits d, ROW 4 REAL : (angles d(1), sind (theta) * cosd (phi),
+ sind (theta) * sind (phi), cosd (theta)),
+ oblique d, perspective d)
+END PROC view;
+
+PROC view (REAL CONST x, y, z) :
+ set values (size d, limits d, ROW 4 REAL : (angles d (1), x, y, z), oblique d, perspective d)
+END PROC view;
+
+set values (size d, limits d, angles d, oblique d, perspective d);
+
+PROC drawing area (REAL VAR min h, max h, min v, max v):
+ min h := h min limit; max h := h max limit;
+ min v := v min limit; max v := v max limit
+END PROC drawing area;
+
+BOOL PROC new values:
+ IF values new
+ THEN values new := FALSE;
+ TRUE
+ ELSE FALSE FI
+END PROC new values;
+
+PROC get values (ROW 3 ROW 2 REAL VAR size,
+ ROW 2 ROW 2 REAL VAR limits,
+ ROW 4 REAL VAR angles,
+ ROW 2 REAL VAR oblique,
+ ROW 3 REAL VAR perspective) :
+ size := size d;
+ limits := limits d;
+ angles := angles d;
+ oblique := oblique d;
+ perspective := perspective d;
+
+END PROC get values;
+
+PROC set values (ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 4 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ drawing area (size hor, size vert, pixel hor, pixel vert);
+ display hor := real (pixel hor); display vert := real (pixel vert);
+ IF NOT same values
+ THEN values new := TRUE;
+ copy values;
+ set views;
+ check perspective projektion;
+ calc limits;
+ change projektion
+ FI .
+
+same values:
+ size hor d = size hor AND size vert d = size vert AND
+ pixel hor d = pixel hor AND pixel vert d = pixel vert AND
+ size d = size AND limits d = limits AND angles d = angles AND
+ oblique d = oblique AND perspective d = perspective .
+
+copy values :
+ size hor d := size hor;
+ size vert d := size vert;
+ pixel hor d := pixel hor;
+ pixel vert d := pixel vert;
+ size d := size;
+ limits d := limits;
+ angles d := angles;
+ oblique d := oblique;
+ perspective d := perspective .
+
+set views :
+ REAL VAR diagonale := sqrt (angles [2] * angles [2] +
+ angles [3] * angles [3] +
+ angles [4] * angles [4]),
+ projektion := sqrt (angles [2] * angles [2] +
+ angles [4] * angles [4]),
+ sin p, cos p, sin t, cos t, sin a, cos a;
+
+ IF diagonale = 0.0
+ THEN sin p := 0.0; cos p := 1.0;
+ sin t := 0.0; cos t := 1.0
+ ELIF projektion = 0.0
+ THEN sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := 0.0; cos t := 1.0
+ ELSE sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := angles [2] / projektion;
+ cos t := angles [4] / projektion
+ FI;
+
+ REAL VAR sin p sin t := sin p * sin t,
+ sin p cos t := sin p * cos t,
+ cos p sin t := cos p * sin t,
+ cos p cos t := cos p * cos t,
+
+ dx := size [1][2] - size [1][1],
+ dy := size [2][2] - size [2][1],
+ dz := size [3][2] - size [3][1],
+ norm az := oblique [1] ,
+ norm bz := oblique [2] ,
+ norm cx := perspective [1] / dx,
+ norm cy := perspective [2] / dy,
+ norm cz := perspective [3] / dz,
+ xx := - size [1][1] / dx * cos p sin t -
+ size [2][1] / dy * sin p +
+ size [3][1] / dz * cos p cos t;
+
+p := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( cos t / dx - cos p sin t / dx * norm az ,
+ - sin p sin t / dx - cos p sin t / dx * norm bz,
+ 0.0,
+ - cos p sin t / dx * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( - sin p / dy * norm az,
+ cos p / dy - sin p / dy * norm bz,
+ 0.0,
+ - sin p / dy * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( sin t / dz + cos p cos t / dz * norm az,
+ + sin p cos t / dz + cos p cos t / dz * norm bz,
+ 0.0,
+ cos p cos t / dz * norm cz,
+ 0.0 ),
+ ROW 5 REAL : (- norm cx, - norm cy, 0.0, 1.0, 0.0 ),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0));
+
+ IF angles (1) = 0.0
+ THEN set alpha as y vertical
+ ELSE sin a := sind (angles (1));
+ cos a := cosd (angles (1))
+ FI;
+
+ FOR j FROM 1 UPTO 5
+ REP REAL CONST p j 1 := p (j)(1);
+ p (j)(1) := p j 1 * cos a - p (j)(2) * sin a;
+ p (j)(2) := p j 1 * sin a + p (j)(2) * cos a
+ PER .
+
+set alpha as y vertical :
+ REAL VAR r := sqrt (p(2)(1)**2 + p(2)(2)**2);
+ IF r = 0.0
+ THEN sin a := 0.0;
+ cos a := 1.0
+ ELSE sin a :=-p(2)(1)/r;
+ cos a := p(2)(2)/r
+ FI .
+
+check perspective projektion:
+ perspective projektion := perspective [3] <> 0.0 .
+
+calc limits :
+ IF new limits
+ THEN calc two dim extrema;
+ IF all limits smaller than 2
+ THEN prozente
+ ELSE zentimeter FI
+ FI .
+
+calc two dim extrema :
+ h min := max real; h max :=-max real;
+ v min := max real; v max :=-max real;
+
+ extrema (size [1][1], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][2], h min, h max, v min, v max) .
+
+all limits smaller than 2 :
+ limits (1)(2) < 2.0 AND limits (2)(2) < 2.0 .
+
+prozente :
+ h min limit := display hor * limits (1)(1)/relation;
+ h max limit := display hor * limits (1)(2)/relation;
+
+ v min limit := limits (2)(1) * display vert;
+ v max limit := limits (2)(2) * display vert .
+
+zentimeter :
+ h min limit := display hor * (limits (1)(1)/size hor);
+ h max limit := display hor * (limits (1)(2)/size hor);
+
+ v min limit := display vert * (limits (2)(1)/size vert);
+ v max limit := display vert * (limits (2)(2)/size vert) .
+
+change projektion :
+ REAL VAR sh := (h max limit - h min limit) / (h max - h min),
+ sv := (v max limit - v min limit) / (v max - v min),
+ dh := h min limit - h min*sh,
+ dv := v min limit - v min*sv;
+
+ FOR j FROM 1 UPTO 5
+ REP
+ p (j)(1) := p (j)(1) * sh;
+ p (j)(2) := p (j)(2) * sv
+ PER;
+ p (5)(1) := dh;
+ p (5)(2) := dv.
+END PROC set values;
+
+PROC transform (REAL CONST x, y, z, INT VAR h, v) :
+ disable stop;
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := int ((x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (4)(1))*w + p (5)(1));
+ v := int ((x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (4)(2))*w + p (5)(2))
+ ELSE h := int (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (5)(1));
+ v := int (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (5)(2));
+ FI;
+ IF is error
+ THEN h := -1;
+ v := -1;
+ clear error
+ FI
+END PROC transform;
+
+PROC extrema (REAL CONST x, y, z, REAL VAR h min, h max, v min, v max):
+ REAL VAR h, v;
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) +p (4)(1))*w;
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) +p (4)(2))*w
+ ELSE h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1));
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2))
+ FI;
+
+ IF h < h min
+ THEN h min := h
+ ELIF h > h max
+ THEN h max := h FI;
+
+ IF v < v min
+ THEN v min := v
+ ELIF v > v max
+ THEN v max := v FI
+
+END PROC extrema;
+
+(**************************** Plot Prozeduren ****************************)
+LET empty = 0, {Punktmuster}
+ half = 1,
+ full = 2,
+ horizontal = 3,
+ vertical = 4,
+ cross = 5,
+ diagonal right = 6,
+ diagonal left = 7,
+ diagonal both = 8;
+
+LET POS = STRUCT (REAL x, y, z);
+POS VAR pos :: POS : (0.0, 0.0, 0.0);
+INT VAR h :: 0, v :: 0, new h :: 0, new v :: 0;
+BOOL VAR hidden :: FALSE;
+DATASPACE VAR ds :: nilspace;
+BOUND STRUCT (ROW 32764 INT akt, last) VAR maxima :: ds;
+
+
+PROC box :
+ move (int (h min limit+0.5), int (v min limit+0.5));
+ draw (int (h max limit+0.5), int (v min limit+0.5));
+ draw (int (h max limit+0.5), int (v max limit+0.5));
+ draw (int (h min limit+0.5), int (v max limit+0.5));
+ draw (int (h min limit+0.5), int (v min limit+0.5))
+END PROC box;
+
+PROC reset:
+ forget (ds);
+ ds := nilspace;
+ maxima := ds
+END PROC reset;
+
+PROC move (REAL CONST x, y) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (x, y, 0.0, h, v);
+ move (h, v);
+ pos := POS : (x, y, 0.0)
+END PROC move;
+
+PROC move (REAL CONST x, y, z) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (x, y, z, h, v);
+ move (h, v);
+ pos := POS : (x, y, z)
+END PROC move;
+
+PROC draw (REAL CONST x, y) :
+ IF hidden
+ THEN transform (x, y, 0.0, new h, new v);
+ vector (new h-h, new v-v)
+ ELSE transform (x, y, 0.0, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (x, y, 0.0)
+END PROC draw;
+
+PROC draw (REAL CONST x, y, z) :
+ IF hidden
+ THEN transform (x, y, z, new h, new v);
+ vector (new h-h, new v-v)
+ ELSE transform (x, y, z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (x, y, z)
+END PROC draw;
+
+PROC move r (REAL CONST x, y) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (pos.x+x, pos.y+y, pos.z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC move r;
+
+PROC move r (REAL CONST x, y, z) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC move r;
+
+PROC draw r (REAL CONST x, y) :
+ IF hidden
+ THEN transform (pos.x+x, pos.y+y, pos.z, h, v);
+ vector (new h-h, new v-v)
+ ELSE transform (pos.x+x, pos.y+y, pos.z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC draw r;
+
+PROC draw r (REAL CONST x, y, z) :
+ IF hidden
+ THEN transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ vector (new h-h, new v-v)
+ ELSE transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC draw r;
+
+PROC move cm (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ h := int (x cm*hor relation+0.5);
+ v := int (y cm*vert relation+0.5);
+ move (h, v)
+END PROC move cm;
+
+PROC draw cm (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN vector (int (x cm*hor relation+0.5)-h, int (y cm*vert relation+0.5)-v)
+ ELSE h := int (x cm*hor relation+0.5);
+ v := int (y cm*vert relation+0.5);
+ draw (h, v)
+ FI
+END PROC draw cm;
+
+PROC move cm r (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ h INCR int (x cm*hor relation+0.5);
+ v INCR int (y cm*vert relation+0.5);
+ move (h, v)
+END PROC move cm r;
+
+PROC draw cm r (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN vector (int (x cm*hor relation+0.5), int (y cm*vert relation+0.5))
+ ELSE h INCR int (x cm*hor relation+0.5);
+ v INCR int (y cm*vert relation+0.5);
+ draw (h, v)
+ FI
+END PROC draw cm r;
+
+PROC hidden lines (BOOL CONST dev):
+ hidden := NOT dev;
+END PROC hidden lines;
+
+PROC vector (INT CONST dx, dy):
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (v, h, dy, dx, 1, 1)
+ ELIF dy > 0 THEN vector (h, v, dx, dy, 1, 1)
+
+ ELIF dy > -dx THEN vector (h, v, dx, -dy, 1,-1)
+ ELSE vector (v, h, -dy, dx,-1, 1) FI
+
+ ELSE IF dy > -dx THEN vector (v, h, dy, -dx, 1,-1)
+ ELIF dy > 0 THEN vector (h, v, -dx, dy,-1, 1)
+
+ ELIF dy > dx THEN vector (h, v, -dx, -dy,-1,-1)
+ ELSE vector (v, h, -dy, -dx,-1,-1) FI
+ FI .
+
+ENDPROC vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
+ INT VAR i;
+ prepare first step ;
+ draw point;
+ FOR i FROM 1 UPTO dx
+ REP do one step PER;
+
+ IF was visible
+ THEN draw (h, v) FI .
+
+
+prepare first step :
+ INT VAR up right error := dy - dx,
+ right error := dy,
+ old error := 0,
+ last h :: h, last v :: v;
+ BOOL VAR was visible :: visible .
+
+
+do one step:
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ draw point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ draw point ;
+ old error INCR right error .
+
+draw point :
+ IF was visible
+ THEN IF NOT visible
+ THEN draw (last h, last v);
+ was visible := FALSE
+ FI;
+ last h := h;
+ last v := v
+ ELSE IF visible
+ THEN move (h, v);
+ was visible := TRUE;
+ last h := h;
+ last v := v
+ FI
+ FI .
+
+visible:
+ IF h < 1 OR h > pixel hor
+ THEN FALSE
+ ELSE IF maxima.akt [h] < v
+ THEN maxima.akt [h] := v FI;
+ v > maxima.last [h]
+ FI
+END PROC vector;
+
+PROC where (REAL VAR x, y) :
+ x := pos.x; y := pos.y
+END PROC where;
+
+PROC where (REAL VAR x, y, z) :
+ x := pos.x; y := pos.y; z := pos.z
+END PROC where;
+
+PROC bar (REAL CONST hight, width, INT CONST pattern):
+ INT VAR zero x, zero y, end x, end y;
+ transform (0.0, 0.0, 0.0, zero x, zero y);
+ transform (width, hight, 0.0, end x, end y);
+ bar (h-(end x-zero x) DIV 2, v, end x-zero x, end y-zero y, pattern)
+END PROC bar;
+
+PROC bar (INT CONST from x, from y, width, hight, pattern):
+ INT CONST to x :: from x+width, to y :: from y+hight;
+ INT VAR x, y;
+ draw frame;
+ SELECT pattern OF
+ CASE empty: (* nothing to do *)
+ CASE half: half bar
+ CASE full: full bar
+ CASE horizontal: horizontal bar
+ CASE vertical: vertical bar
+ CASE cross: horizontal bar;
+ vertical bar
+ CASE diagonal right: diagonal right bar
+ CASE diagonal left: diagonal left bar
+ CASE diagonal both: diagonal both bar
+ OTHERWISE errorstop ("Unknown pattern") ENDSELECT .
+
+draw frame:
+ move (from x, from y);
+ draw (from x, to y);
+ draw (to x, to y);
+ draw (to x, from y) .
+
+full bar:
+ FOR y FROM from y UPTO to y
+ REP move (from x, y);
+ draw (to x, y)
+ PER .
+
+half bar:
+ FOR y FROM from y UPTO to y
+ REP x := from x + 1 + (y AND 1);
+ WHILE x < to x
+ REP move (x, y);
+ draw (x, y);
+ x INCR 2
+ PER
+ PER .
+
+horizontal bar:
+ y := from y;
+ WHILE y < to y
+ REP move (from x, y);
+ draw (to x, y);
+ y INCR 5
+ PER .
+
+vertical bar:
+ x := from x + 5;
+ WHILE x < to x
+ REP move (x, from y);
+ draw (x, to y);
+ x INCR 5
+ PER .
+
+diagonal right bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (max (from x, to x-y-width+from y), max (from y, y));
+ draw (min (to x, from x+to y-y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+diagonal left bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (min (to x, to x-from y+y), max (from y, y));
+ draw (max (from x, from x+y+width-to y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+diagonal both bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (max (from x, to x-y-width+from y), max (from y, y));
+ draw (min (to x, from x+to y-y), min (to y, y+width));
+ move (min (to x, to x-from y+y), max (from y, y));
+ draw (max (from x, from x+y+width-to y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+END PROC bar;
+
+PROC circle (REAL CONST r, from, to, INT CONST pattern):
+ REAL VAR t :: from;
+ WHILE t < to
+ REP transform (pos.x + r*cosd (t), pos.y + r*sind (t), 0.0, h, v);
+ draw (h, v);
+ t INCR 1.0
+ PER;
+ transform (pos.x, pos.y, 0.0, h, v);
+ draw (h, v) .
+
+END PROC circle;
+
+ENDPACKET basis plot;
diff --git a/app/mpg/1987/src/DIPCHIPS.DS b/app/mpg/1987/src/DIPCHIPS.DS Binary files differnew file mode 100644 index 0000000..2cdd8e9 --- /dev/null +++ b/app/mpg/1987/src/DIPCHIPS.DS diff --git a/app/mpg/1987/src/FUPLOT.ELA b/app/mpg/1987/src/FUPLOT.ELA new file mode 100644 index 0000000..1d0d247 --- /dev/null +++ b/app/mpg/1987/src/FUPLOT.ELA @@ -0,0 +1,319 @@ +PACKET fuplot DEFINES axis, (*Autor : H.Indenbirken *)
+ plot, (*Stand : 23.02.85 *)
+ cube:
+
+PICTURE VAR pic;
+TEXT VAR value text;
+
+PICTURE PROC cube (REAL CONST x min, x max, INT CONST no x,
+ REAL CONST y min, y max, INT CONST no y,
+ REAL CONST z min, z max, INT CONST no z):
+ cube (x min, x max, (x max-x min)/real (no x),
+ y min, y max, (y max-y min)/real (no y),
+ z min, z max, (z min-z max)/real (no z))
+END PROC cube;
+
+PICTURE PROC cube (REAL CONST x min, x max, dx, y min, y max, dy, z min, z max, dz):
+ pic := cube (x min, x max, y min, y max, z min, z max);
+ move (pic, x max, y min, z min); draw (pic, text (x max));
+ move (pic, x min, y max, z min); draw (pic, text (y max));
+ move (pic, x min, y min, z max); draw (pic, text (z max));
+
+ draw tabs (pic, x min, y min, z min, x max, y min, z min, dx, 0.0, 0.0);
+ draw tabs (pic, x min, y min, z min, x min, y max, z min, 0.0, dy, 0.0);
+ draw tabs (pic, x min, y min, z min, x min, y min, z max, 0.0, 0.0, dx);
+ pic
+END PROC cube;
+
+PICTURE PROC cube (REAL CONST x min, x max, y min, y max, z min, z max):
+ pic := nilpicture;
+ move (pic, x min, y min, z min);
+ draw (pic, x max, y min, z min);
+ draw (pic, x max, y max, z min);
+ draw (pic, x min, y max, z min);
+ draw (pic, x min, y min, z min);
+
+ move (pic, x min, y min, z max);
+ draw (pic, x max, y min, z max);
+ draw (pic, x max, y max, z max);
+ draw (pic, x min, y max, z max);
+ draw (pic, x min, y min, z max);
+
+ move (pic, x min, y min, z min);
+ draw (pic, x min, y min, z max);
+
+ move (pic, x max, y min, z min);
+ draw (pic, x max, y min, z max);
+
+ move (pic, x max, y max, z min);
+ draw (pic, x max, y max, z max);
+
+ move (pic, x min, y max, z min);
+ draw (pic, x min, y max, z max);
+ pic
+
+END PROC cube;
+
+PICTURE PROC axis (REAL CONST x min, x max, INT CONST no x,
+ REAL CONST y min, y max, INT CONST no y) :
+ axis (x min, x max, (x max-x min) / real (no x - 1),
+ y min, y max, (y max-y min) / real (no y - 1))
+END PROC axis;
+
+PICTURE PROC axis (REAL CONST x min, x max, dx, y min, y max, dy) :
+ REAL CONST x diff :: x max - x min,
+ y diff :: y max - y min;
+ pic := nilpicture;
+ calc axis pos;
+ IF dx > 0.0
+ THEN x axis FI;
+ IF dy > 0.0
+ THEN y axis FI;
+ pic .
+
+calc axis pos :
+ REAL VAR x0, y0;
+ IF x min < 0.0 AND x max < 0.0
+ THEN y0 := y max
+ ELIF x min > 0.0 AND x max > 0.0
+ THEN y0 := y max
+ ELSE y0 := 0.0 FI;
+
+ IF y min < 0.0 AND y max < 0.0
+ THEN x0 := x max
+ ELIF y min > 0.0 AND y max > 0.0
+ THEN x0 := x max
+ ELSE x0 := 0.0 FI .
+
+x axis :
+ move (pic, x max, y0);
+ move cm r (pic, 0.1, -0.3);
+ draw (pic, "X");
+
+ draw tabs (pic, x0,y0, x max,y0, dx,0.0);
+ value text := text (x max);
+ draw (pic, (length (value text) DIV 2) * ""8"" + ""10"" + value text);
+
+ draw tabs (pic, x0,y0, x min,y0,-dx,0.0);
+ value text := text (x min);
+ draw (pic, (length (value text) DIV 2) * ""8"" + ""10"" + value text) .
+
+y axis :
+ move (pic, x0, y max);
+ move cm r (pic, -0.18, 0.1);
+ draw (pic, "Y");
+
+ draw tabs (pic, x0,y0, x0,y max, 0.0, dy);
+ value text := text (y max);
+ draw (pic, length (value text) * ""8"" + value text);
+
+ draw tabs (pic, x0,y0, x0,y min, 0.0,-dy);
+ value text := text (y min);
+ draw (pic, length (value text) * ""8"" + value text) .
+
+END PROC axis;
+
+PROC draw tabs (PICTURE VAR pic, REAL CONST x0,y0, x1,y1, dx,dy) :
+ move (pic, x0, y0);
+ draw (pic, x1, y1);
+
+ REAL VAR x :: x0, y :: y0;
+ INT VAR i :: 0;
+ WHILE abs (x) <= abs (x1) AND abs (y) <= abs (y1)
+ REP move (pic, x, y);
+ IF dx <> 0.0
+ THEN draw cm r (pic, 0.0, size)
+ ELIF dy <> 0.0
+ THEN draw cm r (pic, size, 0.0) FI;
+ i INCR 1;
+ x INCR dx; y INCR dy
+ PER .
+
+size:
+ IF i MOD 10 = 0
+ THEN -0.75
+ ELIF i MOD 5 = 0
+ THEN -0.5
+ ELSE -0.3 FI .
+
+END PROC draw tabs;
+
+PICTURE PROC axis (REAL CONST x min, x max, INT CONST no x,
+ REAL CONST y min, y max, INT CONST no y,
+ REAL CONST z min, z max, INT CONST no z) :
+ axis (x min, x max, (x max-x min) / real (no x - 1),
+ y min, y max, (y max-y min) / real (no y - 1),
+ z min, z max, (z max-z min) / real (no z - 1))
+END PROC axis;
+
+PICTURE PROC axis (REAL CONST x min, x max, dx,
+ y min, y max, dy,
+ z min, z max, dz) :
+ REAL CONST x diff :: x max - x min,
+ y diff :: y max - y min,
+ z diff :: z max - z min;
+ pic := nilpicture;
+ calc axis pos;
+ IF dx > 0.0
+ THEN x axis FI;
+ IF dy > 0.0
+ THEN y axis FI;
+ IF dz > 0.0
+ THEN z axis FI;
+ pic .
+
+calc axis pos :
+ REAL VAR x0, y0, z0;
+ IF x min < 0.0 AND x max < 0.0
+ THEN y0 := y max
+ ELIF x min > 0.0 AND x max > 0.0
+ THEN y0 := y max
+ ELSE y0 := 0.0 FI;
+
+ IF y min < 0.0 AND y max < 0.0
+ THEN x0 := x max
+ ELIF y min > 0.0 AND y max > 0.0
+ THEN x0 := x max
+ ELSE x0 := 0.0 FI;
+
+ IF z min < 0.0 AND z max < 0.0
+ THEN z0 := z max
+ ELIF z min > 0.0 AND z max > 0.0
+ THEN z0 := z max
+ ELSE z0 := 0.0 FI .
+
+x axis :
+ move (pic, x max, y0, z0);
+ move cm r (pic, 0.1, -0.3);
+ draw (pic, "X");
+
+ draw tabs (pic, x0,y0,z0, x max,y0,z0, dx,0.0,0.0);
+ value text := text (x max);
+ draw (pic, (length (value text) DIV 2) * ""8"" + ""10"" + value text);
+
+ draw tabs (pic, x0,y0,z0, x min,y0,z0,-dx,0.0,0.0);
+ value text := text (x min);
+ draw (pic, (length (value text) DIV 2) * ""8"" + ""10"" + value text) .
+
+y axis :
+ move (pic, x0, y max, z0);
+ move cm r (pic, -0.18, -0.1);
+ draw (pic, "Y");
+
+ draw tabs (pic, x0,y0,z0, x0,y max,z0, 0.0, dy,0.0);
+ value text := text (y max);
+ draw (pic, length (value text) * ""8"" + value text);
+
+ draw tabs (pic, x0,y0,z0, x0,y min,z0, 0.0,-dy,0.0);
+ value text := text (y min);
+ draw (pic, length (value text) * ""8"" + value text) .
+
+z axis :
+ move (pic, x0, y0, z max);
+ move cm r (pic, 0.1, -0.3);
+ draw (pic, "Z");
+
+ draw tabs (pic, x0,y0,z0, x0,y0,z max, 0.0,0.0, dz);
+ value text := text (z max);
+ draw (pic, (length (value text) DIV 2) * ""8"" + ""10"" + value text);
+
+ draw tabs (pic, x0,y0,z0, x0,y0,z min, 0.0,0.0,-dz);
+ value text := text (z min);
+ draw (pic, (length (value text) DIV 2) * ""8"" + ""10"" + value text) .
+
+END PROC axis;
+
+PROC draw tabs (PICTURE VAR pic, REAL CONST x0,y0,z0, x1,y1,z1, dx,dy,dz) :
+ move (pic, x0, y0, z0);
+ draw (pic, x1, y1, z1);
+
+ REAL VAR x :: x0, y :: y0, z :: z0;
+ INT VAR i :: 0;
+ WHILE abs (x) <= abs (x1) AND abs (y) <= abs (y1) AND abs (z) <= abs (z1)
+ REP move (pic, x, y, z);
+ IF dx <> 0.0
+ THEN draw cm r (pic, 0.0, size);
+ ELIF dy <> 0.0
+ THEN draw cm r (pic, size, 0.0);
+ ELIF dz <> 0.0
+ THEN draw cm r (pic, 0.0, size) FI;
+ i INCR 1;
+ x INCR dx; y INCR dy; z INCR dz
+ PER .
+
+size:
+ IF i MOD 10 = 0
+ THEN -0.75
+ ELIF i MOD 5 = 0
+ THEN -0.5
+ ELSE -0.3 FI .
+
+END PROC draw tabs;
+
+PROC plot (PICFILE VAR p, REAL PROC (REAL CONST, REAL CONST) f,
+ REAL CONST x min, x max, INT CONST pixel x,
+ REAL CONST z min, z max, INT CONST pixel z) :
+ plot (p, PROC f, 1, x min, x max, (x max-x min) / real (pixel x),
+ z min, z max, (z max-z min) / real (pixel z))
+END PROC plot;
+
+PROC plot (PICFILE VAR p, REAL PROC (REAL CONST, REAL CONST) f, INT CONST pen,
+ REAL CONST x min, x max, INT CONST pixel x,
+ REAL CONST z min, z max, INT CONST pixel z) :
+ plot (p, PROC f, pen, x min, x max, (x max-x min) / real (pixel x),
+ z min, z max, (z max-z min) / real (pixel z))
+END PROC plot;
+
+PROC plot (PICFILE VAR p, REAL PROC (REAL CONST, REAL CONST) f,
+ REAL CONST x min, x max, dx,
+ REAL CONST z min, z max, dz) :
+ plot (p, PROC f, 1, x min, x max, dx, z min, z max, dz)
+END PROC plot;
+
+PROC plot (PICFILE VAR p, REAL PROC (REAL CONST, REAL CONST) f, INT CONST n,
+ REAL CONST x min, x max, dx,
+ REAL CONST z min, z max, dz) :
+ REAL VAR z := z min;
+ line;
+ WHILE z <= z max
+ REP out (""13""5"Ebene: " + text (z));
+ pic := plot (PROC f, x min, x max, dx, z);
+ pen (pic, n);
+ put picture (p, pic);
+ z INCR dz
+ PER .
+
+END PROC plot;
+
+PICTURE PROC plot (REAL PROC (REAL CONST, REAL CONST) f,
+ REAL CONST x min, x max, dx, z):
+ pic := nilpicture;
+ REAL VAR x := x min;
+ move (pic, x, f (x, z), z);
+ WHILE x < x max
+ REP x INCR dx;
+ draw (pic, x, f (x, z), z);
+ PER;
+ draw (pic, x, f (x, z), z);
+ pic .
+
+END PROC plot;
+
+PICTURE PROC plot (REAL PROC (REAL CONST) f,
+ REAL CONST x min, x max, INT CONST pixel) :
+ plot (PROC f, x min, x max, (x max-x min) / real (pixel))
+END PROC plot;
+
+PICTURE PROC plot (REAL PROC (REAL CONST) f, REAL CONST x min, x max, dx) :
+ PICTURE VAR pic :: nilpicture;
+ REAL VAR x := x min;
+ move (pic, x, f (x));
+ WHILE x < x max
+ REP x INCR dx;
+ draw (pic, x, f (x));
+ PER;
+ draw (pic, x, f (x));
+ pic
+END PROC plot;
+
+END PACKET fuplot
diff --git a/app/mpg/1987/src/GRAPHIK.Basis b/app/mpg/1987/src/GRAPHIK.Basis new file mode 100644 index 0000000..62cb790 --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.Basis @@ -0,0 +1,1573 @@ +(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.2 vom 23.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Basis" geschrieben von C.Weinholz/EUMEL-Std *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Paket I: Endgeraet-unabhaengige Graphikroutinen *)
+(* *)
+(* 1. Transformation (Umsetzung 3D -> 2D), *)
+(* Clipping und Normierung *)
+(* 2. PICTURE - Verwaltung *)
+(* (geanderte Standard-Version) *)
+(* 3. PICFILE - Verwaltung *)
+(* (geanderte Standard-Version) *)
+(* 4. Endgeraet - Verwaltung *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* OP := (PICFILE VAR, PICFILE CONST) hinzugefuegt *)
+(* TEXT PROC text (PICTURE CONST) *)
+(* wg. Heapueberlauf geaendert *)
+(* *)
+(**************************************************************************)
+
+(****************************** transformation ****************************)
+
+PACKET transformation DEFINES
+ transform,
+ set values,
+ get values,
+ new values,
+ drawing area,
+ set drawing area,
+
+ window,
+ viewport,
+ view,
+ oblique,
+ orthographic,
+ perspective,
+
+ clipped line:
+
+BOOL VAR new limits :: TRUE,
+ values new :: TRUE,
+ perspective projektion :: FALSE;
+
+REAL VAR display hor, display vert, (* Anzahl der Pixel *)
+ size hor, size vert, (* Groesse des Bildschirms *)
+ size hor d, size vert d,
+ h min limit, h max limit,
+ v min limit, v max limit,
+ h min, h max,
+ v min, v max,
+ relation;
+
+ROW 5 ROW 5 REAL VAR p ;
+ROW 3 ROW 2 REAL VAR size d ;
+ROW 2 ROW 2 REAL VAR limits d ;
+ROW 4 REAL VAR angles d ;
+ROW 2 REAL VAR oblique d ;
+ROW 3 REAL VAR perspective d ;
+
+INT VAR i, j;
+
+PROC init transformation rows:
+ size d := ROW 3 ROW 2 REAL : (ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0));
+
+ limits d := ROW 2 ROW 2 REAL : (ROW 2 REAL : (0.0, relation),
+ ROW 2 REAL : (0.0, 1.0));
+
+ angles d := ROW 4 REAL : (0.0, 0.0, 0.0, 0.0);
+
+ oblique d := ROW 2 REAL : (0.0, 0.0);
+
+ perspective d := ROW 3 REAL : (0.0, 0.0, 0.0);
+ set values (size d, limits d, angles d, oblique d, perspective d);
+END PROC init transformation rows;
+
+BOOL OP = (ROW 3 ROW 2 REAL CONST l, r):
+ FOR i FROM 1 UPTO 3
+ REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2]
+ THEN LEAVE = WITH FALSE FI
+ PER;
+ TRUE
+END OP =;
+
+BOOL OP = (ROW 2 ROW 2 REAL CONST l, r):
+ FOR i FROM 1 UPTO 2
+ REP IF l [i][1] <> r [i][1] OR l [i][2] <> r [i][2]
+ THEN LEAVE = WITH FALSE FI
+ PER;
+ TRUE
+END OP =;
+
+BOOL OP = (ROW 2 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2]
+END OP =;
+
+BOOL OP = (ROW 3 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3]
+END OP =;
+
+BOOL OP = (ROW 4 REAL CONST l, r):
+ l [1] = r [1] AND l [2] = r [2] AND l [3] = r [3] AND l [4] = r [4]
+END OP =;
+
+PROC oblique (REAL CONST a, b) :
+ set values (size d, limits d, angles d, ROW 2 REAL : (a, b), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC oblique;
+
+PROC orthographic :
+ set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (0.0, 0.0, 0.0))
+END PROC orthographic;
+
+PROC perspective (REAL CONST cx, cy, cz) :
+ set values (size d, limits d, angles d, ROW 2 REAL : (0.0, 0.0), ROW 3 REAL : (cx, cy,-cz))
+END PROC perspective;
+
+PROC window (BOOL CONST dev) :
+ new limits := dev
+END PROC window;
+
+PROC window (REAL CONST x min, x max, y min, y max) :
+ window (x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (REAL CONST x min, x max, y min, y max, z min, z max) :
+ set values (ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max),
+ ROW 2 REAL : (y min, y max),
+ ROW 2 REAL : (z min, z max)),
+ limits d, angles d, oblique d, perspective d)
+END PROC window;
+
+PROC viewport (REAL CONST h min, h max, v min, v max) :
+ set values (size d, ROW 2 ROW 2 REAL : (ROW 2 REAL : (h min, h max),
+ ROW 2 REAL : (v min, v max)),
+ angles d, oblique d, perspective d)
+END PROC view port;
+
+PROC view (REAL CONST alpha) :
+ set values (size d, limits d, ROW 4 REAL : (alpha, angles d(2), angles d (3), angles d (4)),
+ oblique d, perspective d)
+END PROC view;
+
+PROC view (REAL CONST phi, theta) :
+ set values (size d, limits d, ROW 4 REAL : (angles d(1), sind (theta) * cosd (phi),
+ sind (theta) * sind (phi), cosd (theta)),
+ oblique d, perspective d)
+END PROC view;
+
+PROC view (REAL CONST x, y, z) :
+ set values (size d, limits d, ROW 4 REAL : (angles d (1), x, y, z), oblique d, perspective d)
+END PROC view;
+
+PROC drawing area (REAL VAR min h, max h, min v, max v):
+ min h := h min limit; max h := h max limit;
+ min v := v min limit; max v := v max limit
+END PROC drawing area;
+
+PROC set drawing area (REAL CONST new size hor,new size vert,
+ new display hor,new display vert):
+ size hor := new size hor;
+ size vert:= new size vert;
+ display hor := new display hor;
+ display vert:= new display vert;
+ relation := size hor/size vert;
+ new limits := TRUE;
+ init transformation rows
+END PROC set drawing area;
+
+BOOL PROC new values:
+ IF values new
+ THEN values new := FALSE;
+ TRUE
+ ELSE FALSE FI
+END PROC new values;
+
+PROC get values (ROW 3 ROW 2 REAL VAR size,
+ ROW 2 ROW 2 REAL VAR limits,
+ ROW 4 REAL VAR angles,
+ ROW 2 REAL VAR oblique,
+ ROW 3 REAL VAR perspective) :
+ size := size d;
+ limits := limits d;
+ angles := angles d;
+ oblique := oblique d;
+ perspective := perspective d;
+
+END PROC get values;
+
+PROC set values (ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 4 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ IF NOT same values
+ THEN values new := TRUE;
+ copy values;
+ set views;
+ check perspective projektion;
+ calc limits;
+ change projektion
+ FI .
+
+same values:
+ size hor d = size hor AND size vert d = size vert AND
+ size d = size AND limits d = limits AND angles d = angles AND
+ oblique d = oblique AND perspective d = perspective .
+
+copy values :
+ size hor d := size hor;
+ size vert d := size vert;
+ size d := size;
+ limits d := limits;
+ angles d := angles;
+ oblique d := oblique;
+ perspective d := perspective .
+
+set views :
+ REAL VAR diagonale := sqrt (angles [2] * angles [2] +
+ angles [3] * angles [3] +
+ angles [4] * angles [4]),
+ projektion := sqrt (angles [2] * angles [2] +
+ angles [4] * angles [4]),
+ sin p, cos p, sin t, cos t, sin a, cos a;
+
+ IF diagonale = 0.0
+ THEN sin p := 0.0; cos p := 1.0;
+ sin t := 0.0; cos t := 1.0
+ ELIF projektion = 0.0
+ THEN sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := 0.0; cos t := 1.0
+ ELSE sin p := angles [3] / diagonale;
+ cos p := projektion / diagonale;
+ sin t := angles [2] / projektion;
+ cos t := angles [4] / projektion
+ FI;
+
+ REAL VAR sin p sin t := sin p * sin t,
+ sin p cos t := sin p * cos t,
+ cos p sin t := cos p * sin t,
+ cos p cos t := cos p * cos t,
+
+ dx := size [1][2] - size [1][1],
+ dy := size [2][2] - size [2][1],
+ dz := size [3][2] - size [3][1],
+ norm az := oblique [1] ,
+ norm bz := oblique [2] ,
+ norm cx := perspective [1] / dx,
+ norm cy := perspective [2] / dy,
+ norm cz := perspective [3] / dz;
+
+p := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( cos t / dx - cos p sin t / dx * norm az ,
+ - sin p sin t / dx - cos p sin t / dx * norm bz,
+ 0.0,
+ - cos p sin t / dx * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( - sin p / dy * norm az,
+ cos p / dy - sin p / dy * norm bz,
+ 0.0,
+ - sin p / dy * norm cz,
+ 0.0 ),
+ ROW 5 REAL : ( sin t / dz + cos p cos t / dz * norm az,
+ + sin p cos t / dz + cos p cos t / dz * norm bz,
+ 0.0,
+ cos p cos t / dz * norm cz,
+ 0.0 ),
+ ROW 5 REAL : (- norm cx, - norm cy, 0.0, 1.0, 0.0 ),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0));
+
+ IF angles (1) = 0.0
+ THEN set alpha as y vertical
+ ELSE sin a := sind (angles (1));
+ cos a := cosd (angles (1))
+ FI;
+
+ FOR j FROM 1 UPTO 5
+ REP REAL CONST p j 1 := p (j)(1);
+ p (j)(1) := p j 1 * cos a - p (j)(2) * sin a;
+ p (j)(2) := p j 1 * sin a + p (j)(2) * cos a
+ PER .
+
+set alpha as y vertical :
+ REAL VAR r := sqrt (p(2)(1)**2 + p(2)(2)**2);
+ IF r = 0.0
+ THEN sin a := 0.0;
+ cos a := 1.0
+ ELSE sin a :=-p(2)(1)/r;
+ cos a := p(2)(2)/r
+ FI .
+
+check perspective projektion:
+ perspective projektion := perspective [3] <> 0.0 .
+
+calc limits :
+ IF new limits
+ THEN calc two dim extrema;
+ IF all limits smaller than 2
+ THEN prozente
+ ELSE zentimeter FI
+ FI .
+
+calc two dim extrema :
+ h min := max real; h max :=-max real;
+ v min := max real; v max :=-max real;
+
+ extrema (size [1][1], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][1], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][1], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][2], size [2][2], size [3][2], h min, h max, v min, v max);
+ extrema (size [1][1], size [2][2], size [3][2], h min, h max, v min, v max) .
+
+all limits smaller than 2 :
+ limits (1)(2) < 2.0 AND limits (2)(2) < 2.0 .
+
+prozente :
+ h min limit := display hor * limits (1)(1)/relation;
+ h max limit := display hor * limits (1)(2)/relation;
+
+ v min limit := limits (2)(1) * display vert;
+ v max limit := limits (2)(2) * display vert .
+
+zentimeter :
+ h min limit := display hor * (limits (1)(1)/size hor);
+ h max limit := display hor * (limits (1)(2)/size hor);
+
+ v min limit := display vert * (limits (2)(1)/size vert);
+ v max limit := display vert * (limits (2)(2)/size vert) .
+
+change projektion :
+ REAL VAR sh := (h max limit - h min limit) / (h max - h min),
+ sv := (v max limit - v min limit) / (v max - v min),
+ dh := h min limit - h min*sh,
+ dv := v min limit - v min*sv;
+
+ FOR j FROM 1 UPTO 5
+ REP
+ p (j)(1) := p (j)(1) * sh;
+ p (j)(2) := p (j)(2) * sv
+ PER;
+ p (5)(1) := dh;
+ p (5)(2) := dv.
+END PROC set values;
+
+PROC transform (REAL CONST x, y, z, INT VAR h, v) :
+ disable stop;
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := int ((x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (4)(1))*w + p (5)(1));
+ v := int ((x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (4)(2))*w + p (5)(2))
+ ELSE h := int (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) + p (5)(1));
+ v := int (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) + p (5)(2));
+ FI;
+ IF is error
+ THEN h := -1;
+ v := -1;
+ clear error
+ FI
+END PROC transform;
+
+PROC extrema (REAL CONST x, y, z, REAL VAR h min, h max, v min, v max):
+ REAL VAR h, v;
+ IF perspective projektion
+ THEN REAL CONST w :: 1.0/(x*p (1)(4) + y*p (2)(4) + z*p (3)(4) + 1.0);
+ h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1) +p (4)(1))*w;
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2) +p (4)(2))*w
+ ELSE h := (x*p (1)(1)+y*p (2)(1)+z*p (3)(1));
+ v := (x*p (1)(2)+y*p (2)(2)+z*p (3)(2))
+ FI;
+
+ IF h < h min
+ THEN h min := h
+ ELIF h > h max
+ THEN h max := h FI;
+
+ IF v < v min
+ THEN v min := v
+ ELIF v > v max
+ THEN v max := v FI
+
+END PROC extrema;
+
+BOOL PROC clipped line (REAL VAR x0,y0,x1,y1):
+ REAL VAR dx :: (display hor - 1.0) / 2.0,
+ dy :: (display vert- 1.0) / 2.0,
+ rx0 :: x0 - dx,
+ ry0 :: y0 - dy,
+ rx1 :: x1 - dx,
+ ry1 :: y1 - dy;
+ INT VAR cx0,
+ cy0,
+ cx1,
+ cy1;
+ calculate cells;
+ IF (cx0*cx1 = 1) OR (cy0 * cy1 = 1)
+ THEN FALSE
+ ELIF (x0 = x1) AND (y0 = y1)
+ THEN cx0 = 0 AND cy0 = 0
+ ELSE do clipping
+ FI.
+
+ do clipping:
+ IF cx0 <> 0
+ THEN REAL VAR next x :: real(cx0) * dx;
+ ry0 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx0) + ry0;
+ rx0 := next x
+ FI;
+ calculate cells;
+ IF cy0 <> 0
+ THEN REAL VAR next y :: real(cy0) * dy;
+ rx0 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry0) + rx0;
+ ry0 := next y
+ FI;
+ IF cx1 <> 0
+ THEN next x := real(cx1) * dx;
+ ry1 := (ry1 - ry0) / (rx1 - rx0) * (next x - rx1) + ry1;
+ rx1 := next x
+ FI;
+ calculate cells;
+ IF cy1 <> 0
+ THEN next y := real(cy1) * dy;
+ rx1 := (rx1 - rx0) / (ry1 - ry0) * (next y - ry1) + rx1;
+ ry1 := next y
+ FI;
+ IF (rx1 = rx0) AND (ry1 = ry0)
+ THEN FALSE
+ ELSE x0 := rx0+dx;
+ y0 := ry0+dy;
+ x1 := rx1+dx;
+ y1 := ry1+dy;
+ TRUE
+ FI.
+
+ calculate cells:
+ cx0 := 0;
+ cy0 := 0;
+ cx1 := 0;
+ cy1 := 0;
+ IF abs(rx0) > dx
+ THEN cx0 := sign(rx0)
+ FI;
+ IF abs(rx1) > dx
+ THEN cx1 := sign(rx1)
+ FI;
+ IF abs(ry0) > dy
+ THEN cy0 := sign(ry0)
+ FI;
+ IF abs(ry1) > dy
+ THEN cy1 := sign(ry1)
+ FI.
+
+END PROC clipped line;
+
+END PACKET transformation;
+
+(******************************** picture ********************************)
+
+PACKET picture DEFINES (* Autor: H.Indenbirken *)
+ PICTURE, (* Stand: 23.02.1985 *)
+ :=, CAT, nilpicture,
+ draw, draw r, draw cm, draw cm r,
+ move, move r, move cm, move cm r,
+ bar, circle,
+ length, dim, pen, where,
+ extrema, rotate, stretch, translate,
+ text, picture:
+
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ move cm key = 6,
+ draw cm key = 7,
+ move cm r key = 8,
+ draw cm r key = 9,
+ bar key = 10,
+ circle key = 11,
+ max 2 dim = 31983,
+ max 3 dim = 31975,
+ max text = 31974,
+ max bar = 31982,
+ max circle = 31974,
+ max length = 32000;
+
+
+TYPE PICTURE = STRUCT (INT dim, pen, TEXT points);
+
+
+INT VAR read pos;
+REAL VAR x, y, z;
+TEXT VAR r2 :: 16*""0"", r3 :: 24*""0"", i1 :: ""0""0"";
+
+OP := (PICTURE VAR l, PICTURE CONST r) :
+ CONCR (l) := CONCR (r)
+END OP :=;
+
+OP CAT (PICTURE VAR l, PICTURE CONST r) :
+ IF l.dim <> r.dim
+ THEN errorstop ("OP CAT : left dimension <> right dimension")
+ ELIF length (l.points) > max length - length (r.points)
+ THEN errorstop ("OP CAT : Picture overflow") FI;
+
+ l.points CAT r.points
+END OP CAT;
+
+PICTURE PROC nilpicture :
+ PICTURE : (0, 1, "")
+END PROC nilpicture;
+
+PROC draw (PICTURE VAR p, TEXT CONST text) :
+ draw (p, text, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, bright):
+ write (p, text, angle, height, bright, text key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, draw key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, draw key)
+END PROC draw;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, draw r key)
+END PROC draw r;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, draw r key)
+END PROC draw r;
+
+PROC draw cm (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, draw cm key)
+END PROC draw cm;
+
+PROC draw cm r (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, draw cm r key)
+END PROC draw cm r;
+
+PROC move (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, move key)
+END PROC move;
+
+PROC move (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, move key)
+END PROC move;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, move r key)
+END PROC move r;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, move r key)
+END PROC move r;
+
+PROC move cm (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, move cm key)
+END PROC move cm;
+
+PROC move cm r (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, move cm r key)
+END PROC move cm r;
+
+PROC bar (PICTURE VAR p, REAL CONST width, height, INT CONST pattern):
+ write (p, width, height, pattern, bar key)
+END PROC bar;
+
+PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern):
+ write (p, radius, from, to, pattern, circle key)
+END PROC circle;
+
+
+PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST key) :
+ IF length (p.points) < max 3 dim
+ THEN p.points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ p.points CAT r3
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST key) :
+ IF length (p.points) < max 2 dim
+ THEN p.points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ p.points CAT r2
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST n, key) :
+ IF length (p.points) < max bar
+ THEN p.points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ p.points CAT r2;
+ replace (i1, 1, n);
+ p.points CAT i1
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST n, key) :
+ IF length (p.points) < max circle
+ THEN p.points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ p.points CAT r3;
+ replace (i1, 1, n);
+ p.points CAT i1
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, TEXT CONST t, REAL CONST angle, height, bright,
+ INT CONST key) :
+ IF max text - length (p.points) >= length (t)
+ THEN p.points CAT code (key);
+ replace (i1, 1, length (t));
+ p.points CAT i1;
+ p.points CAT t;
+ replace (r3, 1, angle);
+ replace (r3, 2, height);
+ replace (r3, 3, bright);
+ p.points CAT r3
+ FI;
+END PROC write;
+
+PROC check dim (PICTURE VAR p, INT CONST dim):
+ IF p.dim = 0
+ THEN p.dim := dim
+ ELIF p.dim <> dim
+ THEN errorstop ("Picture is " + text (p.dim) + " dimensional") FI
+END PROC check dim;
+
+INT PROC length (PICTURE CONST p):
+ length (p.points)
+END PROC length;
+
+INT PROC dim (PICTURE CONST pic) :
+ pic.dim
+END PROC dim;
+
+PROC pen (PICTURE VAR p, INT CONST pen) :
+ IF pen < 0 OR pen > 16
+ THEN errorstop ("pen out of range [0-16]") FI;
+ p.pen := pen
+END PROC pen;
+
+INT PROC pen (PICTURE CONST p) :
+ p.pen
+END PROC pen;
+
+PROC where (PICTURE CONST p, REAL VAR x, y) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0
+ ELIF p.dim = 3
+ THEN errorstop ("Picture is 3 dimensional")
+ ELSE x := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ y := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1
+ FI
+END PROC where;
+
+PROC where (PICTURE CONST p, REAL VAR x, y, z) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0; z := 0.0
+ ELIF p.dim = 2
+ THEN errorstop ("Picture is 2 dimensional")
+ ELSE x := subtext (p.points, length (p.points)-23, length (p.points)-16) RSUB 1;
+ y := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ z := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1;
+ FI
+END PROC where;
+
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max, z min, z max) :
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ z min := max real; z max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+calc extrema :
+ x := next real; y := next real; z := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real; z INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max):
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+calc extrema :
+ x := next real; y := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC rotate (PICTURE VAR p, REAL CONST angle) : (* X-Rotation *)
+ REAL CONST s :: sind( angle ), c := cosd( angle );
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( 1.0, 0.0, 0.0 ),
+ ROW 3 REAL : ( 0.0, c , s ),
+ ROW 3 REAL : ( 0.0, -s , c ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC rotate;
+
+PROC yrotate (PICTURE VAR p, REAL CONST angle): (* Y-Rotation *)
+ REAL CONST s :: sind (angle), c :: cosd (angle);
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( c , 0.0, -s ),
+ ROW 3 REAL : ( 0.0, 1.0, 0.0 ),
+ ROW 3 REAL : ( s , 0.0, c ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC yrotate;
+
+PROC zrotate (PICTURE VAR p, REAL CONST angle): (* Z-Rotation *)
+ REAL CONST s :: sind (angle), c :: cosd (angle);
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( c , s , 0.0 ),
+ ROW 3 REAL : ( -s , c , 0.0 ),
+ ROW 3 REAL : ( 0.0, 0.0, 1.0 ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC zrotate;
+
+PROC rotate (PICTURE VAR p, REAL CONST phi, theta, lambda ) :
+ IF phi <> 0.0
+ THEN rotate (p, phi) FI;
+ IF theta <> 0.0
+ THEN yrotate (p, theta) FI;
+ IF lambda <> 0.0
+ THEN zrotate (p, lambda)
+ FI
+END PROC rotate;
+
+PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) :
+ stretch (pic, sx, sy, 1.0)
+END PROC stretch;
+
+PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( sx, 0.0, 0.0),
+ ROW 3 REAL : (0.0, sy, 0.0),
+ ROW 3 REAL : (0.0, 0.0, sz),
+ ROW 3 REAL : (0.0, 0.0, 0.0)))
+END PROC stretch;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy) :
+ translate (p, dx, dy, 0.0)
+END PROC translate;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : (1.0, 0.0, 0.0),
+ ROW 3 REAL : (0.0, 1.0, 0.0),
+ ROW 3 REAL : (0.0, 0.0, 1.0),
+ ROW 3 REAL : ( dx, dy, dz)))
+END PROC translate;
+
+PROC transform (PICTURE VAR p, ROW 4 ROW 3 REAL CONST a) :
+ INT CONST pic length := length (p.points);
+ INT VAR begin pos;
+ read pos := 0;
+ x := 0.0; y := 0.0; z := 0.0;
+ IF p.dim = 2
+ THEN transform 2 dim pic
+ ELSE transform 3 dim pic FI .
+
+transform 2 dim pic:
+ WHILE read pos < pic length
+ REP transform 2 dim position PER .
+
+transform 2 dim position:
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 2 dim point
+ CASE move key : transform 2 dim point
+ CASE move r key : transform 2 dim point
+ CASE draw r key : transform 2 dim point
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+transform 2 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real;
+ transform (a, x, y, z);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ replace (p.points, begin pos, r2) .
+
+transform 3 dim pic:
+ WHILE read pos < pic length
+ REP transform 3 dim position PER .
+
+transform 3 dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 3 dim point
+ CASE move key : transform 3 dim point
+ CASE move r key : transform 3 dim point
+ CASE draw r key : transform 3 dim point
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+transform 3 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real; z := next real;
+ transform (a, x, y, z);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ replace (p.points, begin pos, r3) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC transform;
+
+PROC transform (ROW 4 ROW 3 REAL CONST a, REAL VAR x, y, z) :
+ REAL CONST ox :: x, oy :: y, oz :: z;
+ x := ox*a(1)(1) + oy*a(2)(1) + oz*a(3)(1) + a(4)(1);
+ y := ox*a(1)(2) + oy*a(2)(2) + oz*a(3)(2) + a(4)(2);
+ z := ox*a(1)(3) + oy*a(2)(3) + oz*a(3)(3) + a(4)(3)
+END PROC transform;
+
+TEXT PROC text (PICTURE CONST pic):
+ TEXT VAR result :: ""0""0""0""0""; (* 23.09.87 -cw- *)
+ replace (result, 1, pic.dim); (* wegen Heap-Ueberlauf *)
+ replace (result, 2, pic.pen);
+ result CAT pic.points;
+ result
+END PROC text;
+
+PICTURE PROC picture (TEXT CONST text):
+ PICTURE : (text ISUB 1, text ISUB 2, subtext (text, 5))
+END PROC picture;
+
+END PACKET picture;
+
+(******************************** picfile *********************************)
+
+PACKET picfile DEFINES (* Autor: H.Indenbirken *)
+ (* Stand: 23.02.1985 *)
+ PICFILE, :=, picture file,
+ select pen, selected pen, background,
+ set values, get values,
+ view, viewport, window, oblique, orthographic, perspective,
+ extrema,
+
+ put, get,
+ to first pic, to eof, to pic, up, down,
+ is first picture, eof, picture no, pictures,
+ delete picture, insert picture, read picture,
+ write picture, put picture:
+
+
+LET max pics = 1024,
+ pic dataspace = 1102;
+
+
+TYPE PICFILE = BOUND STRUCT (INT size, pos, background,
+ ROW 16 ROW 3 INT pens,
+ ROW 16 BOOL hidden,
+ ROW 3 ROW 2 REAL sizes,
+ ROW 2 ROW 2 REAL limits,
+ ROW 4 REAL angles,
+ ROW 2 REAL obliques,
+ ROW 3 REAL perspectives,
+ ROW max pics PICTURE pic);
+
+TEXT VAR i text :: ""0""0"", r text :: ""0""0""0""0""0""0""0""0"";
+INT VAR i;
+
+OP := (PICFILE VAR dest, PICFILE CONST source):
+ EXTERNAL 260
+END OP := ;
+
+OP := (PICFILE VAR p, DATASPACE CONST d) :
+ IF type (d) = pic dataspace
+ THEN CONCR (p) := d
+ ELIF type (d) < 0
+ THEN type (d, pic dataspace) ;
+ CONCR (p) := d ;
+ init picfile dataspace ;
+ ELSE errorstop ("dataspace is no PICFILE") FI .
+
+init picfile dataspace :
+ r.size := 0;
+ r.pos := 0;
+ r.background := 0;
+ r.sizes [1][1] := 0.0;
+ r.sizes [1][2] := 1.0;
+ r.sizes [2][1] := 0.0;
+ r.sizes [2][2] := 1.0;
+ r.sizes [3][1] := 0.0;
+ r.sizes [3][2] := 1.0;
+ r.limits [1][1] := 0.0;
+ r.limits [1][2] := 1.0;
+ r.limits [2][1] := 0.0;
+ r.limits [2][2] := 1.0;
+ r.angles [1] := 0.0;
+ r.angles [2] := 0.0;
+ r.angles [3] := 0.0;
+ r.angles [4] := 0.0;
+ r.obliques [1] := 0.0;
+ r.obliques [2] := 0.0;
+ r.perspectives [1] := 0.0;
+ r.perspectives [2] := 0.0;
+ r.perspectives [3] := 0.0;
+ FOR i FROM 1 UPTO 16
+ REP r.pens [i][1] := 1;
+ r.pens [i][2] := 0;
+ r.pens [i][3] := 1;
+ r.hidden [i] := TRUE
+ PER.
+
+r : CONCR (CONCR (p)).
+
+END OP :=;
+
+DATASPACE PROC picture file (TEXT CONST name) :
+ IF exists (name)
+ THEN old (name)
+ ELSE new (name) FI
+END PROC picture file;
+
+PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type,
+ BOOL CONST hidden):
+ IF pen < 1 OR pen > 16
+ THEN errorstop ("pen out of range") FI;
+ p.pens [pen][1] := colour;
+ p.pens [pen][2] := thickness;
+ p.pens [pen][3] := line type;
+ p.hidden [pen] := hidden
+END PROC select pen;
+
+PROC selected pen (PICFILE CONST p, INT CONST pen,
+ INT VAR colour, thickness, line type,
+ BOOL VAR hidden):
+ IF pen < 1 OR pen > 16
+ THEN errorstop ("pen out of range") FI;
+ colour := p.pens [pen][1];
+ thickness := p.pens [pen][2];
+ line type := p.pens [pen][3];
+ hidden := p.hidden [pen]
+END PROC selected pen;
+
+INT PROC background (PICFILE CONST p):
+ p.background
+END PROC background;
+
+PROC background (PICFILE VAR p, INT CONST colour):
+ p.background := colour
+END PROC background;
+
+PROC get values (PICFILE CONST p,
+ ROW 3 ROW 2 REAL VAR size,
+ ROW 2 ROW 2 REAL VAR limits,
+ ROW 4 REAL VAR angles,
+ ROW 2 REAL VAR oblique,
+ ROW 3 REAL VAR perspective) :
+ size := p.sizes;
+ limits := p.limits;
+ angles := p.angles;
+ oblique := p.obliques;
+ perspective := p.perspectives;
+
+END PROC get values;
+
+PROC set values (PICFILE VAR p,
+ ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 4 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ p.sizes := size;
+ p.limits := limits;
+ p.angles := angles;
+ p.obliques := oblique;
+ p.perspectives := perspective;
+
+END PROC set values;
+
+PROC view (PICFILE VAR p, REAL CONST alpha):
+ p.angles [1] := alpha
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST phi, theta):
+ p.angles [2] := sind (theta) * cosd (phi);
+ p.angles [3] := sind (theta) * sind (phi);
+ p.angles [4] := cosd (theta);
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST x, y, z):
+ p.angles [2] := x;
+ p.angles [3] := y;
+ p.angles [4] := z
+END PROC view;
+
+PROC viewport (PICFILE VAR p,REAL CONST hor min,hor max,vert min,vert max) :
+ p.limits [1][1] := hor min;
+ p.limits [1][2] := hor max;
+ p.limits [2][1] := vert min;
+ p.limits [2][2] := vert max;
+END PROC viewport;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) :
+ window (p, x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, z min, z max) :
+ p.sizes [1][1] := x min;
+ p.sizes [1][2] := x max;
+ p.sizes [2][1] := y min;
+ p.sizes [2][2] := y max;
+ p.sizes [3][1] := z min;
+ p.sizes [3][2] := z max;
+END PROC window;
+
+PROC oblique (PICFILE VAR p, REAL CONST a, b) :
+ p.obliques [1] := a;
+ p.obliques [2] := b;
+ p.perspectives [1] := 0.0;
+ p.perspectives [2] := 0.0;
+ p.perspectives [3] := 0.0
+END PROC oblique;
+
+PROC orthographic (PICFILE VAR p) :
+ p.obliques [1] := 0.0;
+ p.obliques [2] := 0.0;
+ p.perspectives [1] := 0.0;
+ p.perspectives [2] := 0.0;
+ p.perspectives [3] := 0.0
+END PROC orthographic;
+
+PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) :
+ p.obliques [1] := 0.0;
+ p.obliques [2] := 0.0;
+ p.perspectives [1] := cx;
+ p.perspectives [2] := cy;
+ p.perspectives [3] := cz
+END PROC perspective;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) :
+ REAL VAR dummy;
+ extrema (p, x min, x max, y min, y max, dummy, dummy)
+END PROC extrema;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max) :
+ REAL VAR new x min, new x max, new y min, new y max, new z min, new z max;
+ x min := max real; x max := - max real;
+ y min := max real; y max := - max real;
+ z min := max real; z max := - max real;
+ FOR i FROM 1 UPTO p.size
+ REP IF dim (p.pic [i]) = 2
+ THEN extrema (p.pic [i], new x min, new x max, new y min, new y max)
+ ELSE extrema (p.pic [i], new x min, new x max, new y min, new y max,
+ new z min, new z max)
+ FI;
+ x min := min (x min, new x min); x max := max (x max, new x max);
+ y min := min (y min, new y min); y max := max (y max, new y max);
+ z min := min (z min, new z min); z max := max (z max, new z max);
+ PER
+END PROC extrema;
+
+PROC put (FILE VAR f, PICFILE CONST p):
+ put line (f, parameter);
+ FOR i FROM 1 UPTO p.size
+ REP put line (f, text (p.pic [i])) PER .
+
+parameter:
+ intern (p.size) + intern (p.pos) + intern (p.background) + intern (p.pens) +
+ intern (p.hidden) + intern (p.sizes) + intern (p.limits) + intern (p.angles) +
+ intern (p.obliques) + intern (p.perspectives) .
+
+END PROC put;
+
+PROC get (PICFILE VAR p, FILE VAR f):
+ TEXT VAR record;
+ get line (f, record);
+ convert parameter;
+ FOR i FROM 1 UPTO p.size
+ REP get line (f, record);
+ p.pic [i] := picture (record)
+ PER .
+
+convert parameter:
+ convert (record, p.size); convert (record, p.pos);
+ convert (record, p.background); convert (record, p.pens);
+ convert (record, p.hidden); convert (record, p.sizes);
+ convert (record, p.limits); convert (record, p.angles);
+ convert (record, p.obliques); convert (record, p.perspectives) .
+
+END PROC get;
+
+PROC to first pic (PICFILE VAR p):
+ p.pos := 1
+END PROC to first pic;
+
+PROC to eof (PICFILE VAR p):
+ p.pos := p.size+1
+END PROC to eof;
+
+PROC to pic (PICFILE VAR p, INT CONST n):
+ IF n < 1
+ THEN errorstop ("Position underflow")
+ ELIF n > p.size
+ THEN errorstop ("Position after end of PICFILE")
+ ELSE p.pos := n FI
+END PROC to pic;
+
+PROC up (PICFILE VAR p):
+ to pic (p, p.pos-1)
+END PROC up;
+
+PROC up (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos-n)
+END PROC up;
+
+PROC down (PICFILE VAR p):
+ to pic (p, p.pos+1)
+END PROC down;
+
+PROC down (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos+n)
+END PROC down;
+
+BOOL PROC is first picture (PICFILE CONST p):
+ p.pos = 1
+END PROC is first picture;
+
+BOOL PROC eof (PICFILE CONST p):
+ p.pos >= p.size
+END PROC eof;
+
+INT PROC picture no (PICFILE CONST p):
+ p.pos
+END PROC picture no;
+
+INT PROC pictures (PICFILE CONST p):
+ p.size
+END PROC pictures;
+
+PROC delete picture (PICFILE VAR p) :
+ INT VAR i;
+ FOR i FROM p.pos+1 UPTO p.size
+ REP p.pic [i-1] := p.pic [i] PER;
+
+ p.pic [p.size] := nilpicture;
+ IF p.size > 1
+ THEN p.size DECR 1 FI
+END PROC delete picture;
+
+PROC insert picture (PICFILE VAR p) :
+ INT VAR i;
+ IF p.size >= max pics
+ THEN errorstop ("PICFILE overflow")
+ ELSE p.size INCR 1;
+ FOR i FROM p.size DOWNTO p.pos+1
+ REP p.pic [i] := p.pic [i-1] PER;
+
+ p.pic [p.pos] := nilpicture;
+ FI
+END PROC insert picture;
+
+PROC read picture (PICFILE VAR p, PICTURE VAR pic) :
+ pic := p.pic (p.pos) .
+END PROC read picture;
+
+PROC write picture (PICFILE VAR p, PICTURE CONST pic) :
+ p.pic (p.pos) := pic .
+END PROC write picture;
+
+PROC put picture (PICFILE VAR p, PICTURE CONST pic) :
+ IF p.size >= max pics
+ THEN errorstop ("PICFILE overflow")
+ ELSE p.size INCR 1;
+ p.pic [p.size] := pic;
+ FI
+END PROC put picture;
+
+TEXT PROC intern (INT CONST n):
+ replace (i text, 1, n);
+ i text
+END PROC intern;
+
+TEXT PROC intern (ROW 16 ROW 3 INT CONST n):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 16
+ REP FOR j FROM 1 UPTO 3
+ REP result CAT intern (n [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 16 BOOL CONST n):
+ INT VAR i, result :: 0;
+ FOR i FROM 1 UPTO 16
+ REP IF n [i]
+ THEN set bit (result, i-1) FI
+ PER;
+ intern (result)
+END PROC intern;
+
+TEXT PROC intern (REAL CONST r):
+ replace (r text, 1, r);
+ r text
+END PROC intern;
+
+TEXT PROC intern (ROW 3 ROW 2 REAL CONST r):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 3
+ REP FOR j FROM 1 UPTO 2
+ REP result CAT intern (r [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 2 ROW 2 REAL CONST r):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 2
+ REP FOR j FROM 1 UPTO 2
+ REP result CAT intern (r [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 4 REAL CONST r):
+ intern (r [1]) + intern (r [2]) + intern (r [3]) + intern (r [4])
+END PROC intern;
+
+TEXT PROC intern (ROW 3 REAL CONST r):
+ intern (r [1]) + intern (r [2]) + intern (r [3])
+END PROC intern;
+
+TEXT PROC intern (ROW 2 REAL CONST r):
+ intern (r [1]) + intern (r [2])
+END PROC intern;
+
+PROC convert (TEXT VAR record, INT VAR n):
+ n := record ISUB 1;
+ record := subtext (record, 3)
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 16 ROW 3 INT VAR n):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 16
+ REP FOR j FROM 1 UPTO 3
+ REP convert (record, n [i][j]) PER
+ PER
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 16 BOOL VAR n):
+ INT VAR i, result;
+ convert (record, result);
+ FOR i FROM 1 UPTO 16
+ REP n [i] := bit (i-1, result) PER
+END PROC convert;
+
+PROC convert (TEXT VAR record, REAL VAR r):
+ r := record RSUB 1;
+ record := subtext (record, 9)
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 3 ROW 2 REAL VAR r):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 3
+ REP FOR j FROM 1 UPTO 2
+ REP convert (record, r [i][j]) PER
+ PER;
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 2 ROW 2 REAL VAR r):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 2
+ REP FOR j FROM 1 UPTO 2
+ REP convert (record, r [i][j]) PER
+ PER;
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 4 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2]);
+ convert (record, r [3]); convert (record, r [4])
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 3 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2]); convert (record, r [3])
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 2 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2])
+END PROC convert;
+
+END PACKET picfile;
+
+(********************************* devices ********************************)
+
+PACKET devices DEFINES PLOTTER,
+ select plotter,
+ install plotter,
+ plotters,
+ plotter,
+ no plotter,
+ name,
+ channel,
+ station,
+ actual plotter,
+ drawing area,
+ plotter info,
+ :=,
+ = :
+
+LET trenn = "/";
+
+TYPE PLOTTER = STRUCT (INT station, channel, TEXT name);
+PLOTTER CONST noplotter :: PLOTTER : (0,0,"");
+PLOTTER VAR plotter id :: no plotter;
+TARGET VAR devices;
+TEXT VAR plotter set;
+INT VAR act plotter;
+
+OP := (PLOTTER VAR dest, PLOTTER CONST source):
+ CONCR (dest) := CONCR (source)
+END OP := ;
+
+BOOL OP = (PLOTTER CONST a, b):
+ (a.station = b.station) AND
+ (a.channel = b.channel) AND
+ (a.name = b.name )
+END OP =;
+
+PLOTTER PROC plotter:
+ plotter id
+END PROC plotter;
+
+PLOTTER PROC plotter (TEXT CONST def plotter):
+ select target (devices, def plotter, plotter set);
+ IF plotter set = ""
+ THEN IF def plotter = ""
+ THEN act plotter := 0;
+ no plotter
+ ELSE errorstop ("Unbekannter Plot-Id : " + def plotter);
+ no plotter
+ FI
+ ELSE select;plotter id
+ FI.
+
+ select:
+ INT VAR tp;
+ PLOTTER VAR plotter id;
+ plotter id.station := int(def plotter);
+ tp := pos (def plotter, trenn) + 1;
+ plotter id.channel := int(subtext (def plotter,tp));
+ plotter id.name := subtext (def plotter, pos (def plotter,trenn,tp)+1);
+END PROC plotter;
+
+PROC select plotter:
+ THESAURUS VAR plotter list :: empty thesaurus;
+ TEXT VAR plotter name;
+ INT VAR index :: 0;
+ get (plotters, plotter name, index);
+ WHILE index > 0 REP
+ insert (plotter list,plotter info (plotter name,60));
+ get (plotters, plotter name, index)
+ PER;
+ select plotter (name (plotters, link (plotter list, one(plotter list))))
+END PROC select plotter;
+
+PROC select plotter (PLOTTER CONST plotter):
+ select plotter (text (plotter.station) + trenn + text (plotter.channel) +
+ trenn + plotter.name)
+END PROC select plotter;
+
+PROC select plotter (TEXT CONST def plotter):
+ select target (devices, def plotter, plotter set);
+ IF plotter set = ""
+ THEN IF def plotter = ""
+ THEN act plotter := 0;
+ plotter id := no plotter
+ ELSE errorstop ("Unbekannter Plot-Id : " + def plotter)
+ FI
+ ELSE select
+ FI.
+
+ select:
+ INT VAR xp, yp, tp; REAL VAR xc, yc;
+ act plotter := link (plotters, def plotter);
+ plotter id.station := int(def plotter);
+ tp := pos (def plotter, trenn) + 1;
+ plotter id.channel := int(subtext (def plotter,tp));
+ plotter id.name := subtext (def plotter, pos (def plotter,trenn,tp)+1);
+ drawing area (xc, yc, xp, yp);
+ set drawing area (xc, yc, real (xp), real (yp));
+END PROC select plotter;
+
+PROC install plotter (TARGET VAR new plotset):
+ THESAURUS VAR new plotter :: target names (new plotset);
+ INT VAR index :: 0;
+ TEXT VAR name,set;
+ initialize target (devices);
+ get (new plotter,name,index);
+ WHILE index > 0 REP
+ select target (new plotset, name, set);
+ complete target (devices, name, set);
+ get (new plotter, name, index)
+ PER
+END PROC install plotter;
+
+INT PROC actual plotter:
+ act plotter
+END PROC actual plotter;
+
+THESAURUS PROC plotters:
+ target names (devices)
+END PROC plotters;
+
+TEXT PROC name (PLOTTER CONST plotter):
+ plotter.name
+END PROC name;
+
+INT PROC channel (PLOTTER CONST plotter):
+ plotter.channel
+END PROC channel;
+
+INT PROC station (PLOTTER CONST plotter):
+ plotter.station
+END PROC station;
+
+PROC drawing area (REAL VAR xcm, ycm, INT VAR xp, yp):
+ IF plotter set <> ""
+ THEN INT VAR cp;
+ xp := int(plotter set);
+ cp := pos (plotter set,",")+1;
+ yp := int (subtext (plotter set,cp));
+ cp := pos (plotter set,",",cp)+1;
+ xcm := real (subtext (plotter set,cp));
+ cp := pos (plotter set,",",cp)+1;
+ ycm := real (subtext (plotter set,cp))
+ FI
+END PROC drawing area;
+
+PROC drawing area (REAL VAR xcm, ycm, INT VAR xp, yp,PLOTTER CONST pl):
+ PLOTTER CONST keep :: plotter;
+ select plotter (pl);
+ drawing area (xcm, ycm, xp, yp);
+ select plotter (keep)
+END PROC drawing area;
+
+TEXT PROC plotter info (TEXT CONST plotter id,INT CONST len):
+ INT VAR tp :: pos (plotter id, trenn)+1;
+ TEXT VAR plotter name :: plotter id,
+ station :: "/Station" + text (int(plotter name),2),
+ kanal :: " Kanal" + text (int (subtext (plottername,tp)),3);
+ plotter name := subtext (plotter name, pos (plotter name, trenn,tp)+1) + " ";
+ INT VAR llen :: length (plotter name + kanal + station);
+ plotter name + (max(len-llen,0) * ".") + kanal + station
+END PROC plotter info;
+
+END PACKET devices
diff --git a/app/mpg/1987/src/GRAPHIK.Configurator b/app/mpg/1987/src/GRAPHIK.Configurator new file mode 100644 index 0000000..7bfdbb9 --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.Configurator @@ -0,0 +1,945 @@ +(**************************************************************************)
+(* *)
+(* 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
diff --git a/app/mpg/1987/src/GRAPHIK.Fkt b/app/mpg/1987/src/GRAPHIK.Fkt new file mode 100644 index 0000000..b48141c --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.Fkt @@ -0,0 +1,1378 @@ +(***************************************************************************)
+(* *)
+(* 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
diff --git a/app/mpg/1987/src/GRAPHIK.Install b/app/mpg/1987/src/GRAPHIK.Install new file mode 100644 index 0000000..1058c2e --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.Install @@ -0,0 +1,82 @@ +(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.1 vom 10.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Installation" geschrieben von C.Weinholz *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Dieses Programm wird in eine neueingerichtete Task *)
+(* GRAPHIK vom Archiv geladen, und sorgt nach 'run' *)
+(* fuer die volstaendige Installation des Graphik-Systems *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* global manager aequivalent ersetzt *)
+(* 'family password' wird nun erfragt und gesetzt *)
+(* *)
+(**************************************************************************)
+LET packet 1 = "GRAPHIK.Basis",
+ packet 2 = "GRAPHIK.Plot",
+ config = "GRAPHIK.Configurator",
+ install = "GRAPHIK.Configuration",
+ fkt = "GRAPHIK.Fkt",
+ fkthelp = "FKT.help",
+ turtle = "GRAPHIK.Turtle";
+
+FILE VAR f;
+TEXT VAR l;
+INT VAR x;
+
+check off;
+warnings off;
+archiv;
+fetch (ALLarchive- all,archive);
+BOOL VAR new conf :: NOT exists (install);
+IF new conf
+ THEN mess ("GRAPHIK muss neu konfiguriert werden")
+ ELSE new conf := yes ("GRAPHIK neu konfigurieren")
+FI;
+release;
+ins (packet 1);
+IF new conf
+ THEN run (config)
+ ELSE ins (install)
+FI;
+ins (packet 2);
+ins (fkt);
+ins (turtle);
+do ("generate plot manager");
+mess (""15" Fertig "14"");
+IF yes ("Alles loeschen")
+ THEN command dialogue (FALSE);
+ forget (all-fkthelp);
+ command dialogue (TRUE)
+FI;
+TEXT VAR geheim;
+put ("GRAPHIK-Password: ");
+get secret line (geheim);
+family password (geheim);
+global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) std manager);
+
+PROC ins (TEXT CONST name):
+ page;
+ f := sequential file (input, name);
+ FOR x FROM 1 UPTO 11 REP
+ getline (f,l);
+ putline (l);
+ PER;
+ mess ("""" + name + """ wird insertiert"13""10"");
+ insert (name)
+END PROC ins;
+
+PROC mess (TEXT CONST msg):
+ line;
+ putline (msg);
+END PROC mess;
+
diff --git a/app/mpg/1987/src/GRAPHIK.Manager b/app/mpg/1987/src/GRAPHIK.Manager new file mode 100644 index 0000000..b186e32 --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.Manager @@ -0,0 +1,900 @@ +(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.2 vom 23.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Plotmanager" geschrieben von C.Weinholz *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Dieses Paket stellt den Multispool-Ausgabemanager *)
+(* zur Verfuegung. *)
+(* Er wird in der Regel durch Aufruf von *)
+(* 'generate plot manager' in GRAPHIK in einer neuerzeugten *)
+(* Sohntask 'PLOT' installiert. *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* Kommando 'spool control ("TEXT")' im Plot-Monitor *)
+(* Anzeige von 'order tasks' anderer Stationen *)
+(* Fehler : 'Zu viele DATASPACEs', selten, Ursache ungeklaert *)
+(**************************************************************************)
+PACKET plot manager DEFINES plot manager ,
+ plot server :
+
+LET max spools = 12, (* BJ 15.10.87 (wg P9) *)
+ max entries = 20, (* Hinweis: max spools * max entries < 250 *)
+
+ ack = 0,
+ second phase ack = 5,
+ false code = 6,
+ fetch code = 11,
+ save code = 12,
+ existscode = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ first code = 25,
+ start code = 26,
+ stop code = 27,
+ halt code = 28,
+ wait for halt code = 29,
+ continue code = 100,
+ picfiletype = 1102,
+
+ trenn = "/",
+
+ MSG = STRUCT (TEXT ds name, dev name, passwd, INT dev no),
+
+ JOB = STRUCT (DATASPACE ds, TEXT ds name, TASK order task),
+
+ ENTRY = STRUCT (JOB job, INT link),
+
+ CHAIN = STRUCT (ROW max entries ENTRY entry, INT first, last, empty),
+
+ SERVER = STRUCT (TASK task, wait for halt, REAL time,
+ JOB current job, BOOL stopped, INT link);
+
+ROW max spools STRUCT (SERVER server, CHAIN chain) VAR device;
+
+MSG VAR msg;
+
+INT VAR entry to erase, last created server, reply, current plotter;
+FILE VAR chain info;
+THESAURUS VAR managed plotter;
+BOUND THESAURUS VAR thesaurus msg;
+DATASPACE VAR reply ds;
+TASK VAR control task;
+
+(********************************* SPOOL ***********************************)
+
+PROC plot manager :
+ INT VAR act dev;
+ managed plotter := plotters LIKE (text (station (myself)) + any);
+ FOR act dev FROM 1 UPTO max devices REP
+ init device (act dev)
+ PER;
+ control task := niltask;
+ end global manager (FALSE);
+ global manager (PROC (DATASPACE VAR,INT CONST,INT CONST,TASK CONST)plot manager)
+END PROC plot manager;
+
+PROC plot manager (DATASPACE VAR ds, INT CONST order, phase, TASK CONST order task):
+ INT VAR act dev;
+ SELECT order OF
+ CASE fetch code : y fetch
+ CASE save code : y save
+ CASE exists code: y exists
+ CASE erase code : y erase
+ CASE list code : y list
+ CASE all code : y all
+ OTHERWISE IF order >= continue code AND order task = supervisor
+ THEN forget (ds);
+ continue (order - continue code);
+ spool monitor
+ ELIF priv control op
+ THEN SELECT order OF
+ CASE first code : y first
+ CASE start code : y start
+ CASE stop code : y stop
+ CASE halt code : y halt
+ CASE wait for halt code : y halt
+ OTHERWISE order error
+ ENDSELECT
+ ELSE order error
+ FI;
+ END SELECT;
+ BOOL VAR test;
+ FOR act dev FROM 1 UPTO max devices REP
+ test := server is active (act dev)
+ PER.
+
+ priv control op:
+ (order task = father) OR (order task < supervisor) OR
+ spool control task.
+
+ spool control task:
+ NOT (order task = niltask) CAND
+ ((order task = control task) OR (order task < control task)).
+
+ y fetch:
+ FOR act dev FROM 1 UPTO max devices REP
+ UNTIL act server.task = order task PER;
+ IF act dev > max devices
+ THEN order error
+ ELIF chain is empty (act dev) OR act server.stopped
+ THEN end server (act dev);
+ IF exists (act server.wait for halt)
+ THEN send (act server.wait for halt, ack);
+ act server.wait for halt := niltask
+ FI
+ ELSE transfer next job (act dev);
+ send current job (act dev)
+ FI.
+
+ y save:
+ IF phase = 1
+ THEN y save pre
+ ELSE y save post
+ FI.
+
+ y save pre:
+ link dev;
+ IF act dev = 0
+ THEN device error
+ ELIF chain is full (act dev)
+ THEN errorstop ("SPOOL ist voll")
+ ELSE send (order task, second phase ack)
+ FI.
+
+ y save post:
+ act dev := msg.dev no;
+ IF type (ds) <> picfile type
+ THEN forget (ds);
+ errorstop ("Datenraum hat falschen Typ")
+ ELSE entry into chain (act dev, new job);
+ forget (ds);
+ IF NOT (server is active (act dev) OR act server.stopped)
+ THEN create server (act dev)
+ FI;
+ send ack
+ FI.
+
+ new job:
+ JOB : (ds, msg.ds name, order task).
+
+ y exists:
+ link dev;
+ IF find entry (msg.ds name,act dev,order task, priv control op) = 0
+ THEN send (order task, false code, ds)
+ ELSE send ack
+ FI.
+
+ y erase:
+ IF phase = 1
+ THEN link dev;
+ IF act dev > 0
+ THEN y erase pre
+ ELSE device error
+ FI
+ ELSE erase entry (act dev, entry to erase);
+ send ack
+ FI.
+
+ y erase pre:
+ entry to erase := find entry (msg.ds name,act dev, order task, priv control op);
+ IF order not from job order task AND NOT priv control op
+ THEN errorstop ("Kein Zugriffsrecht auf Auftrag """ + msg.ds name + """")
+ ELIF entry to erase = 0
+ THEN manager message ("""" + msg.ds name + """ existiert nicht")
+ ELSE manager question (erase msg)
+ FI.
+
+ erase msg:
+ TASK VAR owner ::act chain.entry [entry to erase].job.order task;
+ owner id (owner) + "/ """ + msg.ds name +
+ """ in Spool """ + name (managed plotter, act dev) +
+ """ loeschen".
+
+ order not from job order task:
+ NOT (act chain.entry [entry to erase].job.order task = order task).
+
+ y list:
+ link dev;
+ create chain list (act dev);
+ send (order task, ack, reply ds).
+
+ y all:
+ link dev;
+ forget (reply ds);
+ reply ds := nilspace;
+ thesaurus msg := reply ds;
+ thesaurus msg := chain thesaurus (act dev, owner or priv task, FALSE);
+ send (order task, ack, reply ds).
+
+ owner or priv task:
+ IF priv control op
+ THEN niltask
+ ELSE order task
+ FI.
+
+ y start:
+ link dev;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ start (act dev)
+ PER
+ ELSE start (act dev)
+ FI;
+ send ack.
+
+ y stop:
+ IF phase = 1
+ THEN y stop pre
+ ELSE y stop post
+ FI.
+
+ y stop pre:
+ link dev;
+ IF act dev > 0
+ THEN stop (act dev);
+ IF NOT is no job (act server.current job)
+ THEN manager question ("""" + act server.current job.ds name
+ + """ neu eintragen")
+ ELSE send ack
+ FI
+ ELSE FOR act dev FROM 1 UPTO max devices REP
+ stop (act dev)
+ PER;
+ send ack
+ FI.
+
+ y stop post:
+ act dev := msg.dev no;
+ entry into chain (act dev, act server.current job);
+ IF act chain.last > 1
+ THEN make new first (act dev, act chain.last)
+ FI;
+ send ack.
+
+ y halt:
+ link dev;
+ IF act dev = 0
+ THEN IF order <> halt code
+ THEN device error
+ ELSE FOR act dev FROM 1 UPTO max devices REP
+ halt (act dev)
+ PER;
+ send ack
+ FI
+ ELSE halt (act dev);
+ IF order = halt code
+ THEN send ack;
+ act server.wait for halt := niltask
+ ELSE act server.wait for halt := order task
+ FI
+ FI.
+
+ y first:
+ link dev;
+ IF act dev = 0
+ THEN device error
+ ELSE INT VAR new first entry :: find entry (msg.ds name,act dev,order task,TRUE);
+ IF new first entry = 0
+ THEN manager message ("""" + msg.ds name + """ existiert nicht")
+ ELSE make new first (act dev,new first entry);
+ send ack
+ FI
+ FI.
+
+ act server:
+ device [act dev].server.
+
+ act chain:
+ device [act dev].chain.
+
+ send ack:
+ send (order task, ack).
+
+ link dev:
+ msg := ds;
+ act dev := msg.dev no.
+
+ order error:
+ errorstop ("Falscher Auftrag fuer Task """ + name (myself) + """").
+
+ device error:
+ IF plotter (msg.dev name) = no plotter
+ THEN clear error; (* 'plotter(TEXT)' liefert evtl. bereits error *)
+ errorstop ("Kein Endgeraet eingestellt")
+ ELSE clear error;
+ errorstop ("Unbekanntes Endgeraet: """ + msg.dev name + """")
+ FI.
+END PROC plot manager;
+
+(****************************** Spool Monitor ******************************)
+
+INT VAR command index , params ;
+TEXT VAR command line, param 1, param 2 ;
+
+LET spool command list =
+"break:1.0start:2.0stop:3.0halt:4.0first:5.0killer:6.0listspool:7.0
+ clearspool:8.0selectplotter:9.0spoolcontrol:10.1";
+
+PROC spool monitor:
+ disable stop ;
+ current plotter := 0;
+ select plotter ("");
+ REP command dialogue (TRUE) ;
+ get command (gib kommando, command line);
+ analyze command (spool command list, command line, 3, command index,
+ params, param1, param2);
+ execute command;
+ UNTIL NOT online PER;
+ command dialogue (FALSE);
+ break (quiet);
+ set autonom.
+
+ gib kommando:
+ IF actual plotter > 0
+ THEN plotter info (name(plotters,actual plotter),50)
+ ELSE "ALL-Plotter: "
+ FI
+END PROC spool monitor;
+
+PROC execute command:
+ enable stop;
+ SELECT command index OF
+ CASE 1 : break
+ CASE 2 : start cmd
+ CASE 3 : stop cmd
+ CASE 4 : halt cmd
+ CASE 5 : first cmd
+ CASE 6 : killer cmd
+ CASE 7 : show spool list
+ CASE 8 : clear spool
+ CASE 9 : select plotter cmd
+ CASE 10 : set spool control
+ OTHERWISE do (command line);
+ set current plotter
+ END SELECT.
+
+ set current plotter:
+ current plotter := link(managed plotter, name (plotters,actual plotter));
+ IF actual plotter > 0 AND current plotter = 0
+ THEN select plotter ("");
+ current plotter := 0;
+ errorstop ("Auf dieser Station unbekannt: """+name(plotter)+"""")
+ FI.
+
+ start cmd:
+ FOR act dev FROM curr dev UPTO top dev REP
+ start (act dev)
+ PER.
+
+ stop cmd:
+ FOR act dev FROM curr dev UPTO top dev REP
+ IF device [act dev].server.current job.ds name <> "" CAND
+ yes ("""" + device [act dev].server.current job.ds name +
+ """ neu eintragen")
+ THEN entry into chain (act dev, device [act dev].server.current job);
+ IF device [act dev].chain.last > 1
+ THEN make new first (act dev, device [act dev].chain.last)
+ FI
+ FI;
+ stop (act dev)
+ PER.
+
+ halt cmd:
+ FOR act dev FROM curr dev UPTO top dev REP
+ halt (act dev)
+ PER.
+
+ first cmd:
+ IF current plotter = 0
+ THEN device error
+ FI;
+ TEXT VAR make to first :: one (chain thesaurus (current plotter,niltask,TRUE)
+ -first chain entry)
+ IF make to first <> ""
+ THEN INT VAR new first entry :: find entry (make to first,
+ current plotter, niltask, FALSE);
+ IF new first entry > 1
+ THEN make new first (current plotter, new first entry)
+ FI
+ FI.
+
+ first chain entry:
+ INT VAR first entry id :: device [current plotter].chain.first;
+ IF first entry id > 0
+ THEN device [current plotter].chain.entry[first entry id].job.ds name
+ ELSE ""
+ FI.
+
+ killer cmd:
+ IF current plotter = 0
+ THEN device error
+ FI;
+ THESAURUS VAR to erase :: chain thesaurus (current plotter,niltask,FALSE);
+ INT VAR index, act dev;
+ TEXT VAR name to erase;
+ FOR act dev FROM curr dev UPTO top dev REP
+ index := 0;
+ get (to erase, name to erase, index);
+ WHILE index > 0 REP
+ INT VAR entry to erase := find entry (name to erase, current plotter, niltask, TRUE);
+ IF (entry to erase > 0) CAND
+ yes ("""" + name to erase + """ loeschen")
+ THEN erase entry (current plotter, entry to erase)
+ FI;
+ get (to erase, name to erase, index)
+ PER
+ PER.
+
+ show spool list :
+ create chain list (current plotter);
+ show (chain info);
+ forget (reply ds).
+
+ clear spool:
+ FOR act dev FROM curr dev UPTO top dev REP
+ IF yes ("Spool """ + name (managed plotter, act dev) + """ initialisieren")
+ THEN BOOL VAR stopped :: device [act dev].server.stopped;
+ stop (act dev);
+ init device (act dev);
+ IF stopped
+ THEN device [act dev].server.stopped := TRUE
+ ELSE start (act dev)
+ FI
+ FI
+ PER.
+
+ set spool control:
+ control task := task (param 1).
+
+ select plotter cmd:
+ THESAURUS VAR plotter list :: empty thesaurus;
+ TEXT VAR plotter name;
+ get (managed plotter, plotter name, index);
+ WHILE index > 0 REP
+ insert (plotter list, plotter info (plotter name, 60));
+ get (managed plotter, plotter name, index)
+ PER;
+ select plotter (name (managed plotter,
+ link (plotter list,one (plotter list))));
+ set current plotter.
+
+ curr dev:
+ IF current plotter = 0
+ THEN 1
+ ELSE current plotter
+ FI.
+
+ top dev:
+ IF current plotter = 0
+ THEN max devices
+ ELSE current plotter
+ FI.
+
+ device error:
+ errorstop ("Kein Endgeraet eingestellt")
+
+ENDPROC execute command ;
+
+(************************** SPOOL - Verwaltung *****************************)
+
+PROC entry into chain (INT CONST dev no, JOB CONST new job):
+ INT VAR act entry := act chain.empty;
+ act chain.empty := act chain.entry [act entry].link;
+ IF act chain.last > 0
+ THEN act chain.entry [act chain.last].link := act entry
+ FI;
+ act chain.last := act entry;
+ IF act chain.first = 0
+ THEN act chain.first := act entry
+ FI;
+ act chain.entry [act entry] := ENTRY : (new job,0).
+
+ act chain :
+ device [dev no].chain
+END PROC entry into chain;
+
+PROC erase entry (INT CONST dev no, to erase):
+ INT VAR act entry;
+ to forward entry;
+ IF act entry > 0
+ THEN act chain.entry [act entry].link := act chain.entry [to erase].link
+ FI;
+ IF act chain.last = to erase
+ THEN act chain.last := act entry
+ FI;
+ IF act chain.first = to erase
+ THEN act chain.first := act chain.entry [to erase].link
+ FI;
+ init job (act chain.entry [to erase].job);
+ act chain.entry [to erase].link := act chain.empty;
+ act chain.empty := to erase.
+
+ to forward entry:
+ FOR act entry FROM 1 UPTO max entries REP
+ UNTIL act chain.entry [act entry].link = to erase PER;
+ IF act entry > max entries
+ THEN act entry := 0
+ FI.
+
+ act chain:
+ device [dev no].chain
+END PROC erase entry;
+
+INT PROC find entry (TEXT CONST ds name, INT CONST dev, TASK CONST order task,BOOL CONST priviledged):
+ INT VAR act dev :: dev,act entry,last found :: 0;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ find entry of order task
+ UNTIL act entry > 0 PER
+ ELSE find entry of order task
+ FI;
+ IF act entry = 0
+ THEN last found
+ ELSE act entry
+ FI.
+
+ find entry of order task:
+ BOOL VAR entry found;
+ act entry := act chain.first;
+ WHILE act entry > 0 REP
+ entry found := (act chain.entry [act entry].job.ds name = ds name);
+ IF entry found
+ THEN last found := act entry;
+ entry found := (index (act chain.entry [act entry].job.order task) =
+ index (order task)) OR priviledged
+ FI;
+ IF NOT entry found
+ THEN act entry := act chain.entry [act entry].link
+ FI
+ UNTIL entry found PER.
+
+ act chain:
+ device [act dev].chain
+
+END PROC find entry;
+
+PROC make new first (INT CONST dev no, new first):
+ JOB VAR new first job :: act chain.entry [new first].job;
+ erase entry (dev no, new first);
+ INT VAR act entry := act chain.empty;
+ act chain.empty := act chain.entry [act entry].link;
+ act chain.entry [act entry] := ENTRY : (new first job, act chain.first);
+ act chain.first := act entry;
+ IF act chain.last = 0
+ THEN act chain.last := act entry
+ FI.
+
+ act chain:
+ device [dev no].chain
+
+END PROC make new first;
+
+THESAURUS PROC chain thesaurus (INT CONST dev no, TASK CONST order task,
+ BOOL CONST double):
+ THESAURUS VAR list :: empty thesaurus;
+ INT VAR act dev := dev no,act entry;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ list chain
+ PER
+ ELSE list chain
+ FI;
+ list.
+
+ list chain:
+ act entry := act chain.first;
+ WHILE act entry > 0 REP
+ IF (order task = niltask) OR
+ (act chain.entry [act entry].job.order task = order task)
+ THEN insert job name
+ FI;
+ act entry := act chain.entry [act entry].link
+ PER.
+
+ insert job name:
+ TEXT VAR this job :: act chain.entry [act entry].job.ds name
+ IF double OR (NOT (list CONTAINS this job))
+ THEN insert (list, this job)
+ FI.
+
+ act chain:
+ device [act dev].chain
+
+END PROC chain thesaurus;
+
+
+PROC create chain list (INT CONST dev no):
+ INT VAR act dev :: dev no, act entry;
+ init chain info;
+ IF act dev = 0
+ THEN FOR act dev FROM 1 UPTO max devices REP
+ list chain
+ PER
+ ELSE list chain
+ FI.
+
+ init chain info:
+ forget (reply ds);
+ reply ds := nilspace;
+ chain info := sequential file (output, reply ds);
+ headline (chain info,"GRAPHIK - Ausgabe um "+ time of day (clock (1)) + " Uhr :").
+
+
+ list chain:
+ server head;
+ IF NOT server is active (act dev) OR is no job (act server.current job)
+ THEN put (chain info, "- Kein Auftrag in Bearbeitung") ;
+ IF act server.stopped
+ THEN put (chain info, " ( SERVER deaktiviert )")
+ FI;
+ line (chain info)
+ ELSE put (chain info, "- In Bearbeitung seit "+time of day (act server.time)+" Uhr :");
+ IF act server.stopped
+ THEN put (chain info, " ( SERVER wird deaktiviert !)")
+ FI;
+ line (chain info, 2);
+ putline (chain info, job note (act server.current job))
+ FI;
+ line (chain info);
+ IF act chain.last = 0
+ THEN putline (chain info, "- Keine Auftraege im SPOOL")
+ ELSE putline (chain info, "- Weitere Auftraege im SPOOL :");
+ line (chain info);
+ act entry := act chain.first;
+ WHILE act entry > 0 REP
+ putline (chain info, job note (act chain.entry [act entry].job));
+ act entry := act chain.entry [act entry].link
+ PER
+ FI;
+ line (chain info, 2).
+
+ server head:
+ TEXT VAR plotter name :: name (managed plotter,act dev);
+ INT VAR station :: int (plottername),
+ tp :: pos (plottername,trenn)+1,
+ channel :: int (subtext (plottername,tp));
+ plotter name := subtext (plotter name, pos (plotter name, trenn, tp)+1);
+ putline (chain info, 77 * "-");
+ putline (chain info,
+ center (plotter name + (30-length(plotter name))*"." +
+ "Kanal " + text (channel) +
+ "/Station " + text (station)));
+ putline (chain info, 77 * "-");
+ line (chain info).
+
+ act chain:
+ device [act dev].chain.
+
+ act server:
+ device [act dev].server
+
+END PROC create chain list;
+
+BOOL PROC chain is empty (INT CONST dev no):
+ device [dev no].chain.first = 0 OR device [dev no].chain.last = 0
+END PROC chain is empty;
+
+BOOL PROC chain is full (INT CONST dev no):
+ device [dev no].chain.empty = 0
+END PROC chain is full;
+
+PROC transfer next job (INT CONST dev no):
+ INT VAR next chain entry := device [dev no].chain.first;
+ next server job (dev no, device [dev no].chain.entry [next chain entry].job);
+ erase entry (dev no,next chain entry)
+END PROC transfer next job;
+
+(*************************** SERVER - Verwaltung ***************************)
+
+PROC next server job (INT CONST dev no,JOB CONST next job):
+ act server.time := clock (1);
+ act server.current job := next job.
+
+ act server:
+ device [dev no].server
+END PROC next server job;
+
+BOOL PROC server is active (INT CONST dev no):
+ exists (act server.task) CAND server alive or restarted.
+
+ server alive or restarted:
+ SELECT status (act server.task) OF
+ CASE 0 (* busy *) ,
+ 4 (* busy-blocked *),
+ 2 (* wait *),
+ 6 (* wait-blocked *) : TRUE
+ CASE 1 (* i/o *),
+ 5 (* i/o -blocked *): IF channel (act server.task) = 0
+ THEN restart
+ ELSE TRUE
+ FI
+ OTHERWISE restart
+ END SELECT.
+
+ restart:
+ end server (dev no);
+ IF NOT act server.stopped AND NOT chain is empty (dev no)
+ THEN create server (dev no)
+ FI;
+ NOT is niltask (act server.task).
+
+ act server:
+ device [dev no].server
+
+END PROC server is active;
+
+PROC create server (INT CONST dev no):
+ init job (act server.current job);
+ act server.wait for halt := niltask;
+ act server.time := 0.0;
+ act server.stopped := FALSE;
+ last created server := dev no;
+ begin (PROC plot server, device [dev no].server.task).
+
+ act server:
+ device [dev no].server
+END PROC create server;
+
+PROC end server (INT CONST dev no):
+ end (act server.task);
+ act server.task := niltask.
+
+ act server:
+ device [dev no].server
+
+END PROC end server;
+
+PROC start (INT CONST dev no):
+ IF server is active (dev no)
+ THEN end server (dev no)
+ FI;
+ IF NOT chain is empty (dev no)
+ THEN create server (dev no)
+ FI;
+ device [dev no].server.stopped := FALSE
+END PROC start;
+
+PROC stop (INT CONST dev no):
+ device [dev no].server.stopped := TRUE;
+ IF exists (device [dev no].server.wait for halt)
+ THEN send (device [dev no].server.wait for halt,ack)
+ FI;
+ device [dev no].server.wait for halt := niltask;
+ IF server is active (dev no)
+ THEN end server (dev no)
+ FI
+END PROC stop;
+
+PROC halt (INT CONST dev no):
+ device [dev no].server.stopped := TRUE
+END PROC halt;
+
+PROC send current job (INT CONST dev no):
+ forget (reply ds);
+ reply ds := device [dev no].server.current job.ds;
+ send (device [dev no].server.task, ack,reply ds);
+END PROC send current job;
+
+(****************************** Hilfsprozeduren ****************************)
+
+PROC init device (INT CONST dev no):
+ INT VAR act entry;
+ act server.task := niltask;
+ act server.time := 0.0;
+ init job (act server.current job);
+ act server.stopped := FALSE;
+ act chain.first := 0;
+ act chain.last := 0;
+ act chain.empty := 1;
+ FOR act entry FROM 1 UPTO max entries-1 REP
+ init job (act chain.entry [act entry].job);
+ act chain.entry [act entry].link := act entry + 1
+ PER;
+ init job (act chain.entry [act entry].job);
+ act chain.entry [act entry].link := 0.
+
+ act server :
+ device [dev no].server.
+
+ act chain :
+ device [dev no].chain
+
+END PROC init device;
+
+INT PROC max devices:
+ highest entry (managed plotter)
+END PROC max devices;
+
+OP := (MSG VAR dest, DATASPACE VAR source):
+ TEXT VAR ds name :: "", dev name :: "";
+ BOUND STRUCT (TEXT ds name, dev name, passwd) VAR msg in := source;
+ divide names;
+ dest := MSG : (ds name, dev name, msg in .passwd,
+ link (managed plotter,dev name));
+ forget (source).
+
+ divide names:
+ INT VAR pps :: pos (msg in.ds name, ""0"");
+ WHILE pos (msg in.ds name, ""0"", pps+1) > 0 REP
+ pps := pos (msg in.ds name,""0"", pps+1)
+ PER;
+ IF pps > 0
+ THEN ds name := subtext (msg in.ds name, 1, pps-1);
+ FI;
+ dev name := subtext (msg in.ds name, pps+1).
+
+END OP :=;
+
+TEXT PROC job note (JOB CONST job):
+ " - " + owner id (job.order task) + " : " + qrline (job.ds name, 20) +
+ " (" + text (storage (job.ds)) + " K)".
+END PROC job note;
+
+TEXT PROC owner id (TASK CONST owner):
+ TEXT VAR test :: name (owner);
+ IF test <> ""
+ THEN text (station (owner)) + "/" + qrline (test,15)
+ ELSE "?????"
+ FI
+END PROC owner id;
+
+PROC init job (JOB VAR to initialize):
+ forget (to initialize.ds);
+ to initialize.ds name := "";
+ to initialize.order task := niltask
+END PROC init job;
+
+TEXT PROC qrline (TEXT CONST t,INT CONST len):
+ IF length (t) > len-2
+ THEN """" + text (t, len-5) + "..."""
+ ELSE text ("""" + t + """", len)
+ FI
+END PROC qrline;
+
+TEXT PROC center (TEXT CONST chars,INT CONST len):
+ len DIV 2 * " " + chars
+END PROC center;
+
+BOOL PROC is no job (JOB CONST job):
+ job.ds name = ""
+END PROC is no job;
+
+PROC send (TASK CONST task, INT CONST code):
+ DATASPACE VAR ds :: nilspace;
+ send (task, code, ds);
+ forget (ds)
+END PROC send;
+
+(**************************** Plot - Server ********************************)
+
+PROC plot server:
+ disable stop;
+ select plotter (name (managed plotter,last created server));
+ prepare;
+ REP
+ TEXT VAR dummy;
+ catinput (dummy, dummy); (* evtl. Zeichen im Tastaturpuffer *)
+ PICFILE VAR pic :: next server job;
+ plot (pic);
+ PER.
+
+ next server job:
+ forget (reply ds);
+ reply ds := nilspace;
+ REP
+ call (father, fetch code, reply ds, reply)
+ UNTIL reply = ack PER;
+ reply ds
+END PROC plot server;
+
+END PACKET plot manager
diff --git a/app/mpg/1987/src/GRAPHIK.Plot b/app/mpg/1987/src/GRAPHIK.Plot new file mode 100644 index 0000000..00911a8 --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.Plot @@ -0,0 +1,1156 @@ +(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.2 vom 23.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Graphik-Plot" geschrieben von C.Weinholz *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Paket II: Endgeraet-abhaengige Graphikroutinen *)
+(* (koennen erst nach 'Interface.Conf' insertiert werden) *)
+(* *)
+(* 1. Plot (Grundlegende Graphik-Operationen *)
+(* *)
+(* 2. Plot Input/Output (Routinen zum *)
+(* Ansprechen des PLOT-Spoolers *)
+(* zur indirekten Graphik-Ausgabe) *)
+(* *)
+(* 3. Plot Picture/Picfile *)
+(* (Ausgabe von PICTURES/ PICFILES) *)
+(* *)
+(**************************************************************************)
+(* Urversion : 10.09.87 *)
+(* Aenderungen: 23.09.87, Carsten Weinholz *)
+(* PROC save (PICFILE CONST, TEXT CONST, PLOTTER CONST) *)
+(* hinzugefuegt *)
+(* PROC plot (PICFILE CONST) auch indirekt *)
+(* Fehlermeldung bei indirektem 'plot (PICTURE)' *)
+(* 20.11.87, Beat Jegerlehner *)
+(* Clipping bei move eingefuehrt. Gibt sonst bei Watanabe *)
+(* Probleme *)
+(* Textgenerator korrigiert *)
+(* *)
+(**************************************************************************)
+
+(************************************ Plot ********************************)
+
+PACKET basis plot DEFINES
+
+ beginplot,
+ pen ,
+
+ move ,
+ move r ,
+ move cm ,
+ move cm r,
+
+ draw ,
+ draw r ,
+ draw cm ,
+ draw cm r,
+
+ hidden lines,
+ reset ,
+
+ zeichensatz,
+ reset zeichensatz,
+
+ linetype,
+ reset linetypes,
+
+ where,
+ bar,
+ circle,
+ box:
+
+LET empty = 0, (* Punktmuster *)
+ half = 1,
+ full = 2,
+ horizontal = 3,
+ vertical = 4,
+ cross = 5,
+ diagonal right = 6,
+ diagonal left = 7,
+ diagonal both = 8,
+ std zeichenname = "ZEICHENSATZ";
+
+INT VAR ltype :: 1,
+ thick :: 0,
+ xpixel :: 0,
+ ypixel :: 0,
+ old x :: 0,
+ old y :: 0,
+ real old x :: 0,
+ real old y :: 0;
+
+REAL VAR x cm, ycm,hor relation, vert relation,x to y,y to x;
+
+ROW 5 TEXT VAR linetypes;
+
+INT VAR cnt :: 0;
+TEXT VAR muster :: "0";
+INT VAR lentxt :: length(muster);
+
+LET POS = STRUCT (REAL x, y, z);
+POS VAR pos :: POS : (0.0, 0.0, 0.0);
+
+LET ZEICHENSATZ = ROW 255 TEXT;
+ZEICHENSATZ VAR zeichen;
+REAL CONST char x :: 6.0, char y :: 6.0,y base :: 2.0;
+
+BOUND ZEICHENSATZ VAR std zeichen :: old (std zeichenname);
+reset zeichensatz;
+reset linetypes;
+
+INT VAR h :: 0, v :: 0, new h :: 0, new v :: 0;
+
+BOOL VAR hidden :: FALSE;
+
+DATASPACE VAR ds :: nilspace;
+BOUND STRUCT (ROW 32764 INT akt, last) VAR maxima :: ds;
+
+(*************************** Initialisierung *******************************)
+
+PROC beginplot:
+ init plot;
+ drawing area (x cm, y cm, x pixel, y pixel);
+ hor relation := real (x pixel)/x cm;
+ vert relation:= real (y pixel)/y cm;
+ x to y := x cm / real(x pixel) / (y cm / real (y pixel)); (*umrechnung:*)
+ y to x := 1.0 / x to y; (* x pixel in y pixel u andersherum*)
+END PROC beginplot;
+
+PROC pen (INT CONST backgr,colour,thickn,linetype):
+ background(backgr);
+ foreground(colour);
+ thick := int(real(thickn) / 200.0 * real(x pixel) / x cm);
+ ltype := selected linetype;
+ IF ltype > 1
+ THEN muster := linetypes[ltype];
+ lentxt := length (muster);
+ cnt := 0
+ FI.
+
+ selected linetype:
+ IF linetype < 0 OR linetype > 5
+ THEN 1
+ ELSE linetype
+ FI
+END PROC pen;
+
+(************************** MOVE - Prozeduren ******************************)
+
+PROC move (INT CONST x,y):
+ old x := x;
+ old y := y
+END PROC move;
+
+PROC do move (INT CONST x,y):
+ IF x <> real old x OR
+ y <> real old y
+ THEN real old x := x;
+ real old y := y;
+ move to (x,y)
+ FI;
+ old x := x;
+ old y := y
+END PROC do move;
+
+PROC move (REAL CONST x, y) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (x, y, 0.0, h, v);
+ move (h, v);
+ pos := POS : (x, y, 0.0)
+END PROC move;
+
+PROC move (REAL CONST x, y, z) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (x, y, z, h, v);
+ move (h, v);
+ pos := POS : (x, y, z)
+END PROC move;
+
+PROC move r (REAL CONST x, y) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (pos.x+x, pos.y+y, pos.z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC move r;
+
+PROC move r (REAL CONST x, y, z) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ move (h, v);
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC move r;
+
+PROC move cm (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ h := int (x cm*hor relation+0.5);
+ v := int (y cm*vert relation+0.5);
+ move (h, v)
+END PROC move cm;
+
+PROC move cm r (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN maxima.last := maxima.akt FI;
+
+ h INCR int (x cm*hor relation+0.5);
+ v INCR int (y cm*vert relation+0.5);
+ move (h, v)
+END PROC move cm r;
+
+(************************** DRAW - Prozeduren ******************************)
+
+PROC draw (INT CONST x,y):
+ draw (old x,old y,x,y)
+END PROC draw;
+
+PROC draw (INT CONST x0,y0,x1,y1):
+ IF thick = 0
+ THEN line (x0, y0,x1,y1)
+ ELSE old x := x0;
+ old y := y0;
+ draw thick line (x1,y1)
+ FI;
+ old x := x1;
+ old y := y1
+END PROC draw;
+
+PROC draw (REAL CONST x, y) :
+ IF hidden
+ THEN transform (x, y, 0.0, new h, new v);
+ vector (new h-h, new v-v)
+ ELSE transform (x, y, 0.0, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (x, y, 0.0)
+END PROC draw;
+
+PROC draw (REAL CONST x, y, z) :
+ IF hidden
+ THEN transform (x, y, z, new h, new v);
+ vector (new h-h, new v-v)
+ ELSE transform (x, y, z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (x, y, z)
+END PROC draw;
+
+PROC draw r (REAL CONST x, y) :
+ IF hidden
+ THEN transform (pos.x+x, pos.y+y, pos.z, h, v);
+ vector (new h-h, new v-v)
+ ELSE transform (pos.x+x, pos.y+y, pos.z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (pos.x+x, pos.y+y, pos.z)
+END PROC draw r;
+
+PROC draw r (REAL CONST x, y, z) :
+ IF hidden
+ THEN transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ vector (new h-h, new v-v)
+ ELSE transform (pos.x+x, pos.y+y, pos.z+z, h, v);
+ draw (h, v)
+ FI;
+ pos := POS : (pos.x+x, pos.y+y, pos.z+z)
+END PROC draw r;
+
+PROC draw cm (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN vector (int (x cm*hor relation+0.5)-h, int (y cm*vert relation+0.5)-v)
+ ELSE h := int (x cm*hor relation+0.5);
+ v := int (y cm*vert relation+0.5);
+ draw (h, v)
+ FI
+END PROC draw cm;
+
+PROC draw cm r (REAL CONST x cm, y cm) :
+ IF hidden
+ THEN vector (int (x cm*hor relation+0.5), int (y cm*vert relation+0.5))
+ ELSE h INCR int (x cm*hor relation+0.5);
+ v INCR int (y cm*vert relation+0.5);
+ draw (h, v)
+ FI
+END PROC draw cm r;
+
+(*************************** LINIEN zeichnen *******************************)
+
+PROC line (INT CONST x0,y0,x1,y1):
+ REAL VAR x0r :: real (x0),
+ y0r :: real (y0),
+ x1r :: real (x1),
+ y1r :: real (y1);
+ IF clipped line (x0r,y0r,x1r,y1r)
+ THEN IF ltype > 1
+ THEN draw special line(int(x0r),int(y0r),int(x1r),int(y1r))
+ ELIF ltype = 1
+ THEN do move (int(x0r),int(y0r));
+ draw std line (int(x1r),int(y1r))
+ FI
+ FI
+END PROC line;
+
+PROC draw std line (INT CONST x,y):
+ old x := x;
+ old y := y;
+ real old x := x;
+ real old y := y;
+ draw to (x,y)
+END PROC draw std line;
+
+PROC draw special line (INT CONST x0,y0,x1,y1):
+ IF x0 = x1
+ THEN vertical line
+ ELIF y0 = y1
+ THEN horizontal line
+ ELIF abs(x1-x0) > abs(y1 - y0)
+ THEN steile linie
+ ELSE flache linie
+ FI.
+
+ vertical line:
+ INT VAR steps :: abs(y1 - y0),
+ sig :: sign(y1-y0),
+ i;
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0,y0+i*sig)
+ FI
+ PER.
+
+ horizontal line:
+ steps := abs(x1 - x0);
+ sig := sign(x1 - x0);
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0+i*sig,y0)
+ FI
+ PER.
+
+ steile linie:
+ steps := abs(x1 - x0);
+ sig := sign(x1 - x0);
+ REAL VAR m :: real(y1 - y0) / real(x1 - x0);
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0+sig*i,y0+int(m*real(sig*i) + 0.5))
+ FI
+ PER.
+
+ flache linie:
+ steps := abs(y1 - y0);
+ sig := sign(y1 - y0);
+ m := real(x1 - x0) / real(y1 - y0);
+ FOR i FROM 0 UPTO steps REP
+ IF next pixel
+ THEN set pixel(x0+int(m*real(sig*i) + 0.5),y0+sig*i)
+ FI
+ PER.
+
+ next pixel:
+ BOOL VAR is set :: (muster SUB cnt) <> "0";
+ cnt INCR 1;
+ IF cnt > lentxt THEN cnt := 1 FI;
+ is set
+END PROC drawspecialline;
+
+PROC draw thick line (INT CONST x1,y1):
+ INT VAR x0 :: old x,
+ y0 :: old y,
+ x :: x1,
+ y :: y1;
+ swap if neccessary;
+ REAL VAR xr0 :: real(x0),
+ yr0 :: real(y0) / (x cm * real(y pixel)) *
+ (y cm * real(x pixel)),
+ xr1 :: real(x),
+ yr1 :: real(y) / (x cm * real(y pixel)) *
+ (y cm * real(x pixel));
+ IF is vertical line
+ THEN draw vertical line
+ ELSE draw line
+ FI;
+ move(x1,y1).
+
+ swap if neccessary:
+ IF x < x0 OR (x = x0 AND y < y0)
+ THEN INT VAR dummy :: x0;
+ x0 := x;
+ x := dummy;
+ dummy := y0;
+ y0 := y;
+ y := dummy
+ FI.
+
+ is vertical line:
+ x = x0.
+
+ draw vertical line:
+ INT VAR i;
+ FOR i FROM - thick UPTO thick REP
+ cnt := 0;
+ line (xr0+real(i),yr0-real(thick),xr0+real(i),yr1+real(thick))
+ PER.
+
+ draw line:
+ REAL VAR m :: (yr1 - yr0) / (xr1 - xr0),
+ dx :: real(thick)/sqrt(1.0+m**2),
+ dy :: m * dx,
+ xn,
+ yn,
+ diff,
+ dsx :: dy,
+ dsy :: -dx,
+ x incr :: -real(sign(dsx)),
+ y incr :: -real(sign(dsy));
+ xr0 INCR -dx;
+ yr0 INCR -dy;
+ xr1 INCR dx;
+ yr1 INCR dy;
+ xn := xr0 + dsx;
+ yn := yr0 + dsy;
+ REP
+ line(xn,yn,xr1 - xr0 + xn,yr1 - yr0 + yn);
+ diff := (2.0*dsy *(xn - (xr0 - dy)) - 2.0 * dsx * (yn - (yr0 + dx)))
+ * real(sign(m));
+ IF diff < 0.0
+ THEN xn INCR x incr
+ ELIF diff > 0.0
+ THEN yn INCR y incr
+ ELSE xn INCR x incr;
+ yn INCR y incr
+ FI
+ UNTIL int(xn - xr0 + dy) = 0 AND int(yn - yr0 - dx) = 0 PER
+
+END PROC draw thick line;
+
+PROC line (REAL CONST x0,y0,x1,y1):
+ line (int(x0),int(y0 * (x cm * real(y pixel)) / (y cm * real(x pixel))),
+ int(x1),int(y1 * (x cm * real(y pixel)) / (y cm * real(x pixel))))
+END PROC line ;
+
+(*************************** HIDDEN LINES **********************************)
+
+PROC hidden lines (BOOL CONST dev):
+ hidden := NOT dev;
+END PROC hidden lines;
+
+PROC vector (INT CONST dx, dy):
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (v, h, dy, dx, 1, 1)
+ ELIF dy > 0 THEN vector (h, v, dx, dy, 1, 1)
+
+ ELIF dy > -dx THEN vector (h, v, dx, -dy, 1,-1)
+ ELSE vector (v, h, -dy, dx,-1, 1) FI
+
+ ELSE IF dy > -dx THEN vector (v, h, dy, -dx, 1,-1)
+ ELIF dy > 0 THEN vector (h, v, -dx, dy,-1, 1)
+
+ ELIF dy > dx THEN vector (h, v, -dx, -dy,-1,-1)
+ ELSE vector (v, h, -dy, -dx,-1,-1) FI
+ FI .
+
+ENDPROC vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
+ INT VAR i;
+ prepare first step ;
+ draw point;
+ FOR i FROM 1 UPTO dx
+ REP do one step PER;
+
+ IF was visible
+ THEN draw (h, v) FI .
+
+
+prepare first step :
+ INT VAR up right error := dy - dx,
+ right error := dy,
+ old error := 0,
+ last h :: h, last v :: v;
+ BOOL VAR was visible :: visible .
+
+
+do one step:
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ draw point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ draw point ;
+ old error INCR right error .
+
+draw point :
+ IF was visible
+ THEN IF NOT visible
+ THEN draw (last h, last v);
+ was visible := FALSE
+ FI;
+ last h := h;
+ last v := v
+ ELSE IF visible
+ THEN move (h, v);
+ was visible := TRUE;
+ last h := h;
+ last v := v
+ FI
+ FI .
+
+visible:
+ IF h < 1 OR h > x pixel
+ THEN FALSE
+ ELSE IF maxima.akt [h] < v
+ THEN maxima.akt [h] := v FI;
+ v > maxima.last [h]
+ FI
+END PROC vector;
+
+PROC reset:
+ forget (ds);
+ ds := nilspace;
+ maxima := ds
+END PROC reset;
+
+(**************************** TEXT - Ausgabe *******************************)
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
+ zeichen := new zeichen;
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC reset zeichensatz:
+ zeichen := std zeichen
+END PROC reset zeichensatz;
+
+PROC draw char (INT CONST char no,REAL CONST x, y,REAL CONST y size,
+ x size, direction):
+ TEXT CONST character :: zeichen [char no];
+ INT VAR n :: 1, x0, y0, x1, y1;
+ INT CONST len :: length (character);
+ REAL CONST sindir :: sind(direction),
+ cosdir :: cosd(direction);
+ WHILE n < len
+ REP value (character, n, x0, y0, x1, y1);
+ REAL VAR xr0 :: real(x0),
+ yr0 :: real(y0),
+ xr1 :: real(x1),
+ yr1 :: real(y1);
+ transform (xr0, yr0, x, y, x size, y size, sindir,cosdir);
+ transform (xr1, yr1, x, y, x size, y size, sindir,cosdir);
+ draw (int(xr0), int (yr0 * x to y),
+ int(xr1),int(yr1 * x to y));
+ n INCR 4
+ PER .
+
+END PROC draw char;
+
+PROC value (TEXT CONST char, INT CONST n, INT VAR x0, y0, x1, y1):
+ x0 := val (code (char SUB n)); y0 := val (code (char SUB n+1));
+ x1 := val (code (char SUB n+2)); y1 := val (code (char SUB n+3));
+END PROC value;
+
+INT PROC val (INT CONST n):
+ IF n > 127
+ THEN -256 OR n
+ ELSE n FI
+END PROC val;
+
+PROC transform (REAL VAR x, y,REAL CONST x0, y0,REAL CONST x size, y size,
+ sindir,cosdir):
+ REAL CONST old x :: x, old y :: y;
+ REAL CONST dx :: x size / char x * old x * cosdir -
+ (y size-y base) / char y * old y * sindir,
+ dy :: (y size-y base) / char y * old y * cosdir +
+ x size / char x * old x * sindir;
+ x := x0 + dx;
+ y := y0 + dy
+END PROC transform;
+
+PROC draw text (REAL CONST x pos, y pos,TEXT CONST msg, REAL CONST angle,
+ REAL CONST height, width):
+ INT VAR i;
+ REAL VAR x :: x pos, y :: y pos,
+ x step :: cosd (angle)*width,
+ y step :: sind (angle)*width;
+ FOR i FROM 1 UPTO length (msg)
+ REP IF control char
+ THEN execute control char
+ ELSE execute normal char FI
+ PER .
+
+control char:
+ akt char < ""32"" .
+
+execute control char:
+ SELECT code (akt char) OF
+ CASE 1: home
+ CASE 2: right
+ CASE 3: up
+ CASE 7: out (""7"")
+ CASE 8: left
+ CASE 10: down
+ CASE 13: return
+ ENDSELECT .
+
+home:
+ x := x pos;
+ y := y pos .
+
+right:
+ x INCR x step; y INCR y step .
+
+up:
+ x INCR y step; y INCR x step .
+
+left:
+ x DECR x step; y DECR y step .
+
+down:
+ x DECR y step; y DECR x step .
+
+return:
+ x := x pos .
+
+execute normal char:
+ draw char (code (akt char), x, y, height, width,
+ angle);
+ x INCR x step;
+ y INCR y step .
+
+akt char:
+ msg SUB i .
+
+END PROC draw text;
+
+PROC draw (TEXT CONST msg):
+ draw (msg,0.0,5.0,5.0)
+END PROC draw;
+
+PROC draw (TEXT CONST msg,REAL CONST angle,REAL CONST heigth,width):
+ REAL CONST xr :: real(old x),
+ yr :: real(old y) * y to x;
+ draw text (xr,yr,msg,angle,heigth * real(x pixel) / x cm / 10.0,
+ width * real(x pixel) / x cm / 10.0)
+ (* heigth mm --> x punkte *)
+END PROC draw;
+
+(***************************** LINETYPES ***********************************)
+
+PROC linetype (INT CONST nummer,TEXT CONST lt):
+ IF nummer > 5 OR nummer < 2
+ THEN errorstop ("number out of range")
+ ELSE linetypes [nummer] := lt
+ FI
+END PROC linetype ;
+
+PROC reset linetypes :
+ linetype (2,"1100");
+ linetype (3,"11110000");
+ linetype (4,"1111111100000000");
+ linetype (5,"1111111100011000");
+END PROC reset linetypes ;
+
+(***************************** UTILIES *************************************)
+
+PROC where (REAL VAR x, y) :
+ x := pos.x; y := pos.y
+END PROC where;
+
+PROC where (REAL VAR x, y, z) :
+ x := pos.x; y := pos.y; z := pos.z
+END PROC where;
+
+PROC bar (REAL CONST hight, width, INT CONST pattern):
+ INT VAR zero x, zero y, end x, end y;
+ transform (0.0, 0.0, 0.0, zero x, zero y);
+ transform (width, hight, 0.0, end x, end y);
+ bar (h-(end x-zero x) DIV 2, v, end x-zero x, end y-zero y, pattern)
+END PROC bar;
+
+PROC bar (INT CONST from x, from y, width, hight, pattern):
+ INT CONST to x :: from x+width, to y :: from y+hight;
+ INT VAR x, y;
+ draw frame;
+ SELECT pattern OF
+ CASE empty: (* nothing to do *)
+ CASE half: half bar
+ CASE full: full bar
+ CASE horizontal: horizontal bar
+ CASE vertical: vertical bar
+ CASE cross: horizontal bar;
+ vertical bar
+ CASE diagonal right: diagonal right bar
+ CASE diagonal left: diagonal left bar
+ CASE diagonal both: diagonal both bar
+ OTHERWISE errorstop ("Unknown pattern") ENDSELECT .
+
+draw frame:
+ move (from x, from y);
+ draw (from x, to y);
+ draw (to x, to y);
+ draw (to x, from y);
+ draw (from x, from y).
+
+full bar:
+ FOR y FROM from y UPTO to y
+ REP move (from x, y);
+ draw (to x, y)
+ PER .
+
+half bar:
+ FOR y FROM from y UPTO to y
+ REP x := from x + 1 + (y AND 1);
+ WHILE x < to x
+ REP move (x, y);
+ draw (x, y);
+ x INCR 2
+ PER
+ PER .
+
+horizontal bar:
+ y := from y;
+ WHILE y < to y
+ REP move (from x, y);
+ draw (to x, y);
+ y INCR 5
+ PER .
+
+vertical bar:
+ x := from x + 5;
+ WHILE x < to x
+ REP move (x, from y);
+ draw (x, to y);
+ x INCR 5
+ PER .
+
+diagonal right bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (max (from x, to x-y-width+from y), max (from y, y));
+ draw (min (to x, from x+to y-y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+diagonal left bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (min (to x, to x-from y+y), max (from y, y));
+ draw (max (from x, from x+y+width-to y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+diagonal both bar:
+ y := from y-width+5;
+ WHILE y < to y
+ REP move (max (from x, to x-y-width+from y), max (from y, y));
+ draw (min (to x, from x+to y-y), min (to y, y+width));
+ move (min (to x, to x-from y+y), max (from y, y));
+ draw (max (from x, from x+y+width-to y), min (to y, y+width));
+ y INCR 5
+ PER .
+
+END PROC bar;
+
+PROC circle (REAL CONST r, from, to, INT CONST pattern):
+ REAL VAR t :: from; INT VAR i; i := pattern; (* sonst WARNUNG *)
+ WHILE t < to
+ REP transform (pos.x + r*cosd (t), pos.y + r*sind (t), 0.0, h, v);
+ draw (h, v);
+ t INCR 1.0
+ PER;
+ transform (pos.x, pos.y, 0.0, h, v);
+ draw (h, v) .
+
+END PROC circle;
+
+PROC box :
+ move (0,0);
+ draw (0,y pixel-1);
+ draw (x pixel-1, y pixel-1);
+ draw (x pixel-1, 0);
+ draw (0,0)
+END PROC box;
+
+END PACKET basis plot;
+
+(************************* Plot Spool Input/ Output ***********************)
+
+PACKET plot interface DEFINES (* Carsten Weinholz *)
+ (* V 1.1 02.07.87 *)
+ save ,
+ exists ,
+ erase ,
+ ALL ,
+ first ,
+ start ,
+ stop ,
+ halt ,
+ wait for halt ,
+ list ,
+ picfiles ,
+ generate plot manager:
+
+LET initfile = "GRAPHIK.Manager",
+ plot manager name= "PLOT" ,
+
+ picfiletype = 1102,
+
+ ack = 0,
+ false code = 6,
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ first code = 25,
+ start code = 26,
+ stop code = 27,
+ halt code = 28,
+ wait for halt code = 29;
+
+BOUND STRUCT (TEXT tname,user id,pass) VAR msg;
+
+DATASPACE VAR ds;
+
+INT VAR reply;
+THESAURUS VAR all myself picfiles;
+
+PROC first (TEXT CONST ds name, PLOTTER CONST plotter id):
+ call (first code, ds name + ""0"" + id name (plotter id), plot id (plotter id))
+END PROC first;
+
+PROC start (PLOTTER CONST plotter id):
+ call (start code, id name (plotter id), plot id (plotter id))
+END PROC start;
+
+PROC stop (PLOTTER CONST plotter id):
+ call (stop code, id name (plotter id), plot id (plotter id))
+END PROC stop;
+
+PROC halt (PLOTTER CONST plotter id):
+ call (halt code, id name (plotter id), plot id (plotter id))
+END PROC halt;
+
+PROC wait for halt (PLOTTER CONST plotter id):
+ call (wait for halt code, id name (plotter id), plot id (plotter id))
+END PROC wait for halt;
+
+PROC save (TEXT CONST ds name, PLOTTER CONST plotter id):
+ enable stop;
+ last param (ds name);
+ call (save code, ds name + ""0"" + id name (plotter id),
+ old (ds name), plot id (plotter id))
+END PROC save;
+
+PROC save (PICFILE CONST p, TEXT CONST pname, PLOTTER CONST plotter id):
+ enable stop;
+ DATASPACE VAR ds;
+ ds BECOMES p;
+ call (save code, pname + ""0"" + id name (plotter id), ds,
+ plot id (plotter id));
+END PROC save;
+
+OP BECOMES (DATASPACE VAR ds, PICFILE CONST p):
+ EXTERNAL 260
+END OP BECOMES;
+
+PROC save (THESAURUS CONST nameset, PLOTTER CONST plotter id):
+ TEXT VAR name;
+ INT VAR i :: 0;
+ get (nameset, name, i);
+ WHILE i > 0 REP
+ save (name, plotter id);
+ cout (i);
+ get (nameset, name, i)
+ PER
+END PROC save;
+
+BOOL PROC exists (TEXT CONST ds name, PLOTTER CONST plotter id):
+ INT VAR reply;
+ DATASPACE VAR ds :: nilspace;
+ BOUND TEXT VAR qname :: ds;
+ qname := ds name + ""0"" + id name (plotter id);
+ REP
+ call (plot id (plotter id), exists code, ds, reply)
+ UNTIL reply = false code OR reply = ack PER;
+ forget (ds);
+ reply = ack
+END PROC exists;
+
+PROC erase (TEXT CONST ds name,PLOTTER CONST plotter id):
+ call (erase code, ds name + ""0"" + id name (plotter id), plot id (plotter id))
+END PROC erase;
+
+PROC erase (THESAURUS CONST nameset, PLOTTER CONST plotter id):
+ TEXT VAR name;
+ INT VAR i :: 0;
+ get (nameset, name, i);
+ WHILE i > 0 REP
+ erase (name, plotter id);
+ cout (i);
+ get (nameset, name, i)
+ PER
+END PROC erase;
+
+THESAURUS OP ALL (PLOTTER CONST plotter id):
+ REP
+ forget (ds);
+ ds := nilspace;
+ msg := ds;
+ msg.tname := id name (plotter id);
+ msg.user id := "";
+ msg.pass := "";
+ call (plot id (plotter id), all code, ds, reply)
+ UNTIL reply = ack PER;
+ BOUND THESAURUS VAR result ds :: ds;
+ THESAURUS VAR result :: result ds;
+ forget (ds);
+ result
+END OP ALL;
+
+PROC list (FILE VAR f,PLOTTER CONST plotter id):
+ REP
+ forget (ds);
+ ds := nilspace;
+ msg := ds;
+ msg.tname := id name (plotter id);
+ msg.user id := "";
+ msg.pass := "";
+ call (plot id (plotter id), list code, ds, reply)
+ UNTIL reply = ack PER;
+ f := sequential file (modify, ds)
+END PROC list;
+
+PROC list (PLOTTER CONST plotter id):
+ FILE VAR list file;
+ list (list file, plotter id);
+ show (list file)
+END PROC list;
+
+THESAURUS PROC picfiles:
+ all myself picfiles := empty thesaurus;
+ do (PROC (TEXT CONST) insert if picfile,ALL myself);
+ all myself picfiles
+END PROC picfiles;
+
+PROC insert if picfile (TEXT CONST filename):
+ IF type (old (filename)) = picfiletype
+ THEN insert (all myself picfiles,filename)
+ FI
+END PROC insert if picfile;
+
+PROC generate plot manager:
+ TASK VAR plot manager;
+ IF exists (initfile)
+ THEN generate in background
+ ELSE errorstop ("""" + init file + """ existiert nicht")
+ FI.
+
+ generate in background:
+ begin (plot manager name,PROC init plot manager, plot manager);
+ INT VAR manager call;
+ DATASPACE VAR initspace;
+ TASK VAR order task;
+ REP
+ wait (initspace, manager call, order task)
+ UNTIL order task = plot manager PER;
+ initspace := old (initfile);
+ send (plot manager, ack, initspace);
+ say ("Plot-Manager wird generiert"13""10"");
+ say ("Bitte etwas Geduld..."13""10"");
+ REP
+ wait (initspace, manager call, order task)
+ UNTIL order task = plot manager PER;
+ forget (initspace);
+ say ("Plotmanager generiert !"13""10"")
+END PROC generate plot manager;
+
+PROC init plot manager:
+ DATASPACE VAR initspace :: nilspace;
+ INT VAR dummy;
+ call (father, fetch code, initspace, dummy);
+ copy (init space,init file);
+ insert (init file);
+ send (father,ack,initspace);
+ do ("plot manager");
+END PROC init plot manager;
+
+TASK PROC plot id (PLOTTER CONST plotter id):
+ IF plotter id = no plotter
+ THEN task (plot manager name)
+ ELSE station (plotter id)/plot manager name
+ FI
+END PROC plot id;
+
+TEXT PROC id name (PLOTTER CONST plotter id):
+ text (station (plotter id)) + "/" + text (channel (plotter id)) + "/" +
+ name (plotter id)
+END PROC id name;
+
+END PACKET plot interface;
+
+(************************* Plot Picture / Picfile *************************)
+
+PACKET plot DEFINES plot :
+
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ move cm key = 6,
+ draw cm key = 7,
+ move cm r key = 8,
+ draw cm r key = 9,
+ bar key = 10,
+ circle key = 11;
+
+LET postfix = ".PICFILE"
+
+INT VAR read pos;
+
+PROC plot (TEXT CONST name) :
+ PICFILE VAR p :: old (name);
+ IF channel <> channel (plotter) OR station (myself) <> station (plotter)
+ THEN save (name, plotter)
+ ELSE plot (p)
+ FI
+END PROC plot;
+
+PROC plot (PICFILE VAR p) :
+ IF channel <> channel (plotter) OR station(myself) <> station(plotter)
+ THEN save (p, name (myself) + "." + text (highest entry (ALL plotter))
+ + postfix, plotter)
+ ELSE direct plot
+ FI.
+
+ direct plot:
+ ROW 3 ROW 2 REAL VAR sizes;
+ ROW 2 ROW 2 REAL VAR limits;
+ ROW 4 REAL VAR angles;
+ ROW 2 REAL VAR obliques;
+ ROW 3 REAL VAR perspectives;
+ get values (p,sizes,limits,angles,obliques,perspectives);
+ set values (sizes,limits,angles,obliques,perspectives);
+ begin plot;
+ clear;
+ INT VAR i;
+ FOR i FROM 1 UPTO pictures (p)
+ REP PICTURE VAR act pic :: nilpicture;
+ to pic (p,i);
+ read picture (p,act pic);
+ IF pen (act pic) <> 0
+ THEN plot pic FI
+ PER;
+ end plot .
+
+ plot pic:
+ INT VAR colour, thickness, linetype;
+ BOOL VAR hidden;
+ selected pen (p,pen (act pic),colour,thickness,linetype,hidden);
+ pen (background (p),colour,thickness,linetype);
+ hidden lines (hidden);
+ plot (act pic).
+
+END PROC plot;
+
+PROC plot (PICTURE CONST p) :
+ IF channel <> channel (plotter) OR station (myself) <> station (plotter)
+ THEN errorstop ("PICTURES koennen nur direkt ausgegeben werden")
+ ELSE plot pic
+ FI.
+
+plot pic:
+ INT CONST pic length :: length (p);
+ TEXT CONST points :: subtext (text(p),5);
+ read pos := 0;
+ IF dim (p) = 2
+ THEN plot two dim pic
+ ELSE plot three dim pic FI .
+
+plot two dim pic:
+ WHILE read pos < pic length
+ REP plot two dim position PER .
+
+plot two dim position :
+ read pos INCR 1;
+ SELECT code (points SUB read pos) OF
+ CASE draw key : draw (next real, next real)
+ CASE move key : move (next real, next real)
+ CASE move r key : move r (next real, next real)
+ CASE draw r key : draw r (next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+plot three dim pic:
+ WHILE read pos < pic length
+ REP plot three dim position PER .
+
+plot three dim position :
+ read pos INCR 1;
+ SELECT code (points SUB read pos) OF
+ CASE draw key : draw (next real, next real, next real)
+ CASE move key : move (next real, next real, next real)
+ CASE move r key : move r (next real, next real, next real)
+ CASE draw r key : draw r (next real, next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+next real :
+ read pos INCR 8;
+ subtext (points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (points, read pos-1, read pos) ISUB 1 .
+
+next text :
+ INT CONST text length :: next int;
+ read pos INCR text length;
+ subtext (points, read pos-text length+1, read pos) .
+
+END PROC plot;
+
+END PACKET plot
diff --git a/app/mpg/1987/src/GRAPHIK.Turtle b/app/mpg/1987/src/GRAPHIK.Turtle new file mode 100644 index 0000000..7dcfff1 --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.Turtle @@ -0,0 +1,138 @@ +(**************************************************************************)
+(* *)
+(* MPG - Graphik - System *)
+(* *)
+(* Version 2.1 vom 10.09.1987 *)
+(* *)
+(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *)
+(* unter Verwendung der Standard-Graphik *)
+(* "Turtle-Graphik" geschrieben von B.Jegerlehner *)
+(* *)
+(**************************************************************************)
+(* *)
+(* Dieses Paket stellt eine LOGO-aehnliche *)
+(* 'Schildkroetengraphik' zur Verfuegung *)
+(* *)
+(**************************************************************************)
+PACKET turtle graphics DEFINES begin turtle,
+ end turtle,
+ forward ,
+ forward to ,
+ turn ,
+ turn to ,
+ pen up ,
+ pen down ,
+ pen ,
+ angle ,
+ get turtle :
+
+REAL VAR x pos,
+ y pos,
+ winkel;
+
+PICFILE VAR bild;
+PICTURE VAR pic;
+
+BOOL VAR direct,
+ pen status;
+
+PROC begin turtle:
+ direct := TRUE;
+ x pos := 0.0;
+ y pos := 0.0;
+ winkel := 0.0;
+ begin plot;
+ clear;
+ viewport (0.0, 1.0, 0.0, 1.0);
+ window (-500.0, 500.0, -500.0, 500.0);
+ pen up;
+ forward to (0.0, 0.0)
+END PROC begin turtle;
+
+PROC begin turtle (TEXT CONST picfile):
+ direct := FALSE;
+ bild := picture file (picfile);
+ pic := nilpicture;
+ x pos := 0.0;
+ y pos := 0.0;
+ winkel := 0.0;
+ pen up;
+ forward to (0.0,0.0)
+END PROC begin turtle;
+
+PROC end turtle:
+ IF direct
+ THEN end plot
+ ELSE ausgabe
+ FI.
+
+ ausgabe:
+ REAL VAR x cm,y cm;
+ INT VAR dummy;
+ put picture (bild,pic);
+ drawing area (x cm,y cm,dummy,dummy);
+ viewport (bild, 0.0, 1.0, 0.0, 1.0);
+ window (bild, -500.0,500.0,-500.0,500.0);
+ plot(bild)
+END PROC end turtle;
+
+PROC turn (REAL CONST w):
+ winkel := (winkel + w) MOD 360.0
+END PROC turn;
+
+PROC turn to (REAL CONST w):
+ winkel := w MOD 360.0
+END PROC turn to;
+
+REAL PROC angle:
+ winkel
+END PROC angle;
+
+PROC forward (REAL CONST len):
+ forward to (x pos + cosd (winkel) * len,
+ y pos + sind (winkel) * len)
+END PROC forward;
+
+PROC pen up:
+ pen status := FALSE
+END PROC pen up;
+
+PROC pen down:
+ pen status := TRUE
+END PROC pen down;
+
+BOOL PROC pen:
+ pen status
+END PROC pen;
+
+PROC forward to (REAL CONST x,y):
+ IF direct
+ THEN dir plot
+ ELSE pic plot
+ FI;
+ x pos := x;
+ y pos := y.
+
+ dir plot:
+ IF pen status
+ THEN draw (x,y)
+ ELSE move (x,y)
+ FI.
+
+ pic plot:
+ IF length (pic) > 1923
+ THEN put picture (bild,pic);
+ pic := nilpicture
+ FI;
+ IF pen status
+ THEN draw (pic,x,y)
+ ELSE move (pic,x,y)
+ FI
+END PROC forward to;
+
+PROC get turtle (REAL VAR x,y):
+ x := x pos;
+ y := y pos
+END PROC get turtle
+
+END PACKET turtle graphics
diff --git a/app/mpg/1987/src/GRAPHIK.list b/app/mpg/1987/src/GRAPHIK.list new file mode 100644 index 0000000..0ee6612 --- /dev/null +++ b/app/mpg/1987/src/GRAPHIK.list @@ -0,0 +1,22 @@ +GRAPHIK.list
+GRAPHIK.Install
+GRAPHIK.Basis
+GRAPHIK.Configurator
+GRAPHIK.Plot
+GRAPHIK.Manager
+GRAPHIK.Fkt
+GRAPHIK.Turtle
+ZEICHENSATZ
+FKT.help
+Muster
+std primitives
+matrix printer
+terminal plot
+DATAGRAPH 3.GCONF
+VIDEOSTAR 7.GCONF
+AMPEX 1-2/4-6.GCONF
+NEC P-3 15.GCONF
+WATANABE 9.GCONF
+VC 404 8.GCONF
+NEC P-9 HD.GCONF
+NEC P-9 MD.GCONF
diff --git a/app/mpg/1987/src/HRZPLOT.ELA b/app/mpg/1987/src/HRZPLOT.ELA new file mode 100644 index 0000000..b788187 --- /dev/null +++ b/app/mpg/1987/src/HRZPLOT.ELA @@ -0,0 +1,150 @@ +PACKET hrz plot DEFINES drawing area, {Autor: H. Indenbirken}
+ begin plot, {Stand: 16.01.85 }
+ end plot,
+ clear,
+ pen,
+ move,
+ draw:
+
+LET delete = 0, {Farbcodes}
+ std = 1,
+ red = 2,
+ green = 3,
+ blue = 4,
+ black = 5,
+ white = 6,
+
+ nothing = 0; {Linientypen}
+
+LET POS = STRUCT (INT x, y);
+
+FILE VAR tr;
+TEXT VAR dummy;
+INT VAR act thick :: 0, i;
+POS VAR pos :: POS : (0, 0);
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 39.1; y cm := 27.6;
+ x pixel := 3910; y pixel := 2760
+END PROC drawing area;
+
+PROC begin plot :
+ENDPROC begin plot ;
+
+PROC end plot :
+ENDPROC end plot ;
+
+PROC clear :
+ IF exists ("Plotter")
+ THEN put line (tr, "NEXT 1;")
+ ELSE init tr file FI;
+
+ pos := POS : (0, 0);
+ act thick := 0 .
+
+init tr file:
+ tr := sequential file (output, "Plotter");
+ put line (tr, "#XBA,BEN=7800017 0029 UHRZS012 Graphik#.");
+ put line (tr, "ECCO ");
+ put line (tr, "#ANFANG,GRAFIK");
+ put line (tr, "#ZEICHNE,PL(1,9),MOD.=ZCH123,DINAF.=3.2,AUSS.=0'0'4200'2970,STIFTE=1'2'3'4'5'6,DATEI=/");
+ put line (tr, "CLEAR;BOX;") .
+
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ set foreground;
+ set thickness .
+
+set foreground:
+ put line (tr, "PEN " + text (foreground) + ";") .
+
+set thickness:
+ act thick := thickness * 2 .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ put (tr, text (x) + "!" + text (y) + ";");
+ pos := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ IF act thick <> 0
+ THEN IF horizontal line
+ THEN thick y
+ ELSE thick x FI;
+ x MOVE y
+ ELSE put (tr, text (x) + "&" + text (y) + ";") FI;
+ pos := POS : (x, y) .
+
+horizontal line:
+ abs (pos.x-x) > abs (pos.y-y) .
+
+thick y:
+ INT VAR dy, old x :: pos.x-x ausgleich, new x :: x+x ausgleich;
+ old x MOVE pos.y;
+ new x DRAW y;
+ FOR dy FROM 1 UPTO act thick
+ REP old x MOVE pos.y+dy;
+ new x DRAW y+dy;
+ old x MOVE pos.y-dy;
+ new x DRAW y-dy;
+ PER .
+
+x ausgleich:
+ IF pos.x <= x
+ THEN act thick
+ ELSE -act thick FI .
+
+thick x:
+ INT VAR dx, old y :: pos.y-y ausgleich, new y :: y+y ausgleich;
+ pos.x MOVE old y;
+ x DRAW new y;
+ FOR dx FROM 1 UPTO act thick
+ REP pos.x+dx MOVE old y;
+ x+dx DRAW new y;
+ pos.x-dx MOVE old y;
+ x-dx DRAW new y;
+ PER .
+
+y ausgleich:
+ IF pos.y <= y
+ THEN act thick
+ ELSE -act thick FI .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+ put (tr, height symbol + angle symbol + " SYMB """ + double record + """;") .
+
+height symbol:
+ IF height = 0.0
+ THEN ""
+ ELSE "H" + text (height) FI .
+
+angle symbol:
+ IF angle = 0.0
+ THEN ""
+ ELSE "A" + text (angle) FI .
+
+double record:
+ dummy := record;
+ change all (dummy, """", """""");
+ dummy .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+OP MOVE (INT CONST x, y):
+ put (tr, text (x) + "!" + text (y) + ";")
+END OP MOVE;
+
+OP DRAW (INT CONST x, y):
+ put (tr, text (x) + "&" + text (y) + ";")
+END OP DRAW;
+
+END PACKET hrz plot
diff --git a/app/mpg/1987/src/INCRPLOT.ELA b/app/mpg/1987/src/INCRPLOT.ELA new file mode 100644 index 0000000..408ab5f --- /dev/null +++ b/app/mpg/1987/src/INCRPLOT.ELA @@ -0,0 +1,405 @@ +PACKET incremental plot DEFINES drawing area, { Autor: H. Indenbirken }
+ begin plot, { Stand: 07.09.84 }
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+ get cursor,
+
+ zeichensatz,
+ reset:
+
+LET max x = 511, {***** Bildschirm : 0-511 x 0-255*****}
+ max x plus 1 = 512,
+ max y = 255,
+
+ hor faktor = 22.21739, {***** x pixel / x cm *****}
+ vert faktor = 18.61314, {***** y pixel / y cm *****}
+
+
+ delete = 0, {Farbcodes}
+ std = 1,
+ black = 5,
+ white = 6,
+
+ nothing = 0, {Linientypen}
+ durchgehend = 1,
+ gepunktet = 2,
+ kurz gestrichelt = 3,
+ lang gestrichelt = 4,
+ strichpunkt = 5,
+
+ pen up = "U",
+ pen down = "D",
+ up = "8", {Richtungen}
+ up right = "9",
+ right = "6",
+ down right = "3",
+ down = "2",
+ down left = "1",
+ left = "4",
+ up left = "7";
+
+LET PEN = STRUCT (INT back, fore, thick, line, BOOL hidden);
+LET POS = STRUCT (INT x, y);
+LET ZEICHENSATZ = STRUCT (ROW 255 TEXT char, INT width, height);
+
+ROW max x plus 1 INT VAR akt maxima, last maxima;
+ZEICHENSATZ VAR zeichen;
+PEN VAR stift :: PEN : (black, white, 0, durchgehend, FALSE);
+POS VAR pos :: POS : (0, 0), start, end;
+TEXT VAR point :: "";
+INT VAR i, n, diff, up right error, right error, old error, from, to,
+ pattern pos :: 0, line pattern :: -1;
+BOOL VAR bit set :: TRUE;
+
+reset;
+zeichensatz ("STD Zeichensatz");
+
+PROC reset:
+ FOR i FROM 1 UPTO 512
+ REP last maxima [i] := -1;
+ akt maxima [i] := -1
+ PER
+END PROC reset;
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
+ zeichen := new zeichen;
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 23.0; y cm := 13.7; {***** Horizontale und vertikale *****}
+ {***** Gráe in Zentimetern. *****}
+ x pixel := 511; y pixel := 255 {***** Koordinaten des rechten *****}
+ {***** oberen Punktes. *****}
+END PROC drawing area;
+
+PROC begin plot :
+ {***** Graphikmodus einschalten *****}
+ out (""16"")
+ENDPROC begin plot ;
+
+PROC end plot :
+ {***** Graphikmodus ausschalten *****}
+ out (""0"")
+ENDPROC end plot ;
+
+PROC clear :
+ stift := PEN : (black, white, 0, durchgehend, FALSE);
+ pos := POS : (0, 0);
+ line pattern := -1;
+ pattern pos := 0;
+ point := "";
+
+ reset;
+ {***** neue Zeichenflche *****}
+ out ("P")
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ set background;
+ set foreground;
+ set thickness;
+ set linetype;
+ stift := PEN:(background, foreground, thickness, linetype, thickness<0) .
+
+set background:
+ {***** Hintergrundfarbe setzen *****} .
+
+set foreground:
+ {***** Stift auswhlen *****} .
+
+set thickness:
+ {***** Es wird ein breiterer Sift simuliert, indem jeder Punkt *****}
+ {***** dicker gezeichet wird. Mit 'stift.thick' wird angegeben, *****}
+ {***** aus wieviel Pixeln ein Punkt bestehen soll. In 'point' *****};
+ {***** stehen die Befehle, um einen dicken Punkt zu zeichnen. *****}
+ point := "";
+ i := 2;
+ WHILE i <= thickness
+ REP point CAT down left;
+ point CAT (i * right);
+ point CAT (i * up);
+ point CAT (i * left);
+ point CAT (i * down);
+ i INCR 2
+ PER;
+ point CAT (thickness DIV 2) * up right .
+
+set linetype:
+ {***** Falls das Endgert hardwaremáig verschieden Linientypen *****}
+ {***** besitzt, knnen diese hier angesteuert werden. Ansonsten *****}
+ {***** werden sie softwaremáig simuliert. *****}
+ pattern pos := 0;
+ SELECT linetype OF
+ CASE durchgehend : line pattern := -1
+ CASE gepunktet : line pattern := 21845
+ CASE kurz gestrichelt : line pattern := 3855
+ CASE lang gestrichelt : line pattern := 255
+ CASE strichpunkt : line pattern := 4351
+ OTHERWISE line pattern := linetype END SELECT .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ IF stift.hidden
+ THEN last maxima := akt maxima FI;
+
+ {***** Der Stift muss gehoben und ein Vektor zur Position (x,y) *****}
+ {***** gezeichnet werden. *****}
+ out (pen up);
+ IF right to left
+ THEN (x-pos.x) TIMESOUT right;
+ IF down to up
+ THEN (y-pos.y) TIMESOUT up
+ ELSE (pos.y-y) TIMESOUT down FI
+ ELSE (pos.x-x) TIMESOUT left;
+ IF down to up
+ THEN (y-pos.y) TIMESOUT up
+ ELSE (pos.y-y) TIMESOUT down FI
+ FI;
+
+ pos := POS : (x, y) .
+
+right to left: x > pos.x .
+down to up: y > pos.y .
+
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ {***** Der Stift muss gehoben und ein Vektor zur Position (x,y) *****}
+ {***** gezeichnet werden. *****}
+ vector (x-pos.x, y-pos.y);
+ pos := POS : (x, y) .
+
+END PROC draw;
+
+PROC vector (INT CONST dx , dy) :
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (pos.y, pos.x, dy, dx, 1, 1, up, up right)
+ ELIF dy > 0 THEN vector (pos.x, pos.y, dx, dy, 1, 1, right, up right)
+
+ ELIF dy > -dx THEN vector (pos.x, pos.y, dx,-dy, 1,-1, right, down right)
+ ELSE vector (pos.y, pos.x,-dy, dx,-1, 1, down, down right) FI
+
+ ELSE IF dy > -dx THEN vector (pos.y, pos.x, dy,-dx, 1,-1, up, up left)
+ ELIF dy > 0 THEN vector (pos.x, pos.y,-dx, dy,-1, 1, left, up left)
+
+ ELIF dy > dx THEN vector (pos.x, pos.y,-dx,-dy,-1,-1, left, down left)
+ ELSE vector (pos.y, pos.x,-dy,-dx,-1,-1, down, down left) FI
+ FI .
+
+ENDPROC vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, x step, y step,
+ TEXT CONST step right, step up) :
+ prepare first step ;
+ FOR i FROM 1 UPTO dx
+ REP do one step PER .
+
+prepare first step :
+ up right error := dy - dx;
+ right error := dy;
+ old error := 0;
+ IF visible (pos)
+ THEN out (pen down);
+ out (point)
+ ELSE out (pen up) FI .
+
+do one step:
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR x step;
+ y pos INCR y step;
+ check point;
+ out (step up);
+ out (point);
+ old error INCR upright error .
+
+do right step :
+ x pos INCR x step;
+ check point;
+ out (step right);
+ out (point);
+ old error INCR right error .
+
+check point :
+ { In Abhngigkeit vom Ergebnis der Prozedur 'visible' wird der *****}
+ { Stift gehoben oder gesenkt. *****}
+
+ IF visible (pos)
+ THEN out (pen down)
+ ELSE out (pen up) FI .
+
+END PROC vector;
+
+BOOL PROC visible (POS CONST pos) :
+ IF pos.x < 0 OR pos.x > max x OR pos.y < 0 OR pos.y > max y
+ THEN FALSE
+ ELSE pattern AND hidden FI .
+
+pattern:
+ bit set := bit (line pattern, pattern pos);
+ pattern pos := (pattern pos+1) AND 15;
+ bit set .
+
+hidden:
+ IF akt maxima [pos.x+1] < pos.y
+ THEN akt maxima [pos.x+1] := pos.y FI;
+
+ pos.y > last maxima [pos.x+1] .
+
+END PROC visible;
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+{**** Hier werden Texte mit dem Winkel 'angle',der Hhe 'height' und *****}
+{**** der Breite 'width' gezeichnet. Falls die Hardware dieses *****}
+{**** bereits ermglicht, so mssen die Variable 'zeichen' und die *****}
+{**** Prozedur Zeichensatz gelscht werden. Der Datenraum *****}
+{**** 'STD Zeichensatz' wird in diesem Fall nicht bentigt. *****}
+ BOOL CONST horizontal :: NOT (abs (angle) MOD 180.0 > 45.0 AND abs (angle) MOD 180.0 < 135.0);
+ INT CONST x fak :: character width, x step :: character x step,
+ y fak :: character height, y step :: character y step;
+ INT VAR x pos :: pos.x, y pos :: pos.y, i;
+ from := pos;
+
+ FOR i FROM 1 UPTO length (record)
+ REP draw character i PER;
+ move (from) .
+
+character width:
+ IF width <> 0.0
+ THEN int (hor faktor * width+0.5)
+ ELSE zeichen.width FI .
+
+character x step:
+ IF horizontal
+ THEN IF width <> 0.0
+ THEN int (cosd (angle) * hor faktor * width+0.5)
+ ELSE int (cosd (angle) * real (zeichen.width)+0.5) FI
+ ELSE IF width <> 0.0
+ THEN int (cosd (angle) * vert faktor * width+0.5)
+ ELSE int (cosd (angle) * real (zeichen.height)+0.5) FI
+ FI .
+
+character height:
+ IF height <> 0.0
+ THEN int (vert faktor * height+0.5)
+ ELSE zeichen.height FI .
+
+character y step:
+ IF horizontal
+ THEN IF height <> 0.0
+ THEN int (sind (angle) * vert faktor * height+0.5)
+ ELSE int (sind (angle) * real (zeichen.height)+0.5) FI
+ ELSE IF height <> 0.0
+ THEN int (sind (angle) * hor faktor * height+0.5)
+ ELSE int (sind (angle) * real (zeichen.width)+0.5) FI
+ FI .
+
+draw character i:
+ IF code (record SUB i) < 32
+ THEN steuerzeichen
+ ELSE normale zeichen FI .
+
+steuerzeichen:
+ SELECT code (record SUB i) OF
+ CASE 7: out (""0""7""16"")
+ CASE 13: x pos := pos.x; y pos := pos.y
+ END SELECT .
+
+normale zeichen:
+ TEXT CONST char :: zeichen.char [code (record SUB i)];
+ IF horizontal
+ THEN draw horizontal
+ ELSE draw vertical FI .
+
+draw vertical:
+ n := 3;
+ IF char <> ""
+ THEN move (((char ISUB 2)*y fak) DIV zeichen.height + x pos,
+ -((char ISUB 1)*x fak) DIV zeichen.width + y pos)
+ FI;
+ WHILE n <= length (char) DIV 2
+ REP IF (char ISUB n) < 0 OR (char ISUB n+1) < 0
+ THEN move (((char ISUB n+1)*y fak) DIV zeichen.height + x pos,
+ -((char ISUB n )*x fak) DIV zeichen.width + y pos)
+ ELSE draw (-((char ISUB n+1)*y fak) DIV zeichen.height + x pos,
+ ((char ISUB n )*x fak) DIV zeichen.width + y pos)
+ FI;
+ n INCR 2
+ PER;
+ x pos INCR x step;
+ y pos INCR y step .
+
+draw horizontal:
+ n := 3;
+ IF char <> ""
+ THEN move (-((char ISUB 1)*x fak) DIV zeichen.width + x pos,
+ -((char ISUB 2)*y fak) DIV zeichen.height + y pos)
+ FI;
+ WHILE n <= length (char) DIV 2
+ REP IF (char ISUB n) < 0 OR (char ISUB n+1) < 0
+ THEN move (-((char ISUB n )*x fak) DIV zeichen.width + x pos,
+ -((char ISUB n+1)*y fak) DIV zeichen.height + y pos)
+ ELSE draw (((char ISUB n )*x fak) DIV zeichen.width + x pos,
+ ((char ISUB n+1)*y fak) DIV zeichen.height + y pos)
+ FI;
+ n INCR 2
+ PER;
+ x pos INCR x step;
+ y pos INCR y step .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+ x := pos.x;
+ y := pos.y;
+ cursor on;
+ REP inchar (t);
+ SELECT code (t) OF
+ CASE 54: x INCR 1; out (right) {normaler Zehnerblock}
+ CASE 57: x INCR 1; y INCR 1; out (up right)
+ CASE 56: y INCR 1; out (up)
+ CASE 55: x DECR 1; y INCR 1; out (up left)
+ CASE 52: x DECR 1; out (left)
+ CASE 49: x DECR 1; y DECR 1; out (down left)
+ CASE 50: y DECR 1; out (down)
+ CASE 51: x INCR 1; y DECR 1; out (down right)
+ OTHERWISE leave get cursor ENDSELECT;
+ PER .
+
+cursor on:
+ {***** Der Graphische Cursor muss eingeschaltet werden *****};
+ out ("C") .
+
+cursor off:
+ {***** Der Graphische Cursor muss eingeschaltet werden *****};
+ out ("c") .
+
+leave get cursor:
+ cursor off;
+ out (pen up);
+ (x-pos.x) TIMESOUT left;
+ (y-pos.y) TIMESOUT right;
+
+ LEAVE get cursor .
+
+END PROC get cursor;
+
+END PACKET incremental plot;
diff --git a/app/mpg/1987/src/M20PLOT.ELA b/app/mpg/1987/src/M20PLOT.ELA new file mode 100644 index 0000000..ea7f905 --- /dev/null +++ b/app/mpg/1987/src/M20PLOT.ELA @@ -0,0 +1,419 @@ +PACKET m20 plot DEFINES drawing area, (*Autor: H. Indenbirken*)
+ begin plot, (*Stand: 18.11.84 *)
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+
+ cursor on, cursor off,
+ get cursor,
+
+ zeichensatz,
+ get screen, put screen:
+
+LET hor faktor = 22.21739, (****** x pixel / x cm ******)
+ vert faktor = 18.61314, (****** y pixel / y cm ******)
+
+ delete = 0, (*Farbcodes *)
+ std = 1,
+ black = 5,
+ white = 6,
+
+ nothing = 0, (*Linientypen *)
+ durchgehend = 1,
+ gepunktet = 2,
+ kurz gestrichelt = 3,
+ lang gestrichelt = 4,
+ strichpunkt = 5,
+
+ bit 14 = 16384;
+
+TYPE SCREEN = ROW 32 ROW 256 INT;
+LET POS = STRUCT (INT x, y);
+LET ZEICHENSATZ = STRUCT (ROW 255 TEXT char, INT width, height);
+
+ZEICHENSATZ VAR zeichen;
+BOOL VAR character defined :: FALSE;
+TEXT VAR act pen :: "P"1"L"255""255"",
+ cursor pos :: ""0"M"0""0""0""0""0"D"0""0""0""0""0"M"0""0""0""0""0"D"0""0""0""0"",
+ cursor line :: ""0"M"0""0""0""0""0"D"0""0""0""0""0"D"0""0""0""0"";
+INT VAR act thick :: 0, i;
+POS VAR pos :: POS : (0, 0);
+out (""16"" + act pen + ""9"");
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name) (* Hhe: 0.64 cm*)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);(* Breite: 0.40 cm*)
+ zeichen := new zeichen;
+ character defined := TRUE
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 22.0; y cm := 13.7;
+ x pixel := 511; y pixel := 255
+END PROC drawing area;
+
+PROC begin plot :
+ out (""9""16"");
+ENDPROC begin plot ;
+
+PROC end plot :
+ out (""9"");
+ENDPROC end plot ;
+
+PROC clear :
+ pos := POS : (0, 0);
+ act thick := 0;
+ act pen := "P"1"L"255""255"";
+ out ("CP"1"L"255""255"M"0""0""0""0"")
+
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ set foreground;
+ set thickness;
+ set linetype;
+ out (act pen) .
+
+set foreground:
+ IF foreground = delete
+ THEN act pen := "P"0""
+ ELIF foreground < 0
+ THEN act pen := "P"2""
+ ELSE act pen := "P"1"" FI .
+
+set thickness:
+ act thick := thickness .
+
+set linetype:
+ SELECT linetype OF
+ CASE nothing : act pen CAT "L"0""0""
+ CASE durchgehend : act pen CAT "L"255""255""
+ CASE gepunktet : act pen CAT "L"85""85""
+ CASE kurz gestrichelt : act pen CAT "L"15""15""
+ CASE lang gestrichelt : act pen CAT "L"255""0""
+ CASE strichpunkt : act pen CAT "L"255""16""
+ OTHERWISE act pen CAT "L" + intern (linetype) END SELECT .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ replace (vektor, 1, x);
+ replace (vektor, 2, y);
+
+ out ("M");
+ out (vektor);
+ pos := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ IF act thick <> 0
+ THEN IF horizontal line
+ THEN thick y
+ ELSE thick x FI;
+ x MOVE y
+ ELSE replace (vektor, 1, x);
+ replace (vektor, 2, y);
+ out ("D");
+ out (vektor)
+ FI;
+ pos := POS : (x, y) .
+
+horizontal line:
+ abs (pos.x-x) > abs (pos.y-y) .
+
+thick y:
+ INT VAR dy, old x :: pos.x-x ausgleich, new x :: x+x ausgleich;
+ old x MOVE pos.y;
+ new x DRAW y;
+ FOR dy FROM 1 UPTO act thick
+ REP old x MOVE pos.y+dy;
+ new x DRAW y+dy;
+ old x MOVE pos.y-dy;
+ new x DRAW y-dy;
+ PER .
+
+x ausgleich:
+ IF pos.x <= x
+ THEN act thick
+ ELSE -act thick FI .
+
+thick x:
+ INT VAR dx, old y :: pos.y-y ausgleich, new y :: y+y ausgleich;
+ pos.x MOVE old y;
+ x DRAW new y;
+ FOR dx FROM 1 UPTO act thick
+ REP pos.x+dx MOVE old y;
+ x+dx DRAW new y;
+ pos.x-dx MOVE old y;
+ x-dx DRAW new y;
+ PER .
+
+y ausgleich:
+ IF pos.y <= y
+ THEN act thick
+ ELSE -act thick FI .
+
+END PROC draw;
+
+INT VAR x fak :: zeichen.width,
+ y fak :: zeichen.height;
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+ IF act pen = "L"0""0""
+ THEN
+ ELIF character defined
+ THEN draw graphic character
+ ELSE out (""9"");
+ pos cursor (pos.x, pos.y);
+ get cursor (x pos, y pos);
+ outsubtext (record, 1, 79-y pos);
+ out (""16"")
+ FI .
+
+draw graphic character:
+(**** Hier werden Texte mit dem Winkel 'angle',der Hhe 'height' und ****)
+(**** der Breite 'width' gezeichnet. Die Form der Zeichen ist in der ****)
+(**** Datei 'STD Zeichensatz' enthalten. ****)
+ INT CONST x step :: character x step, y step :: character y step;
+ INT VAR x pos :: pos.x, y pos :: pos.y, i, n, x, y;
+ BOOL VAR move order;
+
+ set character height and width;
+ out ("L"255""255"");
+
+ FOR i FROM 1 UPTO length (record)
+ REP draw character i PER;
+ out (act pen);
+ pos.x MOVE pos.y .
+
+set character height and width:
+ IF width = 0.0 AND height = 0.0
+ THEN x fak := zeichen.width;
+ y fak := zeichen.height
+ ELSE x fak := int (hor faktor * width+0.5);
+ y fak := int (vert faktor * height+0.5)
+ FI .
+
+character x step:
+ IF width <> 0.0
+ THEN int (cosd (angle) * hor faktor * width+0.5)
+ ELSE int (cosd (angle) * real (zeichen.width)+0.5) FI .
+
+character y step:
+ IF height <> 0.0
+ THEN int (sind (angle) * vert faktor * height+0.5)
+ ELSE int (sind (angle) * real (zeichen.height)+0.5) FI .
+
+draw character i:
+ IF code (record SUB i) < 32
+ THEN steuerzeichen
+ ELSE normale zeichen FI .
+
+steuerzeichen:
+ SELECT code (record SUB i) OF
+ CASE 1: x pos := 0;
+ y pos := 255-y fak
+ CASE 2: x pos INCR x fak
+ CASE 3: y pos INCR y fak
+ CASE 4: out (""9""); pos cursor (x pos, y pos); out (""4""16"")
+ CASE 5: out (""9""); pos cursor (x pos, y pos); out (""5""16"")
+ CASE 7: out (""9""7""16"")
+ CASE 8: x pos DECR x fak
+ CASE 10: y pos DECR y fak
+ CASE 13: x pos := pos.x
+ END SELECT .
+
+normale zeichen:
+ TEXT CONST char :: zeichen.char [code (record SUB i)];
+ FOR n FROM 1 UPTO length (char) DIV 4
+ REP value (char, n, x, y, move order);
+ IF move order
+ THEN x pos+x MOVE y pos+y
+ ELSE x pos+x DRAW y pos+y FI
+ PER;
+ x pos INCR x step;
+ y pos INCR y step .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC value (TEXT CONST char, INT CONST n, INT VAR x, y, BOOL VAR move):
+ x := char ISUB n+n-1;
+ y := char ISUB n+n;
+ IF x < 0
+ THEN IF (x AND bit 14) <> 0
+ THEN move := FALSE
+ ELSE move := TRUE;
+ x := x XOR bit 14
+ FI
+ ELSE IF (x AND bit 14) <> 0
+ THEN move := TRUE;
+ x := x XOR bit 14
+ ELSE move := FALSE FI
+ FI;
+ x := (x*x fak) DIV zeichen.width;
+ y := (y*y fak) DIV zeichen.height
+
+END PROC value;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+ get cursor (t, x, y, -1, -1, -1, -1)
+END PROC get cursor;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1):
+ init cursor;
+ out ("P"2"");
+ REP set cursor;
+ get step;
+ out (cursor pos);
+ out (cursor line);
+ move cursor
+ PER .
+
+init cursor:
+ INT VAR delta :: 1;
+ x := pos.x;
+ y := pos.y;
+
+ IF x0 >= 0 AND x0 <= 511 AND y0 >= 0 AND y0 <= 255
+ THEN replace (cursor line, 2, "M");
+ replace (cursor line, 2, x0);
+ replace (cursor line, 3, y0);
+ replace (cursor line, 8, "D")
+ ELSE replace (cursor line, 2, ""0""0""0""0""0""0"M") FI;
+
+ IF x1 >= 0 AND x1 <= 511 AND y1 >= 0 AND y1 <= 255
+ THEN replace (cursor line,14, "D");
+ replace (cursor line, 8, x1);
+ replace (cursor line, 9, y1);
+ ELSE replace (cursor line,14, ""0""0""0""0""0"") FI .
+
+get step:
+ t := incharety (1);
+ IF t <> ""
+ THEN IF delta < 10
+ THEN delta INCR delta
+ ELSE delta INCR 1 FI
+ ELSE delta := 1;
+ inchar (t)
+ FI .
+
+move cursor:
+ SELECT code (t) OF
+ CASE 2 : x INCR delta (*normaler Zehnerblock*)
+ CASE 19: x INCR delta; y INCR delta
+ CASE 3 : y INCR delta
+ CASE 18: x DECR delta; y INCR delta
+ CASE 8 : x DECR delta
+ CASE 14: x DECR delta; y DECR delta
+ CASE 10: y DECR delta
+ CASE 15: x INCR delta; y DECR delta
+ OTHERWISE leave get cursor ENDSELECT;
+ check .
+
+set cursor:
+ replace (cursor pos, 2, x-4); replace (cursor pos, 3, y);
+ replace (cursor pos, 5, x+4); replace (cursor pos, 6, y);
+ replace (cursor pos, 8, x); replace (cursor pos, 9, y-4);
+ replace (cursor pos,11, x); replace (cursor pos,12, y+4);
+ out (cursor pos);
+
+ replace (cursor line, 5, x); replace (cursor line, 6, y);
+ out (cursor line) .
+
+leave get cursor:
+ out (act pen);
+ pos.x MOVE pos.y;
+
+ LEAVE get cursor .
+
+check :
+ IF x < 0
+ THEN x := 0;
+ out (""9""7""16"")
+ ELIF x > 511
+ THEN x := 511;
+ out (""9""7""16"")
+ FI;
+ IF y < 0
+ THEN y := 0;
+ out (""9""7""16"")
+ ELIF y > 255
+ THEN y := 255;
+ out (""9""7""16"")
+ FI .
+
+END PROC get cursor;
+
+PROC cursor on (INT CONST x, y):
+ out ("P"2"");
+ replace (cursor pos, 2, x-4); replace (cursor pos, 3, y);
+ replace (cursor pos, 5, x+4); replace (cursor pos, 6, y);
+ replace (cursor pos, 8, x); replace (cursor pos, 9, y-4);
+ replace (cursor pos,11, x); replace (cursor pos,12, y+4);
+ out (cursor pos)
+
+END PROC cursor on;
+
+PROC cursor off:
+ out ("P"2"");
+ out (cursor pos);
+ out (act pen);
+ pos.x MOVE pos.y
+END PROC cursor off;
+
+(* Bildwiederholspeicheraufbau der M20: *)
+(* 32 Blcke (0...31) enthalten jeweils 8 Microzeilen. Die Bitbelegung *)
+(* eines Blocks von 256 INT ist 7654321FEDCBA98. *)
+
+PROC get screen (DATASPACE VAR ds, INT CONST page):
+ INT VAR i, n, begin :: 32*page;
+ FOR i FROM 0 UPTO 31
+ REP block in (ds, begin+i, -1, i, n) PER
+END PROC get screen;
+
+PROC put screen (DATASPACE CONST ds, INT CONST page):
+ INT VAR i, n, begin :: 32*page;
+ FOR i FROM 0 UPTO 31
+ REP block out (ds, begin+i, -1, i, n) PER
+END PROC put screen;
+
+TEXT VAR conv :: ""0""0"";
+TEXT PROC intern (INT CONST n):
+ replace (conv, 1, n);
+ conv
+END PROC intern;
+
+TEXT VAR vektor :: ""0""0""0""0"";
+OP MOVE (INT CONST x, y):
+ replace (vektor, 1, x);
+ replace (vektor, 2, y);
+
+ out ("M");
+ out (vektor)
+END OP MOVE;
+
+OP DRAW (INT CONST x, y):
+ replace (vektor, 1, x);
+ replace (vektor, 2, y);
+
+ out ("D");
+ out (vektor)
+END OP DRAW;
+
+PROC pos cursor (INT CONST x, y):
+ cursor ((x-10) DIV 6, (237-y) DIV 10)
+END PROC pos cursor;
+
+END PACKET m20 plot
+
+IF exists ("ZEICHEN 6*10")
+THEN zeichensatz ("ZEICHEN 6*10")
+ELIF exists ("ZEICHEN 9*12")
+THEN zeichensatz ("ZEICHEN 9*12")
+ELSE put line ("Warnung: Zeichensatz fehlt") FI
diff --git a/app/mpg/1987/src/MTRXPLOT.ELA b/app/mpg/1987/src/MTRXPLOT.ELA new file mode 100644 index 0000000..4068866 --- /dev/null +++ b/app/mpg/1987/src/MTRXPLOT.ELA @@ -0,0 +1,416 @@ +PACKET matrix plot DEFINES drawing area,
+ begin plot,
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+ get cursor,
+
+ zeichensatz,
+ reset,
+ SCREEN, :=,
+ get screen, put screen:
+
+LET max x = 511, {Bildschirm : 1-512 x 1-256}
+ max x plus 1 = 512,
+ max y = 255,
+
+ hor faktor = 22.21739, {***** x pixel / x cm *****}
+ vert faktor = 18.61314, {***** y pixel / y cm *****}
+
+
+ delete = 0, {Farbcodes}
+ std = 1,
+ black = 5,
+ white = 6,
+
+ durchgehend = 1, {Linientypen}
+ gepunktet = 2,
+ kurz gestrichelt = 3,
+ lang gestrichelt = 4,
+ strichpunkt = 5;
+
+
+LET PEN = STRUCT (INT back, fore, thick, line, BOOL hidden, action);
+LET POS = STRUCT (INT x, y);
+TYPE SCREEN = ROW 32 ROW 256 INT;
+LET ZEICHENSATZ = STRUCT (ROW 255 TEXT char, INT width, height);
+
+ROW max x plus 1 INT VAR akt maxima, last maxima;
+ZEICHENSATZ VAR zeichen;
+SCREEN VAR screen;
+PEN VAR stift :: PEN : (black, white, 0, durchgehend, FALSE, TRUE);
+POS VAR pos :: POS : (0, 0), start, delta;
+INT VAR i, n, diff, up right error, right error, old error,
+ pattern pos :: 0, line pattern :: -1;
+BOOL VAR bit set :: TRUE;
+
+reset;
+zeichensatz ("STD Zeichensatz");
+clear (screen);
+
+PROC reset:
+ FOR i FROM 1 UPTO 512
+ REP last maxima [i] := -1;
+ akt maxima [i] := -1
+ PER
+END PROC reset;
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name)
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name);
+ zeichen := new zeichen
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 23.0; y cm := 13.7; {***** Horizontale und vertikale *****}
+ {***** Gráe in Zentimetern. *****}
+ x pixel := 511; y pixel := 255 {***** Koordinaten des rechten *****}
+ {***** oberen Punktes. *****}
+END PROC drawing area;
+
+PROC begin plot :
+ENDPROC begin plot ;
+
+PROC end plot :
+ENDPROC end plot ;
+
+PROC clear :
+ stift := PEN : (black, white, 0, durchgehend, FALSE, TRUE);
+ pos := POS : (0, 0);
+
+(* Lschen der Hiddenmaxima *);
+ reset;
+
+(* Ausgabe der Bildmatrix auf dem Endgert *);
+ put screen;
+
+(* Lschen der Bildmatrix *);
+ clear (screen)
+
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ set linetype;
+ stift := PEN : (background, foreground,thickness, linetype,
+ linetype <> 0, thickness < 0) .
+
+set linetype:
+ pattern pos := 0;
+ SELECT linetype OF
+ CASE durchgehend : stift.line := -1
+ CASE gepunktet : stift.line := 21845
+ CASE kurz gestrichelt : stift.line := 3855
+ CASE lang gestrichelt : stift.line := 255
+ CASE strichpunkt : stift.line := 4351
+ OTHERWISE stift.line := linetype END SELECT;
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ pattern pos := 0;
+ IF stift.hidden
+ THEN last maxima := akt maxima FI;
+
+ pos := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ IF stift.action
+ THEN IF stift.thick > 1
+ THEN draw thick vektor
+ ELSE vector (x-pos.x, y-pos.y) FI
+ FI;
+ pos := POS : (x, y) .
+
+draw thick vektor:
+ INT CONST old pattern pos := pattern pos;
+ check direction;
+ FOR diff FROM -stift.thick UPTO stift.thick
+ REP draw single vektor PER .
+
+check direction :
+ BOOL CONST x direction := abs (x-pos.x) > abs (y-pos.y);
+ IF x direction
+ THEN start := POS : (pos.x+stift.thick * sign (pos.x-x), pos.y);
+ delta := POS : (x+stift.thick * sign (x-pos.x)-pos.x, y-pos.y)
+ ELSE start := POS : (pos.x, pos.y+stift.thick * sign (pos.y-y));
+ delta := POS : (x-pos.x, y+stift.thick * sign (y-pos.y)-pos.y);
+ FI .
+
+draw single vektor :
+ pattern pos := old pattern pos;
+ IF x direction
+ THEN pos := POS : (start.x, start.y+diff);
+ vector (delta.x, delta.y+diff)
+ ELSE pos := POS : (start.x+diff, start.y+diff);
+ vector (delta.x+diff, delta.y)
+ FI .
+
+END PROC draw;
+
+PROC vector (INT CONST dx , dy) :
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (pos.y, pos.x, dy, dx, 1, 1)
+ ELIF dy > 0 THEN vector (pos.x, pos.y, dx, dy, 1, 1)
+
+ ELIF dy > -dx THEN vector (pos.x, pos.y, dx, -dy, 1,-1)
+ ELSE vector (pos.y, pos.x, -dy, dx,-1, 1) FI
+
+ ELSE IF dy > -dx THEN vector (pos.y, pos.x, dy, -dx, 1,-1)
+ ELIF dy > 0 THEN vector (pos.x, pos.y, -dx, dy,-1, 1)
+
+ ELIF dy > dx THEN vector (pos.x, pos.y, -dx, -dy,-1,-1)
+ ELSE vector (pos.y, pos.x, -dy, -dx,-1,-1) FI
+ FI .
+
+ENDPROC vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
+ prepare first step ;
+ point;
+ FOR i FROM 1 UPTO dx
+ REP do one step PER .
+
+prepare first step :
+ up right error := dy - dx;
+ right error := dy;
+ old error := 0 .
+
+do one step:
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ point ;
+ old error INCR right error .
+
+point :
+ IF visible (pos)
+ THEN SELECT (pos.x+1) MOD 16 OF
+ CASE 0: set bit (block [byte], 8)
+ CASE 1: set bit (block [byte], 7)
+ CASE 2: set bit (block [byte], 6)
+ CASE 3: set bit (block [byte], 5)
+ CASE 4: set bit (block [byte], 4)
+ CASE 5: set bit (block [byte], 3)
+ CASE 6: set bit (block [byte], 2)
+ CASE 7: set bit (block [byte], 1)
+ CASE 8: set bit (block [byte], 0)
+ CASE 9: set bit (block [byte], 15)
+ CASE 10: set bit (block [byte], 14)
+ CASE 11: set bit (block [byte], 13)
+ CASE 12: set bit (block [byte], 12)
+ CASE 13: set bit (block [byte], 11)
+ CASE 14: set bit (block [byte], 10)
+ CASE 15: set bit (block [byte], 9)
+ END SELECT;
+ FI .
+
+block:
+ screen [(255-pos.y) DIV 8 + 1] .
+
+byte:
+ pos.x DIV 16 + ((255-pos.y) AND 7) * 32 + 1 .
+
+END PROC vector;
+
+BOOL PROC visible (POS CONST pos) :
+ IF pos.x < 0 OR pos.x > max x OR pos.y < 0 OR pos.y > max y
+ THEN FALSE
+ ELSE pattern AND hidden FI .
+
+pattern:
+ bit set := bit (line pattern, pattern pos);
+ pattern pos := (pattern pos+1) AND 15;
+ bit set .
+
+hidden:
+ IF akt maxima [pos.x+1] < pos.y
+ THEN akt maxima [pos.x+1] := pos.y FI;
+
+ pos.y > last maxima [pos.x+1] .
+
+END PROC visible;
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+{**** Hier werden Texte mit dem Winkel 'angle',der Hhe 'height' und *****}
+{**** der Breite 'width' gezeichnet. Falls die Hardware dieses *****}
+{**** bereits ermglicht, so mssen die Variable 'zeichen' und die *****}
+{**** Prozedur Zeichensatz gelscht werden. Der Datenraum *****}
+{**** 'STD Zeichensatz' wird in diesem Fall nicht bentigt. *****}
+ BOOL CONST horizontal :: NOT (abs (angle) MOD 180.0 > 45.0 AND abs (angle) MOD 180.0 < 135.0);
+ INT CONST x fak :: character width, x step :: character x step,
+ y fak :: character height, y step :: character y step;
+ INT VAR x pos :: pos.x, y pos :: pos.y, i;
+ POS VAR old pos := pos;
+
+ FOR i FROM 1 UPTO length (record)
+ REP draw character i PER;
+ pos := old pos .
+
+character width:
+ IF width <> 0.0
+ THEN int (hor faktor * width+0.5)
+ ELSE zeichen.width FI .
+
+character x step:
+ IF horizontal
+ THEN IF width <> 0.0
+ THEN int (cosd (angle) * hor faktor * width+0.5)
+ ELSE int (cosd (angle) * real (zeichen.width)+0.5) FI
+ ELSE IF width <> 0.0
+ THEN int (cosd (angle) * vert faktor * width+0.5)
+ ELSE int (cosd (angle) * real (zeichen.height)+0.5) FI
+ FI .
+
+character height:
+ IF height <> 0.0
+ THEN int (vert faktor * height+0.5)
+ ELSE zeichen.height FI .
+
+character y step:
+ IF horizontal
+ THEN IF height <> 0.0
+ THEN int (sind (angle) * vert faktor * height+0.5)
+ ELSE int (sind (angle) * real (zeichen.height)+0.5) FI
+ ELSE IF height <> 0.0
+ THEN int (sind (angle) * hor faktor * height+0.5)
+ ELSE int (sind (angle) * real (zeichen.width)+0.5) FI
+ FI .
+
+draw character i:
+ IF code (record SUB i) < 32
+ THEN steuerzeichen
+ ELSE normale zeichen FI .
+
+steuerzeichen:
+ SELECT code (record SUB i) OF
+ CASE 7: out (""0""7""16"")
+ CASE 13: x pos := pos.x; y pos := pos.y
+ END SELECT .
+
+normale zeichen:
+ TEXT CONST char :: zeichen.char [code (record SUB i)];
+ IF horizontal
+ THEN draw horizontal
+ ELSE draw vertical FI .
+
+draw vertical:
+ n := 3;
+ IF char <> ""
+ THEN pos := POS : (((char ISUB 2)*y fak) DIV zeichen.height + x pos,
+ -((char ISUB 1)*x fak) DIV zeichen.width + y pos)
+ FI;
+ WHILE n <= length (char) DIV 2
+ REP IF (char ISUB n) < 0 OR (char ISUB n+1) < 0
+ THEN pos := POS : (((char ISUB n+1)*y fak) DIV zeichen.height + x pos,
+ -((char ISUB n )*x fak) DIV zeichen.width + y pos)
+ ELSE vector (-((char ISUB n+1)*y fak) DIV zeichen.height + x pos-pos.x,
+ ((char ISUB n )*x fak) DIV zeichen.width + y pos-pos.y)
+ FI;
+ n INCR 2
+ PER;
+ x pos INCR x step;
+ y pos INCR y step .
+
+draw horizontal:
+ n := 3;
+ IF char <> ""
+ THEN pos := POS : (-((char ISUB 1)*x fak) DIV zeichen.width + x pos,
+ -((char ISUB 2)*y fak) DIV zeichen.height + y pos)
+ FI;
+ WHILE n <= length (char) DIV 2
+ REP IF (char ISUB n) < 0 OR (char ISUB n+1) < 0
+ THEN pos := POS : (-((char ISUB n )*x fak) DIV zeichen.width + x pos,
+ -((char ISUB n+1)*y fak) DIV zeichen.height + y pos)
+ ELSE vector (((char ISUB n )*x fak) DIV zeichen.width + x pos-pos.x,
+ ((char ISUB n+1)*y fak) DIV zeichen.height + y pos-pos.y)
+ FI;
+ n INCR 2
+ PER;
+ x pos INCR x step;
+ y pos INCR y step .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+ t := "";
+ x := 0;
+ y := 0
+END PROC get cursor;
+
+OP := (SCREEN VAR l, SCREEN CONST r):
+ CONCR (l) := CONCR (r)
+END OP :=;
+
+PROC get screen (TEXT CONST name):
+ IF exists (name)
+ THEN get screen (old (name))
+ ELSE get screen (new (name)) FI;
+END PROC get screen;
+
+PROC get screen (DATASPACE CONST ds):
+ BOUND SCREEN VAR ds screen :: ds;
+ ds screen := screen
+END PROC get screen;
+
+PROC get screen (SCREEN VAR ds screen):
+ ds screen := screen
+END PROC get screen;
+
+PROC get screen:
+ FOR i FROM 1 UPTO 32
+ REP block in (screen [i], -1, i-1, n) PER
+END PROC get screen;
+
+PROC put screen (TEXT CONST name):
+ IF exists (name)
+ THEN put screen (old (name))
+ ELSE errorstop ("Der Datenraum """ + name + """ existiert nicht") FI
+END PROC put screen;
+
+PROC put screen (DATASPACE CONST ds):
+ BOUND SCREEN VAR ds screen :: ds;
+ screen := ds screen;
+ put screen
+END PROC put screen;
+
+PROC put screen (SCREEN VAR ds screen):
+ screen := ds screen;
+ put screen
+END PROC put screen;
+
+PROC put screen:
+ FOR i FROM 1 UPTO 32
+ REP block out (screen [i], -1, i-1, n) PER
+END PROC put screen;
+
+PROC clear (SCREEN VAR screen):
+ FOR i FROM 1 UPTO 256
+ REP screen [1] [i] := 0 PER;
+ FOR i FROM 2 UPTO 32
+ REP screen [i] := screen [1] PER
+END PROC clear;
+
+END PACKET matrix plot;
+
+
diff --git a/app/mpg/1987/src/Muster b/app/mpg/1987/src/Muster new file mode 100644 index 0000000..336e2ef --- /dev/null +++ b/app/mpg/1987/src/Muster @@ -0,0 +1,73 @@ +INCLUDE "Name der Include-Datei";
+
+PLOTTER "Plottername",<Station>,<Kanal>,<Xpixel>,<Ypixel>,<Xcm>,<Ycm>;
+
+LINK <Station>/<Kanal>,<Station>/<Kanal>....;
+
+COLORS "<RGB-Kombinationen als 3-Byte Codefolge>";
+
+ .
+ .
+ .
+<Hier koennen Endgeraetspezifische Prozeduren/Variablen (globalebene)
+ eingefuegt werden. Achtung! um Namenskonflikte mit globalobjekten
+ anderer Endgeraete zu vermeiden sollten die Namen dieser Objekte
+ auch stets den Endgeraet-Namen enthalten
+ (z.B. 'TEXT PROC videostar koordinaten (INT CONST x,y)')
+>
+
+PROC initplot:
+ Warnung: Da der Configurator den Prozedur-Rumpf in ein Refinement
+ verwandelt, muessen Namenskonflikte vermieden wrden !
+END PROC initplot;
+
+PROC endplot:
+END PROC endplot;
+
+PROC prepare:
+END PROC prepare;
+
+PROC clear:
+END PROC clear;
+
+PROC home:
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+END PROC setpixel;
+
+PROC foreground (INT CONST type):
+END PROC foreground;
+
+PROC background (INT CONST type):
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette:
+
+PROC circle (INT CONST x,y,rad,from,to):
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+END PROC fill;
+
+EDITOR; (* Durch EDITOR wird das optionale Vorhandensein nachfolgender
+ Editor-Befehle angezeigt *)
+
+PROC get cursor (INT VAR x,y,TEXT VAR exit char):
+END PROC get cursor;
+
+PROC graphik cursor (INT CONST x,y,BOOL CONST on):
+END PROC graphik cursor;
+
+PROC set marker (INT CONST x,y,type):
+END PROC set marker;
diff --git a/app/mpg/1987/src/NEC P-9 2-15.MD.GCONF b/app/mpg/1987/src/NEC P-9 2-15.MD.GCONF new file mode 100644 index 0000000..0058f48 --- /dev/null +++ b/app/mpg/1987/src/NEC P-9 2-15.MD.GCONF @@ -0,0 +1,219 @@ +INCLUDE "std primitives";
+INCLUDE "matrix printer";
+
+PLOTTER "NEC P9 MD",2,15,2340,1984,33.02,27.99644;
+
+COLORS "000999";
+
+(* Version vom 21.10.87 BJ *)
+
+(* Globale Daten fuer NEC P9 *)
+
+LET md p9 graf = ""27"*"39"", (* Nec P9 in 24-Nadel 180 Pixel/zoll Modus *)
+ md p9 feed = ""28"3", (* Zeilenabstand in 360 Pixel/Zoll setzen *)
+ md p9 nlq = ""27"x"1"", (* NLQ Modus waehlen *)
+ md p9 pos = ""27"\"; (* in 1/180 Zoll-Schritten rel Positionieren *)
+
+LET md p9 x max = 2339,
+ md p9 y max = 1979,
+ md p9 y lines = 124, (* y pixel / 16 (Punkte pro INT) *)
+ md p9 x per ds= 780, (* Maximale x pixel pro Dataspace ( Darf *)
+ (* Nicht mehr als 256 K sein !!! *)
+ (* x per ds = 256 * 1024 / p9 y lines / 4 *)
+ md p9 x lines = 3; (* x pixel / hd p9 x per ds *)
+
+LET MDPYLINE = ROW md p9 x per ds INT,
+ MDPSMAP = ROW md p9 y lines MDPYLINE,
+ MDPMAP = ROW md p9 x lines BOUND MDPSMAP;
+
+MDPMAP VAR md p9 map;
+
+ROW md p9 x lines DATASPACE VAR md p9 ds;
+
+INT VAR md p9 x pos, md p9 y pos;
+
+(* Globale Daten Ende *)
+
+PROC prepare:
+ REP
+ call (29, "", printer); (* wait for halt *)
+ IF task(channel(plotter)) = niltask (* Es koennte der HD worker dran sein *)
+ THEN continue (channel (plotter)) (* der startet den PRINTER wieder ! *)
+ ELSE pause(300) (* folge : Kanal belegt -> dead *)
+ FI
+ UNTIL channel(myself) = channel(plotter) PER
+END PROC prepare;
+
+PROC initplot:
+ INT VAR md p9 i;
+ FOR md p9 i FROM 1 UPTO md p9 x lines REP
+ md p9 ds[md p9 i] := nilspace;
+ md p9 map[md p9 i] := md p9 ds[md p9 i]
+ PER
+END PROC initplot;
+
+PROC endplot:
+ md p9 put map;
+ break(quiet);
+ call (26, "", printer); (* start spool *)
+ enable stop
+END PROC endplot;
+
+PROC md p9 put map:
+ open graf;
+ put map;
+ close graf;
+ forget dataspaces.
+
+ open graf:
+ out(md p9 feed + ""32""); (* LF auf 16/180 Zoll setzen *)
+ out(md p9 nlq). (* NLQ Modus waehlen, damit Positionierung in 1/180 *)
+ (* Schritten geht (sonst 1/120) *)
+ close graf:
+ out(""12""). (* Form Feed ! Drucker muss auf richtige Seitenlaenge *)
+ (* eingestellt sein (EUMEL-DR macht kein FF) *)
+
+ forget dataspaces:
+ INT VAR i;
+ FOR i FROM 1 UPTO md p9 x lines REP
+ forget(md p9 ds[i])
+ PER.
+
+ put map:
+ INT VAR j;
+ FOR j FROM 1 UPTO md p9 y lines REP
+ put line;
+ PER.
+
+ put line:
+ INT VAR actual pos :: 0, (* actual pos : aktuelle x-position 0..x max*)
+ last pos;
+ WHILE actual pos <= md p9 x max REP
+ put blank cols;
+ put nonblank cols
+ PER;
+ line.
+
+ put blank cols:
+ last pos := actual pos;
+ WHILE actual pos <= md p9 x max CAND actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos AND actual pos <= md p9 x max
+ THEN out blank cols
+ FI.
+
+ put nonblank cols:
+ last pos := actual pos;
+ WHILE actual pos <= md p9 x max CAND NOT actual col is blank REP
+ actual pos INCR 1
+ PER;
+ IF actual pos > last pos
+ THEN out nonblank cols
+ FI.
+
+ out blank cols:
+ TEXT VAR t :: " ";
+ replace(t, 1, actual pos - last pos);
+ out (md p9 pos + t).
+
+ out nonblank cols:
+ t := " ";
+ replace (t,1, actual pos - last pos);
+ out(md p9 graf + t);
+ INT VAR k;
+ FOR k FROM last pos UPTO actual pos - 1 REP
+ INT VAR word :: md p9 map [(k DIV md p9 x per ds) + 1][j]
+ [(k MOD md p9 x per ds) + 1],
+ first byte :: word;
+ rotate (word, 8);
+ out (code (word));
+ out (code (first byte));
+ out (""0"")
+ PER.
+
+ actual col is blank:
+ md p9 map [(actual pos DIV md p9 x per ds) + 1][j]
+ [(actual pos MOD md p9 x per ds) + 1] = 0
+
+END PROC md p9 put map;
+
+PROC clear:
+ md p9 clear
+END PROC clear;
+
+PROC md p9 clear:
+ create initline;
+ initialize all lines.
+
+ create initline:
+ MDPYLINE VAR initline;
+ INT VAR i;
+ FOR i FROM 1 UPTO md p9 x per ds REP
+ initline[i] := 0
+ PER.
+
+ initialize all lines:
+ INT VAR k;
+ FOR i FROM 1 UPTO md p9 x lines REP
+ FOR k FROM 1 UPTO md p9 y lines REP
+ md p9 map[i][k] := initline
+ PER
+ PER
+END PROC md p9 clear;
+
+PROC home:
+ move to (0,0)
+END PROC home;
+
+PROC moveto (INT CONST x,y):
+ md p9 x pos := x;
+ md p9 y pos := y
+END PROC moveto;
+
+PROC drawto (INT CONST x,y):
+ printer line (md p9 x pos,md p9 y max - md p9 y pos,
+ x, md p9 y max - y,
+ PROC (INT CONST, INT CONST) md p9 set pixel);
+ md p9 x pos := x;
+ md p9 y pos := y
+END PROC drawto;
+
+PROC setpixel (INT CONST x,y):
+ md p9 set pixel (x, md p9 y max - x)
+END PROC setpixel;
+
+PROC md p9 set pixel (INT CONST x,y):
+ setbit (md p9 map [(x DIV md p9 x per ds) + 1][(y DIV 16) + 1]
+ [(x MOD md p9 x per ds) + 1],15 - (y AND 15))
+END PROC md p9 set pixel;
+
+BOOL PROC md p9 is pixel (INT CONST x,y):
+ bit (md p9 map [(x DIV md p9 x per ds) + 1][(y DIV 16) + 1]
+ [(x MOD md p9 x per ds) + 1],15 - (y AND 15))
+END PROC md p9 is pixel;
+
+PROC foreground (INT VAR type):
+ type := 1
+END PROC foreground;
+
+PROC background (INT VAR type):
+ type := 0
+END PROC background;
+
+PROC setpalette:
+END PROC setpalette;
+
+PROC circle (INT CONST x,y,rad,from,to):
+ std circle (x,y,rad,from,to)
+END PROC circle;
+
+PROC box (INT CONST x1,y1,x2,y2,pattern):
+ std box (x1, y1, x2, y2, pattern)
+END PROC box;
+
+PROC fill (INT CONST x,y,pattern):
+ printer fill (x,x,md p9 y max - y,1,
+ BOOL PROC (INT CONST, INT CONST) md p9 is pixel,
+ PROC (INT CONST, INT CONST) md p9 set pixel)
+END PROC fill;
diff --git a/app/mpg/1987/src/PCPLOT.ELA b/app/mpg/1987/src/PCPLOT.ELA new file mode 100644 index 0000000..f0949ae --- /dev/null +++ b/app/mpg/1987/src/PCPLOT.ELA @@ -0,0 +1,276 @@ +PACKET pc plot DEFINES drawing area, {Autor: H. Indenbirken}
+ begin plot, {Stand: 08.02.85 }
+ end plot,
+ clear,
+ colour palette,
+ pen,
+ move,
+ draw,
+
+ get cursor,
+ zeichensatz:
+
+LET hor faktor = 22.21739, {***** x pixel / x cm *****}
+ vert faktor = 18.61314, {***** y pixel / y cm *****}
+
+ delete = 0, {Farbcodes}
+ std = 1,
+ black = 5,
+ white = 6,
+
+ nothing = 0, {Linientypen}
+ durchgehend = 1,
+ gepunktet = 2,
+ kurz gestrichelt = 3,
+ lang gestrichelt = 4,
+ strichpunkt = 5,
+
+ bit 14 = 16384;
+
+LET POS = STRUCT (INT x, y);
+LET ZEICHENSATZ = STRUCT (ROW 255 TEXT char, INT width, height);
+
+ZEICHENSATZ VAR zeichen;
+BOOL VAR character defined :: FALSE;
+TEXT VAR cursor pos :: ""0"M"0""0""0""0""0"D"0""0""0""0""0"M"0""0""0""0""0"D"0""0""0""0"",
+ cursor line :: ""0"M"0""0""0""0""0"D"0""0""0""0""0"D"0""0""0""0"";
+INT VAR act thick :: 0, i, dummy, resolution :: 6, colour code :: 256;
+POS VAR pos :: POS : (0, 0);
+
+PROC zeichensatz (TEXT CONST name):
+ IF exists (name) { Hhe: 0.64 cm }
+ THEN BOUND ZEICHENSATZ VAR new zeichen :: old (name); { Breite: 0.40 cm }
+ zeichen := new zeichen;
+ character defined := TRUE
+ ELSE errorstop ("Der Zeichensatz """ + name + """ existiert nicht") FI
+END PROC zeichensatz;
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 22.0; y cm := 13.7;
+ IF resolution = 6
+ THEN x pixel := 639; y pixel := 199
+ ELSE x pixel := 319; y pixel := 199 FI
+END PROC drawing area;
+
+
+PROC colour palette (INT CONST colour):
+ SELECT colour OF
+ CASE 0: resolution := 6
+ CASE 1: resolution := 4;
+ colour code:= 256
+ CASE 2: resolution := 4;
+ colour code:= 257
+ OTHERWISE errorstop ("colour palette nicht vorhanden") ENDSELECT
+
+END PROC colour palette;
+
+PROC begin plot :
+ control (-5, resolution, 0, dummy);
+ control (-4, 0, colour code, dummy)
+ENDPROC begin plot ;
+
+PROC end plot :
+ control (-5, 3, 0, dummy)
+ENDPROC end plot ;
+
+PROC clear :
+ control (-5, resolution, 0, dummy);
+ control (-4, 0, colour code, dummy);
+ act thick := 0;
+
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ act thick := thickness;
+ control (-8, linetype code, foreground code, dummy) .
+
+linetype code:
+ SELECT linetype OF
+ CASE nothing : 0
+ CASE durchgehend : -1
+ CASE gepunktet : 21845
+ CASE kurz gestrichelt : 3855
+ CASE lang gestrichelt : 255
+ CASE strichpunkt : 4351
+ OTHERWISE linetype END SELECT .
+
+foreground code:
+ IF foreground = delete
+ THEN 0
+ ELIF foreground < 0
+ THEN 128
+ ELSE foreground FI .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ control (-7, x, 200-y, dummy);
+ pos := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ IF act thick <> 0
+ THEN IF horizontal line
+ THEN thick y
+ ELSE thick x FI;
+ x MOVE y
+ ELSE control (-6, x, 200-y, dummy) FI;
+ pos := POS : (x, y) .
+
+horizontal line:
+ abs (pos.x-x) > abs (pos.y-y) .
+
+thick y:
+ INT VAR dy, old x :: pos.x-x ausgleich, new x :: x+x ausgleich;
+ old x MOVE pos.y;
+ new x DRAW y;
+ FOR dy FROM 1 UPTO act thick
+ REP old x MOVE pos.y+dy;
+ new x DRAW y+dy;
+ old x MOVE pos.y-dy;
+ new x DRAW y-dy;
+ PER .
+
+x ausgleich:
+ IF pos.x <= x
+ THEN act thick
+ ELSE -act thick FI .
+
+thick x:
+ INT VAR dx, old y :: pos.y-y ausgleich, new y :: y+y ausgleich;
+ pos.x MOVE old y;
+ x DRAW new y;
+ FOR dx FROM 1 UPTO act thick
+ REP pos.x+dx MOVE old y;
+ x+dx DRAW new y;
+ pos.x-dx MOVE old y;
+ x-dx DRAW new y;
+ PER .
+
+y ausgleich:
+ IF pos.y <= y
+ THEN act thick
+ ELSE -act thick FI .
+
+END PROC draw;
+
+INT VAR x fak :: zeichen.width,
+ y fak :: zeichen.height;
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+ IF character defined
+ THEN draw graphic character
+ ELSE pos cursor (pos.x, pos.y);
+ get cursor (x pos, y pos);
+ outsubtext (record, 1, 79-y pos);
+ FI .
+
+draw graphic character:
+{**** Hier werden Texte mit dem Winkel 'angle',der Hhe 'height' und *****}
+{**** der Breite 'width' gezeichnet. Die Form der Zeichen ist in der *****}
+{**** Datei 'STD Zeichensatz' enthalten. *****}
+ INT CONST x step :: character x step, y step :: character y step;
+ INT VAR x pos :: pos.x, y pos :: pos.y, i, n, x, y;
+ BOOL VAR move order;
+
+ set character height and width;
+
+ FOR i FROM 1 UPTO length (record)
+ REP draw character i PER;
+ pos.x MOVE pos.y .
+
+set character height and width:
+ IF width = 0.0 AND height = 0.0
+ THEN x fak := zeichen.width;
+ y fak := zeichen.height
+ ELSE x fak := int (hor faktor * width+0.5);
+ y fak := int (vert faktor * height+0.5)
+ FI .
+
+character x step:
+ IF width <> 0.0
+ THEN int (cosd (angle) * hor faktor * width+0.5)
+ ELSE int (cosd (angle) * real (zeichen.width)+0.5) FI .
+
+character y step:
+ IF height <> 0.0
+ THEN int (sind (angle) * vert faktor * height+0.5)
+ ELSE int (sind (angle) * real (zeichen.height)+0.5) FI .
+
+draw character i:
+ IF code (record SUB i) < 32
+ THEN steuerzeichen
+ ELSE normale zeichen FI .
+
+steuerzeichen:
+ SELECT code (record SUB i) OF
+ CASE 1: x pos := 0;
+ y pos := 255-y fak
+ CASE 2: x pos INCR x fak
+ CASE 3: y pos INCR y fak
+ CASE 4: pos cursor (x pos, y pos);
+ CASE 5: pos cursor (x pos, y pos);
+ CASE 7: out (""7"")
+ CASE 8: x pos DECR x fak
+ CASE 10: y pos DECR y fak
+ CASE 13: x pos := pos.x
+ END SELECT .
+
+normale zeichen:
+ TEXT CONST char :: zeichen.char [code (record SUB i)];
+ FOR n FROM 1 UPTO length (char) DIV 4
+ REP value (char, n, x, y, move order);
+ IF move order
+ THEN x pos+x MOVE y pos+y
+ ELSE x pos+x DRAW y pos+y FI
+ PER;
+ x pos INCR x step;
+ y pos INCR y step .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC value (TEXT CONST char, INT CONST n, INT VAR x, y, BOOL VAR move):
+ x := char ISUB n+n-1;
+ y := char ISUB n+n;
+ IF x < 0
+ THEN IF (x AND bit 14) <> 0
+ THEN move := FALSE
+ ELSE move := TRUE;
+ x := x XOR bit 14
+ FI
+ ELSE IF (x AND bit 14) <> 0
+ THEN move := TRUE;
+ x := x XOR bit 14
+ ELSE move := FALSE FI
+ FI;
+ x := (x*x fak) DIV zeichen.width;
+ y := (y*y fak) DIV zeichen.height
+
+END PROC value;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+END PROC get cursor;
+
+OP MOVE (INT CONST x, y):
+ control (-7, x, 200-y, dummy)
+END OP MOVE;
+
+OP DRAW (INT CONST x, y):
+ control (-6, x, 200-y, dummy)
+END OP DRAW;
+
+PROC pos cursor (INT CONST x, y):
+ cursor ((x-10) DIV 6, (237-y) DIV 10)
+END PROC pos cursor;
+
+END PACKET pc plot
+
+IF exists ("ZEICHEN 6*10")
+THEN zeichensatz ("ZEICHEN 6*10")
+ELIF exists ("ZEICHEN 9*12")
+THEN zeichensatz ("ZEICHEN 9*12")
+ELSE put line ("Warnung: Zeichensatz fehlt") FI
+
diff --git a/app/mpg/1987/src/PICFILE.ELA b/app/mpg/1987/src/PICFILE.ELA new file mode 100644 index 0000000..8cd4945 --- /dev/null +++ b/app/mpg/1987/src/PICFILE.ELA @@ -0,0 +1,446 @@ +PACKET picfile DEFINES (*Autor: H.Indenbirken *)
+ (*Stand: 23.02.1985 *)
+ PICFILE, :=, picture file, plot,
+ select pen, selected pen, background,
+ set values, get values,
+ view, viewport, window, oblique, orthographic, perspective,
+ extrema,
+
+ put, get,
+ to first pic, to eof, to pic, up, down,
+ is first picture, eof, picture no, pictures,
+ delete picture, insert picture, read picture,
+ write picture, put picture:
+
+
+LET max pics = 1024,
+ pic dataspace = 1102;
+
+
+TYPE PICFILE = BOUND STRUCT (INT size, pos, background,
+ ROW 16 ROW 3 INT pens,
+ ROW 16 BOOL hidden,
+ ROW 3 ROW 2 REAL sizes,
+ ROW 2 ROW 2 REAL limits,
+ ROW 4 REAL angles,
+ ROW 2 REAL obliques,
+ ROW 3 REAL perspectives
+ ROW max pics PICTURE pic);
+
+TEXT VAR i text :: ""0""0"", r text :: ""0""0""0""0""0""0""0""0"";
+INT VAR i;
+
+OP := (PICFILE VAR p, DATASPACE CONST d) :
+ IF type (d) = pic dataspace
+ THEN CONCR (p) := d
+ ELIF type (d) < 0
+ THEN type (d, pic dataspace) ;
+ CONCR (p) := d ;
+ init picfile dataspace ;
+ ELSE errorstop ("dataspace is no PICFILE") FI .
+
+init picfile dataspace :
+ r.size := 0;
+ r.pos := 0;
+ r.background := 0;
+ r.sizes := ROW 3 ROW 2 REAL : (ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0));
+ r.limits := ROW 2 ROW 2 REAL : (ROW 2 REAL : (0.0, 1.0),
+ ROW 2 REAL : (0.0, 1.0));
+ r.angles := ROW 4 REAL : (0.0, 0.0, 0.0, 0.0);
+ r.obliques := ROW 2 REAL : (0.0, 0.0);
+ r.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0);
+ FOR i FROM 1 UPTO 16
+ REP r.pens [i] := ROW 3 INT : (1, 0, 1);
+ r.hidden [i] := TRUE
+ PER .
+
+r : CONCR (CONCR (p)).
+END OP :=;
+
+DATASPACE PROC picture file (TEXT CONST name) :
+ IF exists (name)
+ THEN old (name)
+ ELSE new (name) FI
+END PROC picture file;
+
+PROC plot (TEXT CONST name) :
+ PICFILE VAR p :: old (name);
+ plot (p);
+END PROC plot;
+
+PROC plot (PICFILE VAR p) :
+ set values (p.sizes, p.limits, p.angles, p.obliques,
+ p.perspectives);
+ begin plot;
+ clear;
+ FOR i FROM 1 UPTO p.size
+ REP IF pen (p.pic [i]) <> 0
+ THEN plot pic FI
+ PER;
+ end plot .
+
+plot pic:
+ pen (p.background, p.pens (pen (p.pic (i)))(1),
+ p.pens (pen (p.pic (i)))(2), p.pens (pen (p.pic (i)))(3));
+ hidden lines (p.hidden [pen (p.pic [i])]);
+ plot (p.pic (i)) .
+
+END PROC plot;
+
+PROC select pen (PICFILE VAR p, INT CONST pen, colour, thickness, line type,
+ BOOL CONST hidden):
+ IF pen < 1 OR pen > 16
+ THEN errorstop ("pen out of range") FI;
+ p.pens [pen] := ROW 3 INT : (colour, thickness, line type);
+ p.hidden [pen] := hidden
+END PROC select pen;
+
+PROC selected pen (PICFILE CONST p, INT CONST pen,
+ INT VAR colour, thickness, line type,
+ BOOL VAR hidden):
+ IF pen < 1 OR pen > 16
+ THEN errorstop ("pen out of range") FI;
+ colour := p.pens [pen][1];
+ thickness := p.pens [pen][2];
+ line type := p.pens [pen][3];
+ hidden := p.hidden [pen]
+END PROC selected pen;
+
+INT PROC background (PICFILE CONST p):
+ p.background
+END PROC background;
+
+PROC background (PICFILE VAR p, INT CONST colour):
+ p.background := colour
+END PROC background;
+
+PROC get values (PICFILE CONST p,
+ ROW 3 ROW 2 REAL VAR size,
+ ROW 2 ROW 2 REAL VAR limits,
+ ROW 4 REAL VAR angles,
+ ROW 2 REAL VAR oblique,
+ ROW 3 REAL VAR perspective) :
+ size := p.sizes;
+ limits := p.limits;
+ angles := p.angles;
+ oblique := p.obliques;
+ perspective := p.perspectives;
+
+END PROC get values;
+
+PROC set values (PICFILE VAR p,
+ ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 4 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ p.sizes := size;
+ p.limits := limits;
+ p.angles := angles;
+ p.obliques := oblique;
+ p.perspectives := perspective;
+
+END PROC set values;
+
+PROC view (PICFILE VAR p, REAL CONST alpha):
+ p.angles [1] := alpha
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST phi, theta):
+ p.angles [2] := sind (theta) * cosd (phi);
+ p.angles [3] := sind (theta) * sind (phi);
+ p.angles [4] := cosd (theta);
+END PROC view;
+
+PROC view (PICFILE VAR p, REAL CONST x, y, z):
+ p.angles [2] := x;
+ p.angles [3] := y;
+ p.angles [4] := z
+END PROC view;
+
+PROC viewport (PICFILE VAR p,REAL CONST hor min,hor max,vert min,vert max) :
+ p.limits := ROW 2 ROW 2 REAL : (ROW 2 REAL : (hor min, hor max),
+ ROW 2 REAL : (vert min, vert max))
+END PROC viewport;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max) :
+ window (p, x min, x max, y min, y max, 0.0, 1.0)
+END PROC window;
+
+PROC window (PICFILE VAR p, REAL CONST x min, x max, y min, y max, z min, z max) :
+ p.sizes := ROW 3 ROW 2 REAL : (ROW 2 REAL : (x min, x max),
+ ROW 2 REAL : (y min, y max),
+ ROW 2 REAL : (z min, z max))
+END PROC window;
+
+PROC oblique (PICFILE VAR p, REAL CONST a, b) :
+ p.obliques := ROW 2 REAL : (a, b);
+ p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0)
+END PROC oblique;
+
+PROC orthographic (PICFILE VAR p) :
+ p.obliques := ROW 2 REAL : (0.0, 0.0);
+ p.perspectives := ROW 3 REAL : (0.0, 0.0, 0.0)
+END PROC orthographic;
+
+PROC perspective (PICFILE VAR p, REAL CONST cx, cy, cz) :
+ p.obliques := ROW 2 REAL : (0.0, 0.0);
+ p.perspectives := ROW 3 REAL : (cx, cy, cz)
+END PROC perspective;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min, x max, y min, y max) :
+ REAL VAR dummy;
+ extrema (p, x min, x max, y min, y max, dummy, dummy)
+END PROC extrema;
+
+PROC extrema (PICFILE VAR p, REAL VAR x min,x max,y min,y max,z min,z max) :
+ REAL VAR new x min, new x max, new y min, new y max, new z min, new z max;
+ x min := max real; x max := - max real;
+ y min := max real; y max := - max real;
+ z min := max real; z max := - max real;
+ FOR i FROM 1 UPTO p.size
+ REP IF dim (p.pic [i]) = 2
+ THEN extrema (p.pic [i], new x min, new x max, new y min, new y max)
+ ELSE extrema (p.pic [i], new x min, new x max, new y min, new y max,
+ new z min, new z max)
+ FI;
+ x min := min (x min, new x min); x max := max (x max, new x max);
+ y min := min (y min, new y min); y max := max (y max, new y max);
+ z min := min (z min, new z min); z max := max (z max, new z max);
+ PER
+END PROC extrema;
+
+PROC put (FILE VAR f, PICFILE CONST p):
+ put line (f, parameter);
+ FOR i FROM 1 UPTO p.size
+ REP put line (f, text (p.pic [i])) PER .
+
+parameter:
+ intern (p.size) + intern (p.pos) + intern (p.background) + intern (p.pens) +
+ intern (p.hidden) + intern (p.sizes) + intern (p.limits) + intern (p.angles) +
+ intern (p.obliques) + intern (p.perspectives) .
+
+END PROC put;
+
+PROC get (PICFILE VAR p, FILE VAR f):
+ TEXT VAR record;
+ get line (f, record);
+ convert parameter;
+ FOR i FROM 1 UPTO p.size
+ REP get line (f, record);
+ p.pic [i] := picture (record)
+ PER .
+
+convert parameter:
+ convert (record, p.size); convert (record, p.pos);
+ convert (record, p.background); convert (record, p.pens);
+ convert (record, p.hidden); convert (record, p.sizes);
+ convert (record, p.limits); convert (record, p.angles);
+ convert (record, p.obliques); convert (record, p.perspectives) .
+
+END PROC get;
+
+PROC to first pic (PICFILE VAR p):
+ p.pos := 1
+END PROC to first pic;
+
+PROC to eof (PICFILE VAR p):
+ p.pos := p.size+1
+END PROC to eof;
+
+PROC to pic (PICFILE VAR p, INT CONST n):
+ IF n < 1
+ THEN errorstop ("Position underflow")
+ ELIF n > p.size
+ THEN errorstop ("Position after end of PICFILE")
+ ELSE p.pos := n FI
+END PROC to pic;
+
+PROC up (PICFILE VAR p):
+ to pic (p, p.pos-1)
+END PROC up;
+
+PROC up (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos-n)
+END PROC up;
+
+PROC down (PICFILE VAR p):
+ to pic (p, p.pos+1)
+END PROC down;
+
+PROC down (PICFILE VAR p, INT CONST n):
+ to pic (p, p.pos+n)
+END PROC down;
+
+BOOL PROC is first picture (PICFILE CONST p):
+ p.pos = 1
+END PROC is first picture;
+
+BOOL PROC eof (PICFILE CONST p):
+ p.pos >= p.size
+END PROC eof;
+
+INT PROC picture no (PICFILE CONST p):
+ p.pos
+END PROC picture no;
+
+INT PROC pictures (PICFILE CONST p):
+ p.size
+END PROC pictures;
+
+PROC delete picture (PICFILE VAR p) :
+ INT VAR i;
+ FOR i FROM p.pos+1 UPTO p.size
+ REP p.pic [i-1] := p.pic [i] PER;
+
+ p.pic [p.size] := nilpicture;
+ IF p.size > 1
+ THEN p.size DECR 1 FI
+END PROC delete picture;
+
+PROC insert picture (PICFILE VAR p) :
+ INT VAR i;
+ IF p.size >= max pics
+ THEN errorstop ("PICFILE overflow")
+ ELSE p.size INCR 1;
+ FOR i FROM p.size DOWNTO p.pos+1
+ REP p.pic [i] := p.pic [i-1] PER;
+
+ p.pic [p.pos] := nilpicture;
+ FI
+END PROC insert picture;
+
+PROC read picture (PICFILE VAR p, PICTURE VAR pic) :
+ pic := p.pic (p.pos) .
+END PROC read picture;
+
+PROC write picture (PICFILE VAR p, PICTURE CONST pic) :
+ p.pic (p.pos) := pic .
+END PROC write picture;
+
+PROC put picture (PICFILE VAR p, PICTURE CONST pic) :
+ IF p.size >= max pics
+ THEN errorstop ("PICFILE overflow")
+ ELSE p.size INCR 1;
+ p.pic [p.size] := pic;
+ FI
+END PROC put picture;
+
+TEXT PROC intern (INT CONST n):
+ replace (i text, 1, n);
+ i text
+END PROC intern;
+
+TEXT PROC intern (ROW 16 ROW 3 INT CONST n):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 16
+ REP FOR j FROM 1 UPTO 3
+ REP result CAT intern (n [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 16 BOOL CONST n):
+ INT VAR i, result :: 0;
+ FOR i FROM 1 UPTO 16
+ REP IF n [i]
+ THEN set bit (result, i-1) FI
+ PER;
+ intern (result)
+END PROC intern;
+
+TEXT PROC intern (REAL CONST r):
+ replace (r text, 1, r);
+ r text
+END PROC intern;
+
+TEXT PROC intern (ROW 3 ROW 2 REAL CONST r):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 3
+ REP FOR j FROM 1 UPTO 2
+ REP result CAT intern (r [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 2 ROW 2 REAL CONST r):
+ INT VAR i, j;
+ TEXT VAR result :: "";
+ FOR i FROM 1 UPTO 2
+ REP FOR j FROM 1 UPTO 2
+ REP result CAT intern (r [i][j]) PER
+ PER;
+ result
+END PROC intern;
+
+TEXT PROC intern (ROW 4 REAL CONST r):
+ intern (r [1]) + intern (r [2]) + intern (r [3]) + intern (r [4])
+END PROC intern;
+
+TEXT PROC intern (ROW 3 REAL CONST r):
+ intern (r [1]) + intern (r [2]) + intern (r [3])
+END PROC intern;
+
+TEXT PROC intern (ROW 2 REAL CONST r):
+ intern (r [1]) + intern (r [2])
+END PROC intern;
+
+PROC convert (TEXT VAR record, INT VAR n):
+ n := record ISUB 1;
+ record := subtext (record, 3)
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 16 ROW 3 INT VAR n):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 16
+ REP FOR j FROM 1 UPTO 3
+ REP convert (record, n [i][j]) PER
+ PER
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 16 BOOL VAR n):
+ INT VAR i, result;
+ convert (record, result);
+ FOR i FROM 1 UPTO 16
+ REP n [i] := bit (i-1, result) PER
+END PROC convert;
+
+PROC convert (TEXT VAR record, REAL VAR r):
+ r := record RSUB 1;
+ record := subtext (record, 9)
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 3 ROW 2 REAL VAR r):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 3
+ REP FOR j FROM 1 UPTO 2
+ REP convert (record, r [i][j]) PER
+ PER;
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 2 ROW 2 REAL VAR r):
+ INT VAR i, j;
+ FOR i FROM 1 UPTO 2
+ REP FOR j FROM 1 UPTO 2
+ REP convert (record, r [i][j]) PER
+ PER;
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 4 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2]);
+ convert (record, r [3]); convert (record, r [4])
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 3 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2]); convert (record, r [3])
+END PROC convert;
+
+PROC convert (TEXT VAR record, ROW 2 REAL VAR r):
+ convert (record, r [1]); convert (record, r [2])
+END PROC convert;
+
+END PACKET picfile
diff --git a/app/mpg/1987/src/PICPLOT.ELA b/app/mpg/1987/src/PICPLOT.ELA new file mode 100644 index 0000000..d8bf5a5 --- /dev/null +++ b/app/mpg/1987/src/PICPLOT.ELA @@ -0,0 +1,241 @@ +PACKET pic plot DEFINES drawing area, {Autor: H. Indenbirken}
+ begin plot, {Stand: 13.02.85 }
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+ get cursor,
+
+ get screen, put screen:
+
+LET hor faktor = 22.21739, {***** x pixel / x cm *****}
+ vert faktor = 18.61314, {***** y pixel / y cm *****}
+
+ h max = 639,
+ v max = 287,
+
+ delete = 0, {Farbcodes}
+ std = 1,
+ black = 5,
+ white = 6,
+
+ nothing = 0, {Linientypen}
+ durchgehend = 1,
+ gepunktet = 2,
+ kurz gestrichelt = 3,
+ lang gestrichelt = 4,
+ strichpunkt = 5;
+
+INT CONST move code :: -255, {Controlcodes}
+ draw code :: -254,
+ plot code :: -253,
+ norm code :: -252,
+ del code :: -251,
+ xor code :: -250,
+ line code :: -249;
+
+LET POS = STRUCT (INT x, y);
+
+INT VAR pen thick :: 0, pen code :: draw code, ack;
+POS VAR pos :: POS : (0, 0);
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 23.0; y cm := 13.7;
+ x pixel := h max; y pixel := v max
+END PROC drawing area;
+
+PROC begin plot :
+ control (plot code, 0, 0, ack);
+ out (""15"")
+ENDPROC begin plot ;
+
+PROC end plot :
+ out (""14"");
+ control (norm code, 0, 0, ack)
+ENDPROC end plot ;
+
+PROC clear :
+ pos := POS : (0, 0);
+ pen (0, 1, 0, 1);
+ page
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ pen code := foreground colour;
+ pen thick := thickness;
+ control (line code, 0, 0, ack) .
+
+foreground colour:
+ IF linetype = nothing
+ THEN move code
+ ELIF foreground = delete OR foreground = black
+ THEN del code
+ ELIF foreground < 0
+ THEN xor code
+ ELSE draw code FI .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ control (move code, x, y);
+ pos := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ control (pen code, x, y);
+ IF thick line
+ THEN IF horizontal line
+ THEN thick y
+ ELSE thick x FI;
+ control (move code, x, y)
+ FI;
+ pos := POS : (x, y) .
+
+thick line:
+ pen thick > 0 AND pen code <> move code .
+
+horizontal line:
+ abs (pos.x-x) > abs (pos.y-y) .
+
+thick y:
+ INT VAR dy;
+ FOR dy FROM 1 UPTO pen thick
+ REP control (move code, pos.x, pos.y+dy);
+ control (pen code, x, y+dy);
+ control (move code, pos.x, pos.y-dy);
+ control (pen code, x, y-dy)
+ PER .
+
+thick x:
+ INT VAR dx;
+ FOR dx FROM 1 UPTO pen thick
+ REP control (move code, pos.x+dx, pos.y);
+ control (pen code, x+dx, y);
+ control (move code, pos.x-dx, pos.y);
+ control (pen code, x-dx, y)
+ PER .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+ IF pen code = draw code
+ THEN cursor (x position, y position);
+ out (record)
+ FI .
+
+x position:
+ (pos.x-1) DIV 8 + 1 .
+
+y position:
+ (pos.y-1) DIV 12 + 1 .
+
+END PROC draw;
+
+PROC control (INT CONST code, x, y):
+ control (code, x check, y check, ack) .
+
+x check:
+ IF x < 0
+ THEN 0
+ ELIF x > h max
+ THEN h max
+ ELSE x FI .
+
+y check:
+ IF y =< 0
+ THEN v max
+ ELIF y >= v max
+ THEN 0
+ ELSE v max-y FI .
+
+END PROC control;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+ get cursor (t, x, y, -1, -1, -1, -1)
+END PROC get cursor;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1):
+ check;
+ init cursor;
+ REP set cursor;
+ get step;
+ set cursor;
+ move cursor
+ PER .
+
+init cursor:
+ INT VAR delta := 1;
+ x := pos.x;
+ y := pos.y .
+
+set cursor:
+ IF x0 > 0 AND y0 > 0
+ THEN control (move code, x0, v max-y0, ack);
+ control (xor code, x, v max-y, ack)
+ FI;
+ IF x1 > 0 AND y1 > 0
+ THEN control (move code, x1, v max-y1, ack);
+ control (xor code, x, v max-y, ack)
+ FI;
+ control (move code, x-4, v max-y, ack);
+ control (xor code, x+5, v max-y, ack);
+ control (move code, x, v max-y-4, ack);
+ control (xor code, x, v max-y-4, ack) .
+
+get step:
+ t := incharety (1);
+ IF t <> ""
+ THEN IF delta < 10
+ THEN delta INCR delta
+ ELSE delta INCR 1 FI
+ ELSE delta := 1;
+ inchar (t)
+ FI .
+
+move cursor:
+ SELECT code (t) OF
+ CASE 2 : x INCR delta
+ CASE 3 : y INCR delta
+ CASE 8 : x DECR delta
+ CASE 10: y DECR delta
+ OTHERWISE leave get cursor ENDSELECT;
+ check .
+
+leave get cursor:
+ control (move code, pos.x, pos.y);
+ LEAVE get cursor .
+
+check :
+ IF x < 0
+ THEN x := 0; out (""7"")
+ ELIF x > h max
+ THEN x := h max; out (""7"") FI;
+
+ IF y < 0
+ THEN y := 0; out (""7"")
+ ELIF y > v max
+ THEN y := v max; out (""7"") FI .
+
+END PROC get cursor;
+
+(* Bildwiederholspeicheraufbau des Pic 400: *)
+(* 45 Blcke (0...44) enthalten den Bildwiederholspeicher. *)
+
+PROC get screen (DATASPACE VAR ds, INT CONST page):
+ INT VAR i, n, begin :: 45*page;
+ FOR i FROM 0 UPTO 44
+ REP block in (ds, begin+i, -1, i, n) PER
+END PROC get screen;
+
+PROC put screen (DATASPACE CONST ds, INT CONST page):
+ INT VAR i, n, begin :: 45*page;
+ FOR i FROM 0 UPTO 44
+ REP block out (ds, begin+i, -1, i, n) PER
+END PROC put screen;
+
+END PACKET pic plot;
diff --git a/app/mpg/1987/src/PICTURE.ELA b/app/mpg/1987/src/PICTURE.ELA new file mode 100644 index 0000000..d5e00fa --- /dev/null +++ b/app/mpg/1987/src/PICTURE.ELA @@ -0,0 +1,521 @@ +PACKET picture DEFINES (*Autor: H.Indenbirken *)
+ PICTURE, (*Stand: 23.02.1985 *)
+ :=, CAT, nilpicture,
+ draw, draw r, draw cm, draw cm r,
+ move, move r, move cm, move cm r,
+ bar, circle,
+ length, dim, pen, where,
+ extrema, rotate, stretch, translate,
+ text, picture, plot:
+
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ move cm key = 6,
+ draw cm key = 7,
+ move cm r key = 8,
+ draw cm r key = 9,
+ bar key = 10,
+ circle key = 11,
+ max 2 dim = 31983,
+ max 3 dim = 31975,
+ max text = 31974,
+ max bar = 31982,
+ max circle = 31974,
+ max length = 32000;
+
+
+TYPE PICTURE = STRUCT (INT dim, pen, TEXT points);
+
+
+INT VAR i, read pos, key;
+REAL VAR x, y, z;
+TEXT VAR t, r2 :: 16*""0"", r3 :: 24*""0"", i1 :: ""0""0"", i2 :: ""0""0""0""0"";
+
+OP := (PICTURE VAR l, PICTURE CONST r) :
+ CONCR (l) := CONCR (r)
+END OP :=;
+
+OP CAT (PICTURE VAR l, PICTURE CONST r) :
+ IF l.dim <> r.dim
+ THEN errorstop ("OP CAT : left dimension <> right dimension")
+ ELIF length (l.points) > max length - length (r.points)
+ THEN errorstop ("OP CAT : Picture overflow") FI;
+
+ l.points CAT r.points
+END OP CAT;
+
+PICTURE PROC nilpicture :
+ PICTURE : (0, 1, "")
+END PROC nilpicture;
+
+PROC draw (PICTURE VAR p, TEXT CONST text) :
+ draw (p, text, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, TEXT CONST text, REAL CONST angle, height, bright):
+ write (p, text, angle, height, bright, text key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, draw key)
+END PROC draw;
+
+PROC draw (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, draw key)
+END PROC draw;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, draw r key)
+END PROC draw r;
+
+PROC draw r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, draw r key)
+END PROC draw r;
+
+PROC draw cm (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, draw cm key)
+END PROC draw cm;
+
+PROC draw cm r (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, draw cm r key)
+END PROC draw cm r;
+
+PROC move (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, move key)
+END PROC move;
+
+PROC move (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, move key)
+END PROC move;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y, z) :
+ check dim (p, 3);
+ write (p, x, y, z, move r key)
+END PROC move r;
+
+PROC move r (PICTURE VAR p, REAL CONST x, y) :
+ check dim (p, 2);
+ write (p, x, y, move r key)
+END PROC move r;
+
+PROC move cm (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, move cm key)
+END PROC move cm;
+
+PROC move cm r (PICTURE VAR p, REAL CONST x, y) :
+ write (p, x, y, move cm r key)
+END PROC move cm r;
+
+PROC bar (PICTURE VAR p, REAL CONST width, height, INT CONST pattern):
+ write (p, width, height, pattern, bar key)
+END PROC bar;
+
+PROC circle (PICTURE VAR p, REAL CONST radius, from, to, INT CONST pattern):
+ write (p, radius, from, to, pattern, circle key)
+END PROC circle;
+
+
+PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST key) :
+ IF length (p.points) < max 3 dim
+ THEN p.points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ p.points CAT r3
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST key) :
+ IF length (p.points) < max 2 dim
+ THEN p.points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ p.points CAT r2
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, INT CONST n, key) :
+ IF length (p.points) < max bar
+ THEN p.points CAT code (key);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ p.points CAT r2;
+ replace (i1, 1, n);
+ p.points CAT i1
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, REAL CONST x, y, z, INT CONST n, key) :
+ IF length (p.points) < max circle
+ THEN p.points CAT code (key);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ p.points CAT r3;
+ replace (i1, 1, n);
+ p.points CAT i1
+ ELSE errorstop ("Picture overflow") FI
+END PROC write;
+
+PROC write (PICTURE VAR p, TEXT CONST t, REAL CONST angle, height, bright,
+ INT CONST key) :
+ IF max text - length (p.points) >= length (t)
+ THEN p.points CAT code (key);
+ replace (i1, 1, length (t));
+ p.points CAT i1;
+ p.points CAT t;
+ replace (r3, 1, angle);
+ replace (r3, 2, height);
+ replace (r3, 3, bright);
+ p.points CAT r3
+ FI;
+END PROC write;
+
+PROC check dim (PICTURE VAR p, INT CONST dim):
+ IF p.dim = 0
+ THEN p.dim := dim
+ ELIF p.dim <> dim
+ THEN errorstop ("Picture is " + text (p.dim) + " dimensional") FI
+END PROC check dim;
+
+INT PROC length (PICTURE CONST p):
+ length (p.points)
+END PROC length;
+
+INT PROC dim (PICTURE CONST pic) :
+ pic.dim
+END PROC dim;
+
+PROC pen (PICTURE VAR p, INT CONST pen) :
+ IF pen < 0 OR pen > 16
+ THEN errorstop ("pen out of range [0-16]") FI;
+ p.pen := pen
+END PROC pen;
+
+INT PROC pen (PICTURE CONST p) :
+ p.pen
+END PROC pen;
+
+PROC where (PICTURE CONST p, REAL VAR x, y) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0
+ ELIF p.dim = 3
+ THEN errorstop ("Picture is 3 dimensional")
+ ELSE x := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ y := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1
+ FI
+END PROC where;
+
+PROC where (PICTURE CONST p, REAL VAR x, y, z) :
+ IF p.dim = 0
+ THEN x := 0.0; y := 0.0; z := 0.0
+ ELIF p.dim = 2
+ THEN errorstop ("Picture is 2 dimensional")
+ ELSE x := subtext (p.points, length (p.points)-23, length (p.points)-16) RSUB 1;
+ y := subtext (p.points, length (p.points)-15, length (p.points)-8) RSUB 1;
+ z := subtext (p.points, length (p.points)-7, length (p.points)) RSUB 1;
+ FI
+END PROC where;
+
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max, z min, z max) :
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ z min := max real; z max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+calc extrema :
+ x := next real; y := next real; z := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real; z INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y);
+ z min := min (z min, z); z max := max (z max, z) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC extrema (PICTURE CONST p, REAL VAR x min, x max, y min, y max):
+ x min := max real; x max :=-max real;
+ y min := max real; y max :=-max real;
+ read pos := 0;
+ INT CONST pic length := length (p.points);
+ WHILE read pos < pic length
+ REP check position PER .
+
+check position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : calc extrema
+ CASE move key : calc extrema
+ CASE move r key : calc rel extrema
+ CASE draw r key : calc rel extrema
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+calc extrema :
+ x := next real; y := next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+calc rel extrema :
+ x INCR next real; y INCR next real;
+ x min := min (x min, x); x max := max (x max, x);
+ y min := min (y min, y); y max := max (y max, y) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC extrema;
+
+PROC rotate (PICTURE VAR p, REAL CONST angle) :
+ REAL CONST s :: sind( angle ), c := cosd( angle );
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( 1.0, 0.0, 0.0 ),
+ ROW 3 REAL : ( 0.0, c , s ),
+ ROW 3 REAL : ( 0.0, -s , c ),
+ ROW 3 REAL : ( 0.0, 0.0, 0.0 )))
+END PROC rotate;
+
+PROC rotate (PICTURE VAR p, REAL CONST phi, theta, lambda ) :
+ REAL CONST s :: sind ( theta ), c :: cosd ( theta ),
+ s p :: sind ( phi ), s l :: sind ( lambda ),
+ ga :: cosd ( phi ), c l :: cosd ( lambda ),
+ be :: s p * s l, al :: s p * c l, c1 :: 1.0 - c;
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( al*al*c1 + c , be*al*c1+ga*s, ga*al*c1-be*s ),
+ ROW 3 REAL : ( al*be*c1-ga*s, be*be*c1 + c , ga*be*c1+al*s ),
+ ROW 3 REAL : ( al*ga*c1+be*s, be*ga*c1-al*s, ga*ga*c1 + c ),
+ ROW 3 REAL : ( 0.0 , 0.0 , 0.0 )))
+END PROC rotate;
+
+PROC stretch (PICTURE VAR pic, REAL CONST sx, sy) :
+ stretch (pic, sx, sy, 1.0)
+END PROC stretch;
+
+PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : ( sx, 0.0, 0.0),
+ ROW 3 REAL : (0.0, sy, 0.0),
+ ROW 3 REAL : (0.0, 0.0, sz),
+ ROW 3 REAL : (0.0, 0.0, 0.0)))
+END PROC stretch;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy) :
+ translate (p, dx, dy, 0.0)
+END PROC translate;
+
+PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) :
+ transform (p, ROW 4 ROW 3 REAL :
+ (ROW 3 REAL : (1.0, 0.0, 0.0),
+ ROW 3 REAL : (0.0, 1.0, 0.0),
+ ROW 3 REAL : (0.0, 0.0, 1.0),
+ ROW 3 REAL : ( dx, dy, dz)))
+END PROC translate;
+
+PROC transform (PICTURE VAR p, ROW 4 ROW 3 REAL CONST a) :
+ INT CONST pic length := length (p.points);
+ INT VAR begin pos;
+ read pos := 0;
+ x := 0.0; y := 0.0; z := 0.0;
+ IF p.dim = 2
+ THEN transform 2 dim pic
+ ELSE transform 3 dim pic FI .
+
+transform 2 dim pic:
+ WHILE read pos < pic length
+ REP transform 2 dim position PER .
+
+transform 2 dim position:
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 2 dim point
+ CASE move key : transform 2 dim point
+ CASE move r key : transform 2 dim point
+ CASE draw r key : transform 2 dim point
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+transform 2 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real;
+ transform (a, x, y, z);
+ replace (r2, 1, x);
+ replace (r2, 2, y);
+ replace (p.points, begin pos, r2) .
+
+transform 3 dim pic:
+ WHILE read pos < pic length
+ REP transform 3 dim position PER .
+
+transform 3 dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : transform 3 dim point
+ CASE move key : transform 3 dim point
+ CASE move r key : transform 3 dim point
+ CASE draw r key : transform 3 dim point
+ CASE move cm key : read pos INCR 16
+ CASE draw cm key : read pos INCR 16
+ CASE move cm r key : read pos INCR 16
+ CASE draw cm r key : read pos INCR 16
+ CASE text key : read pos INCR next int + 24
+ CASE bar key : read pos INCR 18
+ CASE circle key : read pos INCR 26
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+transform 3 dim point:
+ begin pos := read pos+1;
+ x := next real; y := next real; z := next real;
+ transform (a, x, y, z);
+ replace (r3, 1, x);
+ replace (r3, 2, y);
+ replace (r3, 3, z);
+ replace (p.points, begin pos, r3) .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+END PROC transform;
+
+PROC transform (ROW 4 ROW 3 REAL CONST a, REAL VAR x, y, z) :
+ REAL CONST ox :: x, oy :: y, oz :: z;
+ x := ox*a(1)(1) + oy*a(2)(1) + oz*a(3)(1) + a(4)(1);
+ y := ox*a(1)(2) + oy*a(2)(2) + oz*a(3)(2) + a(4)(2);
+ z := ox*a(1)(3) + oy*a(2)(3) + oz*a(3)(3) + a(4)(3)
+END PROC transform;
+
+TEXT PROC text (PICTURE CONST pic):
+ replace (i2, 1, pic.dim);
+ replace (i2, 2, pic.pen);
+ i2 + pic.points
+END PROC text;
+
+PICTURE PROC picture (TEXT CONST text):
+ PICTURE : (text ISUB 1, text ISUB 2, subtext (text, 5))
+END PROC picture;
+
+PROC plot (PICTURE CONST p) :
+ INT CONST pic length := length (p.points);
+ read pos := 0;
+ IF p.dim = 2
+ THEN plot two dim pic
+ ELSE plot three dim pic FI .
+
+plot two dim pic:
+ WHILE read pos < pic length
+ REP plot two dim position PER .
+
+plot two dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : draw (next real, next real)
+ CASE move key : move (next real, next real)
+ CASE move r key : move r (next real, next real)
+ CASE draw r key : draw r (next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+plot three dim pic:
+ WHILE read pos < pic length
+ REP plot three dim position PER .
+
+plot three dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : draw (next real, next real, next real)
+ CASE move key : move (next real, next real, next real)
+ CASE move r key : move r (next real, next real, next real)
+ CASE draw r key : draw r (next real, next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+next text :
+ INT CONST text length :: next int;
+ read pos INCR text length;
+ subtext (p.points, read pos-text length+1, read pos) .
+
+END PROC plot;
+
+END PACKET picture
diff --git a/app/mpg/1987/src/PLOTSPOL.ELA b/app/mpg/1987/src/PLOTSPOL.ELA new file mode 100644 index 0000000..f15b13c --- /dev/null +++ b/app/mpg/1987/src/PLOTSPOL.ELA @@ -0,0 +1,129 @@ +PACKET plotten spool DEFINES plot: #Autor: H.Indenbirken #
+ #Stand: 10.02.1985 #
+LET draw key = 1,
+ move key = 2,
+ text key = 3,
+ move r key = 4,
+ draw r key = 5,
+ move cm key = 6,
+ draw cm key = 7,
+ move cm r key = 8,
+ draw cm r key = 9,
+ bar key = 10,
+ circle key = 11,
+ max length = 32000;
+
+
+TYPE PICTURE = STRUCT (INT dim, pen, TEXT points);
+
+
+INT VAR i, read pos, key;
+REAL VAR x, y, z;
+TEXT VAR t;
+
+
+PROC plot (PICTURE CONST p) :
+ INT CONST pic length := length (p.points);
+ read pos := 0;
+ IF p.dim = 2
+ THEN plot two dim pic
+ ELSE plot three dim pic FI .
+
+plot two dim pic:
+ WHILE read pos < pic length
+ REP plot two dim position PER .
+
+plot two dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : draw (next real, next real)
+ CASE move key : move (next real, next real)
+ CASE move r key : move r (next real, next real)
+ CASE draw r key : draw r (next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+plot three dim pic:
+ WHILE read pos < pic length
+ REP plot three dim position PER .
+
+plot three dim position :
+ read pos INCR 1;
+ SELECT code (p.points SUB read pos) OF
+ CASE draw key : draw (next real, next real, next real)
+ CASE move key : move (next real, next real, next real)
+ CASE move r key : move r (next real, next real, next real)
+ CASE draw r key : draw r (next real, next real, next real)
+ CASE move cm key : move cm (next real, next real)
+ CASE draw cm key : draw cm (next real, next real)
+ CASE move cm r key : move cm r (next real, next real)
+ CASE draw cm r key : draw cm r (next real, next real)
+ CASE text key : draw (next text, next real, next real, next real)
+ CASE bar key : bar (next real, next real, next int)
+ CASE circle key : circle (next real, next real, next real, next int)
+ OTHERWISE errorstop ("wrong key code") END SELECT .
+
+next real :
+ read pos INCR 8;
+ subtext (p.points, read pos-7, read pos) RSUB 1 .
+
+next int :
+ read pos INCR 2;
+ subtext (p.points, read pos-1, read pos) ISUB 1 .
+
+next text :
+ INT CONST text length :: next int;
+ read pos INCR text length;
+ subtext (p.points, read pos-text length+1, read pos) .
+
+END PROC plot;
+
+LET max pics = 1024,
+ pic dataspace = 1102;
+
+
+TYPE PICFILE = BOUND STRUCT (INT size, pos, background,
+ ROW 16 ROW 3 INT pens,
+ ROW 16 BOOL hidden,
+ ROW 3 ROW 2 REAL sizes,
+ ROW 2 ROW 2 REAL limits,
+ ROW 4 REAL angles,
+ ROW 2 REAL obliques,
+ ROW 3 REAL perspectives
+ ROW max pics PICTURE pic);
+
+PICFILE VAR p;
+
+PROC plot (DATASPACE VAR ds):
+ IF type (ds) = pic dataspace
+ THEN CONCR (p) :: old (ds);
+ plot (p)
+ ELSE errorstop ("Dataspace is no PICFILE") FI;
+END PROC plot;
+
+PROC plot (PICFILE VAR p) :
+ set values (p.sizes, p.limits, p.angles, p.obliques,
+ p.perspectives);
+ begin plot;
+ clear;
+ FOR i FROM 1 UPTO p.size
+ REP IF pen (p.pic [i]) <> 0
+ THEN plot pic FI
+ PER;
+ end plot .
+
+plot pic:
+ pen (p.background, p.pens (pen (p.pic (i)))(1),
+ p.pens (pen (p.pic (i)))(2), p.pens (pen (p.pic (i)))(3));
+ hidden lines (p.hidden [pen (p.pic [i])]);
+ plot (p.pic (i)) .
+
+END PROC plot;
+
+END PACKET plotten spool
diff --git a/app/mpg/1987/src/PUBINSPK.ELA b/app/mpg/1987/src/PUBINSPK.ELA new file mode 100644 index 0000000..0650c20 --- /dev/null +++ b/app/mpg/1987/src/PUBINSPK.ELA @@ -0,0 +1,654 @@ +PACKETmpgtestelanprogramsDEFINESelantest:LETs17=0,s30="",s31="*** ELAN TEST VOR
+ZEITIG ABGEBROCHEN ***",s33=1000,s34=1,s35="line exceeding screen",s37="comment
+exceeding line",s38="text denoter too long (",s39=" characters)",s40="text denot
+er exceeding source line",s43=" ""("" open",s44=" ""["" open",s46=";",s47=".",
+s48="(",s49=")",s50="[",s51="]",s53=" ""("" open at end of unit",s54=" ""["" ope
+n at end of unit",s57=77,s58="=",s59="EUMEL - Datei : ",s60=" Zeilen , ",
+s61="Elan - Quelltext : ",s62=" Units , ",s63=" Scanner - Operationen durchg
+efuehrt.",s66="dito ",s67="dito",s68="EOLN ",s69=" ",s74=10,s75="00",s76=100,
+s77="0",s78=" Byte";LETs1=7,s2=8,s3=9,s4=2,s5=4,s6=6,s7=77,s8=255,s9="ENDIFIENDS
+ELECTENDREPEATPERENDPROCEDURENDPACKETENDOP",s10="WARNING: ",s11="ERROR : ";INT
+ VARs12;FILE VARs13;TEXT VARs14;PROCelantest:elantest(lastparam)ENDPROCelantest;
+PROCelantest(TEXT CONSTs15):INT VARs16:=s17,s18:=s17,s19:=s17,s20:=s17,s21:=s17,
+s22:=s17,s23,s24:=s17,s25:=s17,s26:=s17;TEXT VARs27,s28;FILE VARs29:=
+sequentialfile(input,s15);s13:=notefile;s12:=s17;s14:=s30;scan(s30);nextsymbol(
+s27);WHILE NOTeof(s29)REPs32;s36;s27:=incharetyUNTILs27<>s30PER;IFs27<>s30THEN
+putline(s13,s31)FI;s14:=s30;s56;modify(s29);noteedit(s29);line.s32:getline(s29,
+s27);continuescan(s27);s16INCR LENGTHs27;s18INCRs16DIVs33;s16:=s16MODs33;s12INCR
+s34;cout(s12);IF LENGTHs27>s7THENs64(s10+s35)FI.s36:REPEATnextsymbol(s28,s23);
+s24INCRs34;s41UNTILs23>=s1PER;IFs23=s2THENs64(s10+s37)FI;IFs23=s3THENs21INCR
+ LENGTHs28;IFs21>s8THENs64(s11+s38+text(s21)+s39)ELSEs64(s10+s40)FI ELSEs21:=s17
+FI;s20INCRs19DIVs33;s19:=s19MODs33.s41:IFs23=s1THENs42ELIFs23=s6THENs45ELIFs23=
+s5THENs21INCR LENGTHs28;IFs21>s8THENs64(s11+s38+text(s21)+s39)FI ELIFs23=s4CAND
+pos(s9,s28)<>s17THENs52FI;s19INCR LENGTHs28.s42:IFs25<>s17THENs64(s10+text(s25)+
+s43)FI;IFs26<>s17THENs64(s10+text(s26)+s44)FI.s45:IFs28=s46OR(s28=s47ANDs55)THEN
+s52ELIFs28=s48THENs25INCRs34ELIFs28=s49THENs25DECRs34ELIFs28=s50THENs26INCRs34
+ELIFs28=s51THENs26DECRs34FI.s52:s22INCRs34;IFs25<>s17THENs64(s11+text(s25)+s53);
+s25:=s17FI;IFs26<>s17THENs64(s11+text(s26)+s54);s26:=s17FI.s55:FALSE.s56:line(
+s13);putline(s13,s57*s58);putline(s13,s59+text(s12)+s60+s70(s18,s16));putline(
+s13,s61+text(s22)+s62+s70(s20,s19));putline(s13,text(s24)+s63);putline(s13,s57*
+s58).ENDPROCelantest;PROCs64(TEXT CONSTs65):IFs65=s14THENputline(s13,s66+text(
+s12));IFonlineTHENput(s12);putline(s67)FI;LEAVEs64FI;s14:=s65;putline(s13,s68+
+text(s12)+s69+s65);IFonlineTHENput(s12);putline(s65)FI ENDPROCs64;TEXT PROCs70(
+INT CONSTs71,s72):TEXT VARs73:=text(s71);IFs72<s74THENs73CATs75ELIFs72<s76THEN
+s73CATs77FI;s73CATtext(s72);s73CATs78;s73ENDPROCs70ENDPACKETmpgtestelanprograms;
+PACKETmpgarchivesystemDEFINESreserve,archive,release,archiv,archivname,
+archiverror,archivangemeldet,from,to,pla:LETs90="",s98="Unbekannte Laufwerksnumm
+er",s99="Gefundenes Archiv: """,s100="""",s101=""13""10"",s103="Archiv nicht ang
+emeldet",s105=1,s106=13,s107="Archiv heisst",s108=16,s116=70,s117="=",s119="_",
+s121="Archiv eingelegt",s123="PLA",s125=5,s126="ARCHIVNAME: ",s127=" ",s128=" "
+,s129="Date Store Contents",s131=6,s132="-",s135=3,s136="Archivlisting dru
+cken";LETs79=90,s80=91,s81=0,s82=1,s83=2,s84=1,s85=20,s86=19,s87="configurator";
+BOOL VARs88;TEXT VARs89:=s90;PROCreserve(TASK CONSTs91):reserve(s90,s91)ENDPROC
+reserve;PROCreserve(TEXT CONSTs92,TASK CONSTs91):IFs91=archiveTHENs88:=TRUE FI;
+call(s86,s92,s91)ENDPROCreserve;PROCarchive(TEXT CONSTs93):reserve(s93,archive)
+ENDPROCarchive;PROCarchive(TEXT CONSTs93,INT CONSTs94):reserve(s93,s94/archive)
+ENDPROCarchive;PROCarchive(TEXT CONSTs93,TASK CONSTs91):reserve(s93,s91)ENDPROC
+archive;PROCrelease(TASK CONSTs91):call(s85,s90,s91);IFs91=archiveTHENs88:=FALSE
+ FI ENDPROCrelease;PROCrelease:release(archive);ENDPROCrelease;PROCarchiv(INT
+ CONSTs95):SELECTs95OF CASEs81,s82:s96CASEs83:archivOTHERWISEs97ENDSELECT.s96:IF
+station(myself)<>s84THENs97ELSEreserve(archive);SELECTs95OF CASEs81:call(s79,s90
+,task(s87))CASEs82:call(s80,s90,task(s87))ENDSELECT;archivFI.s97:errorstop(s98)
+ENDPROCarchiv;PROCarchiv:s88:=TRUE;TEXT CONSTs93:=archivname;IFs89=s90THEN
+display(s99+s93+s100);ELSEerrorstop(s89)FI;display(s101).ENDPROCarchiv;BOOL PROC
+archivangemeldet:s88ENDPROCarchivangemeldet;TEXT PROCarchivname:TEXT VARs93:=s90
+;THESAURUS VARs102;IF NOTs88THENerrorstop(s103);s90ELSEs88:=FALSE;s89:=s90;
+disablestop;archive(s90);IFiserrorTHENs89:=errormessage;LEAVEarchivnameWITHs90FI
+;s102:=ALLarchive;s104;clearerror;enablestop;archive(s93);s88:=TRUE;s93FI.s104:
+IFsubtext(errormessage,s105,s106)=s107THENs93:=subtext(errormessage,s108,LENGTH
+errormessage-s105)ELSEs89:=errormessageFI ENDPROCarchivname;TEXT PROCarchiverror
+:s89ENDPROCarchiverror;PROCfrom(TEXT CONSTs93):fetch(s93,archive)ENDPROCfrom;
+PROCto(TEXT CONSTs93):BOOL CONSTs109:=commanddialogue;commanddialogue(FALSE);
+save(s93,archive);commanddialogue(s109)ENDPROCto;PROCto:to(lastparam)ENDPROCto;
+PROCfrom(THESAURUS CONSTs110):fetch(s110,archive)ENDPROCfrom;PROCto(THESAURUS
+ CONSTs110):BOOL CONSTs109:=commanddialogue;commanddialogue(FALSE);save(s110,
+archive);commanddialogue(s109)ENDPROCto;PROCpla:pla(TRUE)ENDPROCpla;PROCpla(BOOL
+ CONSTs111):LETs112=18;FILE VARs113;INT VARs114;TEXT CONSTs115:=s116*s117,s118:=
+s116*s119;TEXT VARs120;WHILEyes(s121)REPs122UNTIL NOTs111PER;release.s122:archiv
+;s113:=sequentialfile(output,s123);list(s113,archive);s124;s130;s133;s134.s124:
+modify(s113);toline(s113,s105);FORs114FROMs105UPTOs125REPinsertrecord(s113)PER;
+toline(s113,s105);writerecord(s113,s115);down(s113);writerecord(s113,s126+
+headline(s113)+s127+timeofday+s127+date);down(s113);writerecord(s113,s115);down(
+s113);writerecord(s113,s128);down(s113);writerecord(s113,s129).s130:toline(s113,
+s131);WHILE NOTeof(s113)REPreadrecord(s113,s120);IF(s120SUBs112)=s132THEN
+deleterecord(s113)ELSEdown(s113)FI PER.s133:output(s113);putline(s113,s118).s134
+:modify(s113);edit(s113);line(s135);IFyes(s136)THENprint(s123)FI;forget(s123,
+quiet)ENDPROCplaENDPACKETmpgarchivesystem;PACKETmpgsomeDEFINESsome,SOME,one,
+inchar,center,invers,editsome,editone,reorganize:LETs139=" ",s140=1,s144=2,s145=
+0,s148=""7"",s162=04,s163="-",s164="> "15"weitere Eintraege "14"",s165=52,s200=
+"",s203="Fenster zu klein",s206=""5"",s209=3,s210=5,s212=6,s213=""8"",s219="-> "
+,s220=" > ",s222="----> ",s225="""",s226=""5""13""10"",s228=79,s235=40,s245=4,
+s261=7,s262=8,s263=9,s267="Bitte warten !",s283="-> """,s284=""11"",s285=""2"",
+s306="!",s310=" INFO : Auswahl mehrerer Dateien ",s311=" INFO : Auswahl einer Da
+tei ",s312="q19",s320="zum Editieren",s324="Datei ",s325=30,s326=" wird reorgani
+siert :",s327=" ",s328=" ist keine Datei.",s330=""15" Mit den angekreuzte
+n Namen wird die gewaehlte Operation ausgefuehrt "14"",s331=" "15"
+Positionierungen: "14" ",s332=" Oben : zum vorausgehenden N
+amen",s333=" Unten : zum folgenden Namen ",s334="
+ HOP Oben : zum ersten Namen der (vorigen) Seite",s335="
+HOP Unten : zum letzten Namen der (vorigen) Seite",s336=" HOP RE
+TURN : aktuelle Zeile wird erste Zeile",s337=" ESC 1 : zum
+ ersten Namen der Liste",s338=" ESC 9 : zum letzten Namen d
+er Liste",s339=" ESC s : Liste nach Nummern ordnen",s340="
+ "15" Auswahl treffen: "14" ",s341=" ( Folgende Befehle sind
+ nur bei einer )",s342=" ( Auswahl von mehreren Namen M"218"glich.
+)",s343=" RETURN bzw. x: diesen Namen ankreuzen ",s344="
+ RUBOUT bzw. o: Kreuz vor dem Namen loeschen",s345=" HOP x
+ : alle Namen ankreuzen ",s346=" HOP o : alle Kreuz
+e loeschen ",s347=" ESC x : alle folgenden Namen ankreuz
+en",s348=" ESC o : alle folgenden Kreuze loeschen",s349="
+ RUBIN : einen neuen Namen eintragen",s350=" ( Nur
+ dieser Befehl kann benutzt werden , wenn )",s351=" ( die Auswahl e
+ines ! Namens m"218"glich ist. )",s352=" RETURN bzw. x: diesen
+ Namen auswaehlen",s353=" "15" Auswahl verlassen: "14"",s354="
+ ESC q : Auswaehlen beenden ",s355=" ESC a
+ : Auswahl abbrechen (ohne Kreuze !)",s356=""15" Zum Verlassen des
+Infos bitte 'ESC q' tippen! "14"";LETs137=80;TEXT PROCcenter(
+TEXT CONSTs138):center(s138,s139,s137-s140)ENDPROCcenter;TEXT PROCcenter(TEXT
+ CONSTs138,s141,INT CONSTs142):TEXT VARs143:=((s142-length(s138))DIVs144)*s141;
+s143CAT(s138+s143);IF(LENGTHs143)-s142=s145THENs143ELSEs143+s141FI ENDPROCcenter
+;TEXT PROCinvers(TEXT CONSTs138):s157+s138+s139+s158ENDPROCinvers;PROCinchar(
+TEXT VARs146,TEXT CONSTs147):REPgetchar(s146);IFpos(s147,s146)=s145THENout(s148)
+FI UNTILpos(s147,s146)<>s145PER ENDPROCinchar;LETs149=3,s150=24,s151=200;LETs152
+=""222"",s153=""1""27""3""10""13"x"12"o?"11"",s154=""3""10""12"o"13"x",s155="q19
+a"13"x"12"os";LETs156=""13""10"",s157=""15"",s158=""14"";LETs159="Auswahl einer
+Datei ( Bei Unklarheiten bitte <?> )",s160="Auswahl mehrerer Dateien ( Bei
+Unklarheiten bitte <?> )";TEXT CONSTs161:=s162*s163+s164+s165*s163;LETs166=1,
+s167=2,s168=3,s169=4,s170=5,s171=6,s172=7,s173=8,s174=9,s175=10;LETs176=1003;INT
+ VARs177,s178,s179,s180,s181,s182,s183;TEXT VARs184,s185,s186,s187;BOOL VARs188,
+s189;ROWs151TEXT VARs190;THESAURUS VARs191;FILE VARs192;DATASPACE VARs193;
+INITFLAG VARs194;THESAURUS PROCs195(THESAURUS CONSTs146,BOOL CONSTs196,TEXT
+ CONSTs197,INT CONSTs198,s199):IF NOTinitialized(s194)THENs329FI;s178:=s198;s180
+:=s199;s186:=s197;s184:=s200;s179:=s145;s185:=s200;s231;IFgroesstereditor>s145
+THEN INT VARs201,s202;geteditcursor(s201,s202);IFs150-s179-s149<s202THENs178:=
+s140ELSEs178:=s202;s181:=s180-s178-s149-s179+s140FI FI;IF(s199-s198-s179)<s149OR
+s198<s145ORs199>s150THENerrorstop(s203)FI;THESAURUS VARs204:=emptythesaurus;s191
+:=s146;INT VARs205;s177:=s145;FORs205FROMs140UPTOhighestentry(s146)REP IFname(
+s146,s205)<>s200THENs177INCRs140;s190[s177]:=name(s146,s205)FI PER;IFs177=s145
+THEN LEAVEs195WITHs204FI;s236;s189:=FALSE;s237(s196);IFs189THEN LEAVEs195WITH
+s204FI;cursor(s140,s180);out(s206);s207;s204.s207:TEXT VARs208;WHILEs184<>s200
+REPs208:=subtext(s184,s140,s209);s184:=subtext(s184,s210);insert(s204,s190[int(
+s208)])PER ENDPROCs195;PROCs211:cursor(s140,s179+s182+s178);out(s214(s183,TRUE)+
+s212*s213)ENDPROCs211;TEXT PROCs214(INT CONSTs215,BOOL CONSTs216):INT VARs217:=
+s307(s215);IFs217=s145THENs221ELSEs218FI.s218:IFs216THEN(s209-length(text(s217))
+)*s163+text(s217)+s219ELSEtext(s217,s209)+s220FI.s221:IFs216THENs222ELSEs212*
+s139FI ENDPROCs214;PROCs223(INT CONSTs224):cursor(s140,s179+s178);INT VARs205;
+s227;FORs205FROMs224UPTOs230REPout(s214(s205,FALSE));putline(s225+s190[s205]+
+s225+s206)PER;s229;IFs230<s224+s181THENout((s224+s181-s177)*s226);out(s206)FI.
+s227:IFs182=s183THENout(s228*s163)ELSEout(s161)FI;line.s229:IF NOT((s183+s181-
+s182)<=s177)ORs230=s177THENout(s228*s163)ELSEout(s161)FI.s230:min(s177,s224+s181
+)ENDPROCs223;PROCs231:IFpos(s186,s152)>s145THENs232ELIFs186<>s200ANDlength(s186)
+<s137THENs185CATs186;s185CATs156;s179:=s140ELIFs186<>s200THENs232FI;IFs179>s180-
+s178-s149THENs179:=s180-s178-s149FI;s181:=s180-s178-s149-s179+s140.s232:s187:=
+s186;REPs179INCRs140;s233;s185CATsubtext(s187,s140,pos(s187,s152)-s140);s185CAT
+s156;s187:=subtext(s187,pos(s187,s152)+s140);UNTILpos(s187,s152)=s145PER;IFs187
+<>s200THENs185CATs187;s185CATs156;s179INCRs140FI.s233:IF(pos(s187,s152)>s137OR
+pos(s187,s152)=s145)ANDlength(s187)>s137THENs234FI.s234:INT VARs205;FORs205FROM
+s137DOWNTOs235REP UNTIL(s187SUBs205)=s139PER;s187:=subtext(s187,s140,s205)+s152+
+subtext(s187,s205+s140)+s152ENDPROCs231;PROCs236:cursor(s140,s178);out(s185);
+s183:=s140;s182:=s140;s223(s140);s211ENDPROCs236;PROCs237(BOOL CONSTs196):s188:=
+FALSE;REPs238;s240UNTILs188PER.s238:TEXT VARs239;inchar(s239,s153).s240:SELECT
+pos(s153,s239)OF CASEs166:s242(s196)CASEs167:s260(s196)CASEs168:s293CASEs169:
+s298CASEs170:s276(s196,FALSE);s241CASEs171:s276(s196,TRUE);s241CASEs172:s279CASE
+s173:s279CASEs174:s308(s196)CASEs175:s280;IFs190[s183]<>s200THENs241FI ENDSELECT
+.s241:IF NOTs196THEN LEAVEs237FI ENDPROCs237;PROCs242(BOOL CONSTs196):s243;s240.
+s243:TEXT VARs244;getchar(s244).s240:SELECTpos(s154,s244)OF CASEs145:out(s148)
+CASEs140:s249CASEs144:s254CASEs209,s245:s248CASEs210:s246CASEs212:IFs196THENs247
+ELSEout(s148)FI ENDSELECT.s246:s182:=s140;s223(s183);s211.s247:INT VARs205;FOR
+s205FROMs140UPTOs177REP IFs307(s205)=s145THENs184CATs304(s205)FI PER;s290;s211.
+s248:s184:=s200;s290;s211.s249:IFs250THENout(s148)ELIFs251THENs252ELSEs253FI.
+s250:s183=s140.s251:s182=s140.s252:s183DECR(s181+s140);s183:=max(s183,s140);s223
+(s183);s211.s253:s303;s183DECR(s182-s140);s182:=s140;s211.s254:IFs255THENout(
+s148)ELIFs256THENs257ELSEs259FI.s255:s183=s177.s256:s182>s181.s257:INT VARs258:=
+s183;s183INCR(s181+s140);s183:=min(s183,s177);s182:=s183-s258;s223(s258+s140);
+s211.s259:s303;s258:=s183;s183INCR(s181+s140-s182);s183:=min(s177,s183);s182INCR
+(s183-s258);s211ENDPROCs242;PROCs260(BOOL CONSTs196):TEXT VARs244;getchar(s244);
+SELECTpos(s155,s244)OF CASEs145:out(s148)CASEs140:s188:=TRUE CASEs144:s273CASE
+s209:s274CASEs245:s189:=TRUE;s188:=TRUE CASEs210,s212:IFs196THENs272ELSEout(s148
+)FI CASEs261,s262:IFs196THENs268ELSEout(s148)FI CASEs263:s264ENDSELECT.s264:
+THESAURUS VARs265:=emptythesaurus;TEXT VARs208,s266:=s200;cursor(s140,s180);out(
+center(invers(s267),s163,s137-s140));s205:=s145;WHILEs184<>s200REPs205INCRs140;
+s208:=subtext(s184,s140,s209);s184:=subtext(s184,s210);insert(s265,s190[int(s208
+)]);s266CATs304(s205)PER;s177:=s145;s184:=s266;s191:=s265+s191;FORs205FROMs140
+UPTOhighestentry(s191)REP IFname(s191,s205)<>s200THENs177INCRs140;s190[s177]:=
+name(s191,s205)FI PER;cursor(s140,s180);out(s206);s236.s268:INT VARs269;FORs269
+FROMs183UPTOs177REP INT VARs270:=s307(s269);IFs270<>s145THENs271FI PER;s290;s211
+.s271:s184:=subtext(s184,s140,s245*s270-s245)+subtext(s184,s245*s270+s140).s272:
+INT VARs205;FORs205FROMs183UPTOs177REP IFs307(s205)=s145THENs184CATs304(s205)FI
+ PER;s290;s211.s273:IFs183=s140THENout(s148)ELIFs183=s182THENs303;s183:=s140;
+s182:=s140;s211ELSEs183:=s140;s182:=s140;s223(s140);s211FI.s274:IFs183=s177THEN
+out(s148)ELIFs275THENs303;s182INCR(s177-s183);s183:=s177;s211ELSEs183:=s177;s182
+:=s181+s140;s223(s177-s181);s211FI.s275:(s182+s177-s183)<s181+s140ENDPROCs260;
+PROCs276(BOOL CONSTs196,s277):INT VARs217:=s307(s183);IFs217<>s145THENout(s148);
+s278;LEAVEs276FI;s184CATs304(s183);IFs196THENs278FI.s278:IFs277THENs211ELSE IF
+s183<s177THENs298FI;IFs183=s177THENs211FI FI ENDPROCs276;PROCs279:INT VARs270:=
+s307(s183);IFs270=s145THENout(s148);LEAVEs279FI;s271;s303;s290;s211.s271:s184:=
+subtext(s184,s140,s245*s270-s245)+subtext(s184,s245*s270+s140)ENDPROCs279;PROC
+s280:IFs177=s151THENout(s148);LEAVEs280FI;s281;s282;s289.s281:INT VARs205;FOR
+s205FROMs177DOWNTOs183REPs190[s205+s140]:=s190[s205]PER;s190[s183]:=s225;s177
+INCRs140;s288;s184CATs304(s183);s289.s282:INT VARs217:=s307(s183);cursor(s140,
+s179+s182+s178);out(s206+(s209-length(text(s217)))*s163+text(s217)+s283);push(
+s284);editget(s190[s183]);IF(s286SUBlength(s286))=s225THENs286:=subtext(s286,
+s140,length(s286)-s140)FI;IFs190[s183]=s200THENs279;s287ELSEcursor(s140,s179+
+s182+s178);putline(s212*s285+s225+s190[s183]+s225)FI.s286:s190[s183].s287:FOR
+s205FROMs183UPTOs177-s140REPs190[s205]:=s190[s205+s140];change(s184,s304(s205+
+s140),s304(s205))PER;s177DECRs140.s288:FORs205FROMs177-s140DOWNTOs183REPchange(
+s184,s304(s205),s304(s205+s140))PER.s289:s223(s183-(s182-s140));s290;s211ENDPROC
+s280;PROCs290:INT VARs291,s292,s205;s291:=s183-s182+s140;s292:=min(s291+s181,
+s177);cursor(s140,s179+s140+s178);FORs205FROMs291UPTOs292REPout(s214(s205,FALSE)
+);linePER ENDPROCs290;PROCs293:IFs294THENs295ELSEout(s148)FI.s294:s183>s140.s295
+:IFs182=s140THENs296ELSEs297FI.s296:s183DECRs140;s223(s183);s211.s297:s303;s183
+DECRs140;s182DECRs140;s211ENDPROCs293;PROCs298:IFs299THENs300ELSEout(s148)FI.
+s299:s183<s177.s300:IFs182>s181THENs301ELSEs302FI.s301:s183INCRs140;s223(s183-
+s181);s211.s302:s303;s183INCRs140;s182INCRs140;s211ENDPROCs298;PROCs303:out(s214
+(s183,FALSE))ENDPROCs303;TEXT PROCs304(INT CONSTs305):text(s305,s209)+s306
+ENDPROCs304;INT PROCs307(INT CONSTs215):IFpos(s184,s304(s215))=s145THENs145ELSE(
+pos(s184,s304(s215))DIVs245)+s140FI ENDPROCs307;PROCs308(BOOL CONSTs309):modify(
+s192);IFs309THENheadline(s192,s310);ELSEheadline(s192,s311);FI;toline(s192,s140)
+;openeditor(groesstereditor+s140,s192,FALSE,s140,s178,s228,s180-s178+s140);edit(
+groesstereditor,s312,PROC(TEXT CONST)stdkommandointerpreter);s236ENDPROCs308;
+THESAURUS PROCsome(THESAURUS CONSTs146,TEXT CONSTs313,INT CONSTs198,s199):s195(
+s146,TRUE,s313,s198,s199)ENDPROCsome;THESAURUS PROCsome(THESAURUS CONSTs146):
+some(s146,center(invers(s160)),s140,s150)ENDPROCsome;THESAURUS PROCsome:s195(all
+,TRUE,center(invers(s160)),s140,s150)ENDPROCsome;THESAURUS PROCsome(TEXT CONST
+s314):some(ALLs314)ENDPROCsome;THESAURUS PROCsome(TASK CONSTs315):some(ALLs315)
+ENDPROCsome;THESAURUS OP SOME(THESAURUS CONSTs316):some(s316)ENDOP SOME;
+THESAURUS OP SOME(TASK CONSTs317):some(ALLs317)ENDOP SOME;THESAURUS OP SOME(TEXT
+ CONSTs314):some(ALLs314)ENDOP SOME;TEXT PROCone(THESAURUS CONSTs146,TEXT CONST
+s318,INT CONSTs198,s199):name(s195(s146,FALSE,s318,s198,s199),s140)ENDPROCone;
+TEXT PROCone(THESAURUS CONSTs146):one(s146,center(invers(s159)),s140,s150)
+ENDPROCone;TEXT PROCone(TASK CONSTs315):one(ALLs315)ENDPROCone;TEXT PROCone:one(
+all)ENDPROCone;TEXT PROCone(TEXT CONSTs314):one(ALLs314)ENDPROCone;PROCeditone:
+TEXT CONSTs319:=one(all,center(invers(s159))+s152+center(invers(s320)),s140,s150
+);IFs319<>s200CAND(NOTexists(s319)CORtype(old(s319))=s176)THENedit(s319)FI
+ ENDPROCeditone;PROCeditsome:THESAURUS CONSTs321:=some(all,center(invers(s160))+
+s152+center(invers(s320)),s140,s150);INT VARs205;FORs205FROMs140UPTOhighestentry
+(s321)REP TEXT VARs319:=name(s321,s205);IFs319<>s200CAND(NOTexists(s319)CORtype(
+old(s319))=s176)THENedit(s319)FI PER ENDPROCeditsome;PROCreorganize(THESAURUS
+ CONSTs146):page;do(PROC(TEXT CONST)s322,s146)ENDPROCreorganize;PROCs322(TEXT
+ CONSTs323):IFtype(old(s323))=s176THENput(s324+center(invers(s225+s323+s225),
+s139,s325)+s326);reorganize(s323)ELSEput(s327+center(invers(s225+s323+s225),s139
+,s325)+s328)FI;lineENDPROCs322;PROCs329:s193:=nilspace;s192:=sequentialfile(
+output,s193);putline(s192,s330);line(s192);putline(s192,s331);line(s192);putline
+(s192,s332);putline(s192,s333);putline(s192,s334);putline(s192,s335);putline(
+s192,s336);putline(s192,s337);putline(s192,s338);putline(s192,s339);line(s192);
+putline(s192,s340);line(s192);putline(s192,s341);putline(s192,s342);line(s192);
+putline(s192,s343);putline(s192,s344);putline(s192,s345);putline(s192,s346);
+putline(s192,s347);putline(s192,s348);putline(s192,s349);line(s192);putline(s192
+,s350);putline(s192,s351);line(s192);putline(s192,s352);line(s192);putline(s192,
+s353);line(s192);putline(s192,s354);putline(s192,s355);line(s192);putline(s192,
+s356);ENDPROCs329;ENDPACKETmpgsome;PACKETmpgdmDEFINESdm:LETs364="PUBLIC",s374="k
+",s375="q",s377="",s379=27,s380=" ",s381="V O R M O N I T O R ",s382=4,s383="t",
+s384="Task einstellen, mit der kommuniziert werden soll",s385="p",s386="Es soll
+ mit 'PUBLIC' kommuniziert werden",s387="v",s388="Es soll mit der Vatertask
+ kommuniziert werden",s389="a",s390="Es soll mit dem Archiv kommuniziert werd
+en",s391="Programm beenden",s393="Bitte Eingabe :",s394="tvapq",s395=0,s397="tva
+p",s399="ARCHIVE",s402=1,s403=20,s404=""7""15"FEHLER: ",s405=""14"",s407=14,s408
+="Neue Task:",s409="Mit der eigenen Task kann nicht kommuniziert werden.",s416=2
+,s417="Task ist nicht im Wartezustand",s420=15,s423="ARCHIVE ist nicht im Wartez
+ustand",s428=5,s429=" Erst Diskette einlegen !",s430=100,s432=24,s433="D A T E I
+ M O N I T O R ",s434=3,s435="Auflisten aller Dateien in dieser Task",s436="l",
+s437="Loeschen von Dateien in dieser Task",s438="Archiv: ",s439="Task : ",
+s440=40,s441="'",s442=" ...",s443="""",s447="des Archivs",s448="zum Archiv",s449
+="vom Archiv",s450="in ",s451="zu ",s452="von ",s453="u",s454="Uebersicht uebe
+r alle Dateien ",s455="s",s456="Senden von Dateien ",s457="h",s458="H
+olen von Dateien ",s459="c",s460="'Checken' von Dateien ",
+s461="Vernichten von Dateien ",s462="d",s463="Drucken einer Liste der Dat
+eien des Archivs",s464="f",s465="Formatieren einer Diskette",s466="i",s467="Init
+ialisieren/vollstaendiges Loeschen des Archivs",s468="n",s469="Neue Diskette anm
+elden",s470="Zurueck zum Vormonitor",s472=" Bitte warten...",s473=6,s474=7,
+s475=8,s476=9,s477=10,s478=11,s479=12,s482=""15"",s483=" "14"",s484=" ... ",s486
+="Formatieren einer Diskette.",s487="===========================",s488=""15"Acht
+ung: Alle Disketten-Informationen werden gel"218"scht!"14"",s489="Dies sind die
+moeglichen Formate:",s490="o",s491="... Ohne Format-Angabe",s492="0",s493="... S
+tandard-Format",s494="1",s495="... 40 Spur - 360 KB",s496="2",s497="... 80 Spur
+ - 720 KB",s498="3",s499="... IBM Std - 1200 KB",s500="... Es wird nicht format
+iert.",s502="Ihre Wahl:",s503="o01234q",s504="zuk"219"nftiger Name des Archives
+:",s508="Liste der eigenen Task",s510="Loeschen von Dateien ",s511=" Info mit <
+?>",s512="Bitte alle zu loeschenden Dateien ankreuzen",s513="(Ankreuzen mit <RET
+URN> )",s516="Bitte warten...",s521="nicht reserviert",s522="Haben Sie die Diske
+tte eingelegt und das Laufwerk geschlossen",s524=""15"Sie muessen unbedingt erst
+ das Archiv reservieren, "14"",s525=""15"sonst kann ich nicht darauf zugreifen!
+"14"",s527="Dateiliste",s533=""15"'Checken' von Dateien (auf dem Archiv) "14"",
+s534="Bitte alle zu 'checkenden' Dateien ankreuzen",s537=""15"Schreiben von Date
+ien "14" Info mit <?>",s538="Bitte alle zu schreibenden Dateien ankreuzen.",s542
+=" <--- """,s544="Bitte Warten",s545="-",s546=80,s548="Zuerst Dateien auf der Di
+skette loeschen?",s553=""15"Holen von Dateien "14" Info mit <?>",s554="Bitte al
+le zu holenden Dateien ankreuzen.",s555=" --> """,s558=""15"Vernichten (Loeschen
+) von Dateien "14" Info mit <?>",s559="Bitte alle zu loeschenden Dateien ankreuz
+en.",s562=""15"Vollstaendiges Loeschen des Archivs "14"",s563="Eingestellter Arc
+hivname: ",s564="Moechten Sie einen anderen Namen fuer das Archiv",s566="Bitte d
+en Namen fuer das Archiv (maximal 30 Buchstaben):",s567="Der neue Archivname ist
+ zu lang!",s569="Bitte Fehler beseitigen und Vorgang wiederholen!",s576="keine d
+iskette",s577=""15"Ich mache die Reservierung rueckgaengig! "14"",s578="inkonsis
+tent",s579=""15"Diskette ist nicht formatiert / initialisiert "14"",s580="Lesen
+unmoeglich",s581="Schreiben unmoeglich",s582=""15"Die Diskette ist falsch eingel
+egt "14"",s583=""15"oder das Laufwerk ist nicht geschlossen "14"",s584=""15"oder
+ die Diskette ist nicht formatiert !"14"",s585="Archiv heisst",s586="?????",s587
+=""15"Diskette nicht lesbar ! (Name: '?????') "14"",s588=""15"Moeglicherweise is
+t die Diskette defekt ! "14"",s589=""15"Diskette wurde mit anderem Namen angemel
+det!"14"",s590="Bitte neu reservieren!",s592="Bitte den Fehler beseitigen und da
+s Archiv neu reservieren !",s594="Zum Weitermachen bitte irgendeine Taste tippen
+!";LETs357=""15"",s358=""14"",s359=""222"",s360=24,s361="alnfqushcvdi",s362="al
+ qush v";TASK CONSTs363:=task(s364);TASK VARs365;BOOL VARs366:=archivangemeldet,
+s367,s368:=FALSE;TEXT VARs369,s370,s371;PROCdm:TEXT VARs372,s373:=
+lernsequenzauftaste(s374);REPs376UNTILs372=s375PER;lernsequenzauftastelegen(s374
+,s373).s376:s365:=s363;s392;IFs372<>s375ANDs370<>s377THENs424FI.s378:s370:=name(
+s365);page;write(s379*s380);write(s357);write(s381);write(s358);line(s382);s480(
+s383,s384);s480(s385,s386);s480(s387,s388);s480(s389,s390);s480(s375,s391).s392:
+IFisincharety(s377)THENs378FI;line;write(s393);inchar(s372,s394);out(s372);line;
+IFpos(s389,s372)=s395CANDs365=archiveTHENs574FI;s396.s396:IFpos(s397,s372)<>s395
+THENs398FI.s398:s370:=s377;IFs372=s389THENs370:=s399ELIFs372=s385THENs370:=s364
+ELIFs372=s387THENs370:=name(father)ELSEs406FI;TEXT VARs400;BOOL VARs401:=s370=
+s377CORs370=s364CORs410(s370,s400);IF NOTs401THENcursor(s402,s403);putline(s404+
+s400+s405);pause;s370:=s377;FI;IFs370=s377THENs365:=s363ELIFs370=s399THENs365:=
+archiveELSEs365:=task(s370)FI.s406:REPcursor(s402,s407);put(s408);editget(s370);
+line;IFs370=name(myself)THENputline(s409)FI;UNTILs370<>name(myself)PER;
+lernsequenzauftastelegen(s374,s370).ENDPROCdm;BOOL PROCs410(TEXT CONSTs411,TEXT
+ VARs412):disablestop;TASK VARs413:=task(s411);IFiserrorTHENs412:=errormessage;
+clearerror;enablestop;FALSE ELSEs414FI.s414:IFs411<>s399THENs415ELSEs422FI.s415:
+IFstatus(s413)<>s416THENs412:=s417;enablestop;FALSE ELSEs418FI.s418:INT CONST
+s419:=s420;DATASPACE VARs421:=nilspace;call(s419,s377,s421,s413);forget(s421);IF
+iserrorTHENs412:=errormessage;clearerror;enablestop;FALSE ELSEs412:=s377;
+enablestop;TRUE FI.s422:IFstatus(archive)<>s416THENs412:=s423;LEAVEs422WITH
+ FALSE FI;archive(s377);IFiserrorTHENs412:=errormessage;clearerror;enablestop;
+FALSE ELSEenablestop;s366:=TRUE;s368:=FALSE;s412:=s377;TRUE FI ENDPROCs410;PROC
+s424:s367:=(s365=archive);TEXT VARs425;IFs367THENs425:=s361ELSEs425:=s362FI;TEXT
+ VARs426;INT VARs427;s368:=FALSE;IFs367THENs514FI;REP IFisincharety(s377)THEN
+s431FI;line;write(s393);inchar(s426,s425);s427:=pos(s361,s426);IFs427>s428AND
+ NOTs368ANDs367THENline;putline(s429);pause(s430)ELIFs426<>s380THENs471FI UNTIL
+s426=s375PER;IFarchivangemeldetTHENs574FI.s431:page;write(s432*s380);write(s357)
+;write(s433);write(s358);line(s434);s480(s389,s435);s480(s436,s437);line(s416);
+write(s420*s380);IFs367THENwrite(s438)ELSEwrite(s439)FI;IFs367THEN IFs368THEN IF
+length(s369)>s440THENwrite(s441+subtext(s369,s402,s440)+s442)ELSEwrite(invers(
+s443+s369+s443))FI FI ELSEwrite(invers(s443+s370+s443))FI;line(s416);TEXT VAR
+s444,s445,s446;IFs367THENs444:=s447;s445:=s448;s446:=s449ELSEs444:=s450+s370;
+s445:=s451+s370;s446:=s452+s370FI;s480(s453,s454+s444);s480(s455,s456+s445);s480
+(s457,s458+s446);IFs367THENs480(s459,s460+s444)FI;s480(s387,s461+s444);IFs367
+THENs480(s462,s463);s480(s464,s465);s480(s466,s467);s480(s468,s469);FI;line(s402
+);s480(s375,s470).s471:out(s380+s426+s472);SELECTs427OF CASEs402:s505CASEs416:
+s509CASEs434:s572CASEs382:s485CASEs428:CASEs473:s526CASEs474:s535CASEs475:s551
+CASEs476:s531CASEs477:s556CASEs478:s570CASEs479:s560ENDSELECT ENDPROCs424;PROC
+s480(TEXT CONSTs413,s481):putline(s475*s380+s482+s413+s483+s484+s481)ENDPROCs480
+;PROCs485:page;putline(s486);putline(s487);putline(s488);line;putline(s489);s480
+(s490,s491);s480(s492,s493);s480(s494,s495);s480(s496,s497);s480(s498,s499);s480
+(s375,s500);TEXT VARs501;put(s502);inchar(s501,s503);IFs501=s375THEN LEAVEs485FI
+;out(s501);line;put(s504);editget(s369);line;archive(s369);s368:=TRUE;
+disablestop;IFs501=s490THENformat(archive)ELSEformat(int(s501),archive)FI;IF
+iserrorTHENs595(errormessage);clearerror;s368:=FALSE ELSEs369:=archivnameFI;
+enablestopENDPROCs485;PROCs505:DATASPACE VARs506:=nilspace;FILE VARs507:=
+sequentialfile(output,s506);list(s507);headline(s507,s508);modify(s507);toline(
+s507,s402);show(s507);forget(s506)ENDPROCs505;PROCs509:s371:=center(invers(s510)
++s511)+s359+center(s512)+s359+center(invers(s513));forget(some(all,s371,s402,
+s360))ENDPROCs509;PROCs514:TEXT VARs515;page;cursor(s402,s402);write(s516);line(
+s416);s517(s515);IFs515<>s377THENpage;line(s477);write(s482+s515+s483);s593;s368
+:=FALSE;s366:=FALSE;LEAVEs514FI;s519(s369,s515);IFs515<>s377THENs575(s515)FI.
+ENDPROCs514;PROCs517(TEXT VARs518):s518:=s377;IFs366THEN LEAVEs517FI;disablestop
+;archive(s377);IFiserrorTHENs518:=errormessage;s366:=FALSE;clearerror;enablestop
+;ELSEs366:=TRUE;s518:=s377;enablestopFI ENDPROCs517;PROCs519(TEXT VARs520,s518):
+page;line(s434);s518:=s377;IF NOTs366THENs520:=s377;s368:=FALSE;s518:=s521;LEAVE
+s519FI;IFyes(s522)THENline;write(s516);s520:=archivname;IFarchiverror<>s377THEN
+s518:=archiverror;s368:=FALSE ELSEs368:=TRUE FI ELSEs368:=FALSE;s520:=s377FI
+ ENDPROCs519;PROCs523:page;line(s474);write(s524);line(s416);write(s525);line(
+s416);s593ENDPROCs523;PROCs526:forget(s527,quiet);s528;s529;s530;forget(s527,
+quiet).s528:IFs367ANDs368AND NOTs366THENs523;LEAVEs526FI.s529:FILE VARs507:=
+sequentialfile(output,s527);disablestop;list(s507,s365);IFiserrorTHENpage;IFs367
+THENs575(errormessage)FI;clearerror;enablestop;LEAVEs526;ELSEenablestopFI.s530:
+show(s507)ENDPROCs526;PROCs531:s528;s532.s528:IFs367ANDs368AND NOTs366THENs523;
+LEAVEs531FI.s532:s371:=center(s533)+s359+center(s534);disablestop;check(some(ALL
+s365,s371,s402,s360),s365);s593;IFiserrorTHEN IFs367THENs575(errormessage)FI;
+clearerror;enablestop;LEAVEs531ELSEenablestop;FI ENDPROCs531;PROCs535:s528;s536.
+s528:IFs367ANDs368AND NOTs366THENs523;LEAVEs535FI.s536:s371:=center(s537)+s359+
+center(s538)+s359+center(invers(s513));THESAURUS VARs539:=some(ALLmyself,s371,
+s402,s360);s543;INT VARs540;TEXT VARs541;page;FORs540FROMs402UPTOhighestentry(
+s539)REPs541:=name(s539,s540);disablestop;IFs541<>s377THENputline(s370+s542+s541
++s443);save(s541,s365)FI;IFiserrorTHEN IFs367THENs575(errormessage)FI;clearerror
+;enablestop;LEAVEs535FI;enablestopPER.s543:IFs367CAND(s549(s539))THENout(center(
+invers(s544),s545,s546));THESAURUS CONSTs547:=s539/ALLs365;IFs549(s547)THENpage;
+putline(s548);erase(s547,s365)FI FI ENDPROCs535;BOOL PROCs549(THESAURUS CONST
+s413):INT VARs550;FORs550FROMs402UPTOhighestentry(s413)REP IFname(s413,s550)<>
+s377THEN LEAVEs549WITH TRUE FI PER;FALSE ENDPROCs549;PROCs551:s528;s552.s528:IF
+s367ANDs368AND NOTs366THENs523;LEAVEs551FI.s552:s371:=center(s553)+s359+center(
+s554);THESAURUS VARs539:=some(ALLs365,s371,s402,s360);INT VARs540;TEXT VARs541;
+page;FORs540FROMs402UPTOhighestentry(s539)REPs541:=name(s539,s540);disablestop;
+IFs541<>s377THENputline(s370+s555+s541+s443);fetch(s541,s365)FI;IFiserrorTHEN IF
+s367THENs575(errormessage)FI;clearerror;enablestop;LEAVEs551ELSEenablestopFI PER
+ ENDPROCs551;PROCs556:s528;s557.s528:IFs367ANDs368AND NOTs366THENs523;LEAVEs556
+FI.s557:s371:=center(s558)+s359+center(s559);disablestop;erase(some(ALLs365,s371
+,s402,s360),s365);IFiserrorTHEN IFs367THENs575(errormessage)FI;clearerror;
+enablestop;LEAVEs556ELSEenablestop;FI ENDPROCs556;PROCs560:TEXT VARs561;page;
+line(s416);write(center(s562));line(s416);IFs366ANDs368THENwrite(s563+invers(
+s443+s369+s443));line(s416);IFyes(s564)THENline(s416);s565ELSEs561:=s369FI ELSE
+s565FI;s568.s565:write(s566);line;getline(s561);s561:=compress(s561);IFlength(
+s561)>s440THENline(s416);write(s567);s593;LEAVEs560FI.s568:disablestop;s369:=
+s561;archive(s561);IFiserrorTHENs595(errormessage);line;write(s569);clearerror;
+enablestop;s593;s368:=FALSE;s366:=FALSE;LEAVEs560ELSEclear(archive);IFiserror
+THENpage;line(s416);s575(errormessage);clearerror;enablestop;s593;s368:=FALSE;
+LEAVEs560ELSEs369:=archivname;s368:=archiverror=s377FI FI ENDPROCs560;PROCs570:
+s528;s571;s593.s528:IFs367ANDs368AND NOTs366THENs523;LEAVEs570FI.s571:pla(FALSE)
+.ENDPROCs570;PROCs572:s528;s573.s528:IF NOTs366THENs514;LEAVEs572FI.s573:TEXT
+ VARs515;page;cursor(s402,s402);write(s516);line(s416);s519(s369,s515);IFs515<>
+s377THENs575(s515)FI.ENDPROCs572;PROCs574:s366:=FALSE;s368:=FALSE;
+commanddialogue(FALSE);release(archive);commanddialogue(TRUE)ENDPROCs574;PROC
+s575(TEXT CONSTs515):line(s416);IFs515=s521THENs523;ELIFs515=s576THENwrite(s577)
+;s591ELIFpos(s515,s578)>s395THENwrite(s579);s591;ELIFpos(s515,s580)>s395CORpos(
+s515,s581)>s395THENwrite(s582);line(s416);write(s583);line(s416);write(s584);
+s591;ELIFpos(s515,s585)>s395ANDpos(s515,s586)>s395THENwrite(s587);line(s416);
+write(s588);s591;ELIFpos(s515,s585)>s395THENwrite(invers(s515));line(s416);write
+(s589);line(s416);write(s590);s593ELSEwrite(invers(s515));s591FI ENDPROCs575;
+PROCs591:line(s416);write(s592);s593;s368:=FALSE ENDPROCs591;PROCs593:line(s416)
+;write(s594);pauseENDPROCs593;PROCs595(TEXT CONSTs515):page;line(s477);write(
+invers(s515));s593ENDPROCs595ENDPACKETmpgdm;PACKETmpgtoolsDEFINESput,th,gen:LET
+s596="E",s597=""27""2""27"p"27"qedit ("27"g)"13"",s599="TRUE",s600="FALSE",s606=
+"***",s607="-->",s608=""13""10"",s610=77,s611="=",s612=" wird insertiert"13""10"
+",s619="gen.",s622=0,s623="GENERIERUNG VON ",s624=16,s626=1,s627=2,s628="Bitte e
+ntfernen Sie Ihre Diskette aus dem Laufwerk!",s630="global manager";
+lernsequenzauftastelegen(s596,s597);PROCput(BOOL CONSTs598):IFs598THENput(s599)
+ELSEput(s600)FI ENDPROCput;PROCth(THESAURUS CONSTs601):THESAURUS VARs602:=SOME
+s601;s602:=emptythesaurusENDPROCth;BOOL VARs603:=FALSE;PROCs604(TEXT CONSTs605):
+IFexists(s605)THENdisplay(s606)ELSE IF NOTs603THENarchiv;s603:=TRUE FI;display(
+s607);from(s605)FI;display(s605+s608)ENDPROCs604;PROCs609(TEXT CONSTs605):line;
+out(s610*s611+s608);out(s605+s612);insert(s605);forget(s605,quiet)ENDPROCs609;
+LETs613=20;ROWs613TEXT VARs614;INT VARs615,s616;PROCgen:TEXT CONSTs617:=name(
+myself),s618:=s619+s617;TEXT VARs620;BOOL VARs621:=TRUE;s603:=FALSE;s615:=s622;
+s616:=s622;page;putline(s623+s617);putline((s624+length(s617))*s611);s604(s618);
+FILE VARs625:=sequentialfile(input,s618);WHILE NOTeof(s625)ANDs616<s613REP
+getline(s625,s620);s620:=compress(s620);IFs620=s618THENs621:=FALSE FI;IFs621THEN
+s615INCRs626FI;s616INCRs626;s604(s620);s614[s616]:=s620PER;forget(s618,quiet);IF
+s603THENrelease;line(s627);put(s628);lineFI;INT VARs629;FORs629FROMs626UPTOs615
+REPs609(s614[s629])PER;IFyes(s630)THENdo(s630)FI.ENDPROCgenENDPACKETmpgtools;
+PACKETtargethandlingDEFINES TARGET,initializetarget,completetarget,
+deleteintarget,selecttarget,actualtargetname,actualtargetset,targetnames:LETs638
+="Bezeichner bereits vorhanden",s640=0,s641="";TYPE TARGET=STRUCT(INTs631,
+THESAURUSs632,s633);LETs634=0;PROCinitializetarget(TARGET VARs635):s635.s633:=
+emptythesaurus;s635.s632:=emptythesaurus;s635.s631:=s634ENDPROCinitializetarget;
+PROCcompletetarget(TARGET VARs635,TEXT CONSTs636,s637):IF NOT(s635.s632CONTAINS
+s636)THENinsert(s635.s632,s636);insert(s635.s633,s637)ELSEerrorstop(s638)FI
+ ENDPROCcompletetarget;PROCdeleteintarget(TARGET VARs635,TEXT CONSTs636):INT
+ CONSTs639:=link(s635.s632,s636);delete(s635.s632,s639);delete(s635.s633,s639);
+s635.s631:=s634ENDPROCdeleteintarget;PROCselecttarget(TARGET VARs635,TEXT CONST
+s636,TEXT VARs637):INT VARs639:=link(s635.s632,s636);IFs639<>s640THENs637:=name(
+s635.s633,s639);s635.s631:=s639ELSEs637:=s641FI ENDPROCselecttarget;TEXT PROC
+actualtargetname(TARGET CONSTs635):IFs635.s631=s634THENs641ELSEname(s635.s632,
+s635.s631)FI ENDPROCactualtargetname;TEXT PROCactualtargetset(TARGET CONSTs635):
+IFs635.s631=s634THENs641ELSEname(s635.s633,s635.s631)FI ENDPROCactualtargetset;
+THESAURUS PROCtargetnames(TARGET CONSTs635):s635.s632ENDPROCtargetnamesENDPACKET
+targethandling;PACKETmpgprintcmdDEFINESprint,selectprinter,installprinters,
+listprinters,printer,printers:LETs650="",s654=1,s656=24,s660=0;TARGET VARs642;
+LETs643="PRINTER",s644="PRINTER AUSWAHL";LETs645=""222"";TARGET PROCprinters:
+s642ENDPROCprinters;PROCinstallprinters(FILE VARs646):initializetarget(s642);
+TEXT VARs647,s648;TEXT VARs649:=s650,s651:=s650;WHILE NOTeof(s646)REP TEXT VAR
+s652;getline(s646,s652);IFs652<>s650THEN INT CONSTs653:=pos(s652,s645);s647:=
+subtext(s652,s654,s653-s654);s648:=subtext(s652,s653+s654);completetarget(s642,
+s647,s648);IFint(s647)=station(myself)THENs649:=s647;s651:=s648FI FI PER;
+selecttarget(s642,s649,s651);IFs651<>s650THENfonttable(s651)FI ENDPROC
+installprinters;PROCselectprinter:TEXT VARs655;selecttarget(s642,one(targetnames
+(s642),s644,s654,s656),s655);IFs655<>s650THENfonttable(s655)FI ENDPROC
+selectprinter;PROClistprinters:th(targetnames(s642))ENDPROClistprinters;PROC
+print:print(lastparam)ENDPROCprint;PROCprint(TEXT CONSTs657):save(s657,printer)
+ENDPROCprint;PROCprint(THESAURUS CONSTs658):save(s658,printer)ENDPROCprint;TASK
+ PROCprinter:INT VARs659:=int(actualtargetname(s642));IFs659=s660THENniltaskELSE
+s659/s643FI ENDPROCprinterENDPACKETmpgprintcmd;PACKETeditmonitorDEFINES
+editmonitor,close,F,table:LETs670="quitmonitor:1.0edit:2.1run:3.1insert:4.1",
+s671="forget:5.1rename:6.2copy:7.2fetch:8.1",s672="save:9.1close:10.1fileinfo:11
+.0reorganize:12.1",s684=0,s689="",s698="Q",s702=""1""8""1""12"quitmonitor"13"",
+s703=1,s704="Editmonitor overflow: Bereits ",s705="Monitore geoeffnet",s708="
+"10"",s711=22,s715=""3"",s716=" ",s717=""13""10" ",s718="fk",s719="
+"27"k",s720=""13""5"",s721="f",s722=7,s725=50,s728=4,s730=""1"",s731=2,s732=" :
+",s733="""",s734=""5""10""13"",s735=""5"",s737=5,s738=" ",s739=11,s740="=",s741=
+16,s742=" ",s745=3,s746=6,s747=8,s748=9,s749=10,s750=12,s754=""7"",s765="Maxima
+l 10 Parallel-Editoren",s774=79,s775=25,s776=24,s778="Undefinierter Index [1;15]
+",s780=""5"? ",s781=""13""10"",s782=""2"",s783="Datei neu einrichten",s795=120;
+LETs661=18,s662=15,s663=1003,s664=24,s665=3,s666=4711,s667="Gib Edit-Monitor ",
+s668=" Kommando :";TEXT CONSTs669:=s670+s671+s672;LET SGHD=ROWs662STRUCT(
+THESAURUSs674,TEXTs675,FILEs676);LETs677=0,s678=1,s679=2;INT VARs680,s681,s682,
+s683:=s684,s685;TEXT VARs686,s687,s688:=s689,s690:=s689;BOOL VARs691,s692:=FALSE
+,s693:=FALSE;INITFLAG VARs694;SGHD VARs695;PROCeditmonitor:TEXT VARs696,s697:=
+lernsequenzauftaste(s698);INT VARs699,s700:=heapsize;disablestop;s701;s756;REP
+s706;s712;s743;s727UNTILs693PER;lernsequenzauftastelegen(s698,s697);s726.s701:
+lernsequenzauftastelegen(s698,s702);s693:=FALSE;s683INCRs703;IFs683>s662THENs683
+DECRs703;errorstop(s704+text(s662)+s705)ELSE IF NOTinitialized(s694)THEN FORs699
+FROMs703UPTOs662REPs695[s699].s674:=emptythesaurus;s695[s699].s675:=s689PER FI;
+FORs699FROMs703UPTOs662REPs695[s699].s675:=name(s695[s683].s674,s699)PER FI.s706
+:s707;s729.s707:out(s708);INT VARs709,s710;getcursor(s709,s710);FORs709FROMs703
+UPTOs710-s711REPout(s708)PER;s685:=max(s661,min(s710+s703,s711)).s712:BOOL VAR
+s713:=FALSE,s714:=FALSE;IFiserrorTHENs690:=s688;out(s715);puterror;clearerror;
+s714:=TRUE ELSEs690:=s689FI;out(s716);out(s798);out(s717);IF NOTs714THENs723FI;
+IFs713THENs680:=s666;LEAVEs712FI;editget(s690,s689,s718,s696);IFs696=s719THENout
+(s720);s690:=s688;out(s716);editget(s690,s689,s721,s696)FI;line;s688:=s690;s680
+:=s796(s690);paramposition(LENGTHs690+s722);IF(s680>s684ANDs680<=s662)ANDs682>
+s684THENs691:=TRUE ELSEs691:=FALSE;analyzecommand(s669,s690,s665,s680,s681,s686,
+s687)FI.s723:BOOL VARs724;s696:=getcharety;IFs696<>s689THENpush(s696);LEAVEs723
+FI;s696:=incharety(s725);IFs696<>s689THENtype(s696);LEAVEs723FI;FORs699FROMs703
+UPTOs662REPreorganize(s695[s699].s675,s713,s724,s699);UNTILs724ORs713PER.s726:
+s683DECRs703;s680:=s684;s693:=s683=s684;IFs683>s684THEN FORs699FROMs703UPTOs662
+REPs695[s699].s675:=name(s695[s683].s674,s699)PER;ELSEs686:=s689;s687:=s689;s690
+:=s689;s688:=s689FI.s727:IFheapsize>s700+s728THENcollectheapgarbage;s700:=
+heapsizeFI ENDPROCeditmonitor;PROCs729:INT VARs699;out(s730);FORs699FROMs703UPTO
+s662WHILE NOTisincharetyREPout(text(s699,s731));out(s732);IFs692THENs736FI;IF
+s695[s699].s675<>s689THENout(s733+s695[s699].s675+s733)FI;out(s734)PER;out(s735)
+;cursor(s703,s685).s736:IFexists(s695[s699].s675)THEN IFtype(old(s695[s699].s675
+))=s663THENout(text(lines(s695[s699].s676),s737));out(s738);out(text(segments(
+s695[s699].s676),s728));out(s738)ELSEout(s739*s740)FI;out(text(storage(old(s695[
+s699].s675)),s737))ELIFs695[s699].s675<>s689THENout(s741*s740)FI;out(s742).
+ENDPROCs729;PROCs743:enablestop;IFs680=s666THEN LEAVEs743FI;IFs691THENs761(s680)
+ELSEs744FI.s744:SELECTs680OF CASEs703:s693:=TRUE CASEs731:edit(s785(s686))CASE
+s745:run(s785(s686))CASEs728:insert(s785(s686))CASEs737:forget(s785(s686));close
+(int(s686))CASEs746:rename(s785(s686),s785(s687))CASEs722:copy(s785(s686),s785(
+s687))CASEs747:fetch(s785(s686))CASEs748:save(s785(s686))CASEs749:close(int(s686
+))CASEs739:s692:=NOTs692CASEs750:reorganize(s785(s686))OTHERWISEdo(s690)
+ENDSELECT ENDPROCs743;PROCclose(INT CONSTs751):IF(s751>s684ANDs751<=s662)CAND
+s695[s751].s675<>s689THEN IFexists(s695[s751].s675)CANDtype(old(s695[s751].s675)
+)=s663THENclose(s695[s751].s676)FI;INT VARs752;delete(s695[s683].s674,s695[s751]
+.s675,s752);s695[s751].s675:=s689FI ENDPROCclose;TEXT OP F(INT CONSTs753):IFs753
+>s684ANDs753<=s662THENs695[s753].s675ELSEout(s754);s689FI ENDOP F;OP F(INT CONST
+s753,TEXT CONSTs755):IFs753>s684ANDs753<=s662THENs695[s753].s675:=s755;insert(
+s695[s683].s674,s755);IFexists(s755)CANDtype(old(s755))=s663THENs695[s753].s676
+:=sequentialfile(modify,s755)FI ELSEout(s754)FI ENDOP F;PROCs756:table(some(all+
+s695[s683].s674+s757)).s757:IFs683=s703THENemptythesaurusELSEs695[s683-s703].
+s674FI ENDPROCs756;THESAURUS PROCtable:THESAURUS VARs758:=emptythesaurus;INT VAR
+s699;FORs699FROMs703UPTOs662REP IFexists(s695[s699].s675)AND NOT(s758CONTAINS
+s695[s699].s675)THENinsert(s758,s695[s699].s675)FI PER;s758ENDPROCtable;PROC
+table(THESAURUS CONSTs759):INT VARs699,s753:=s703,s709;TEXT VARs760;s695[s683].
+s674:=emptythesaurus;FORs699FROMs703UPTOs662REPs695[s699].s675:=s689PER;FORs699
+FROMs703UPTOhighestentry(s759)REPget(s759,s760,s709);IFs760<>s689THENs753Fs760;
+s753INCRs703FI UNTILs753>s662PER ENDPROCtable;PROCs761(INT CONSTs762):enablestop
+;IFs682=s703THENs763ELSEs764FI.s763:SELECTs777(s762)OF CASEs678:lastparam(s695[
+s762].s675);edit(s695[s762].s676);pageCASEs679:do(s695[s762].s675)ENDSELECT.s764
+:IFs682<=s749THENs766;IFgroesstereditor>s684THENedit(s703);WHILEgroesstereditor>
+s684REPquitPER;pageFI ELSEerrorstop(s765)FI.s766:TEXT VARs767,s768:=s689;INT VAR
+s769:=s703,s770:=s762,s771;WHILEgroesstereditor>s684REPquitPER;FORs771FROMs703
+UPTOs731REP IFs771=s731THENs690:=s768FI;scan(s690);nextsymbol(s767);REP INT VAR
+s772:=s777(s770);IFs771=s703THEN SELECTs772OF CASEs677:s682DECRs703CASEs678:s768
+CAT(s767+s738)CASEs679:s768CAT(s767+s738);s682DECRs703ENDSELECT ELSE SELECTs772
+OF CASEs678:s773CASEs679:do(s695[s770].s675);IFgroesstereditor>s684THEN
+bildzeigen;ueberschriftzeigenFI ENDSELECT FI;nextsymbol(s767);s770:=int(s767)
+UNTILs767=s689PER;s770:=s762;PER.s773:openeditor(groesstereditor+s703,s695[s770]
+.s676,TRUE,s703,s769,s774,s775-s769);s769INCR(s776DIVs682)ENDPROCs761;INT PROC
+s777(INT CONSTs762):IFs762>s684ANDs762<=s662THEN IFs695[s762].s675=s689THENs779;
+IFs695[s762].s675<>s689THEN IFexists(s695[s762].s675)THEN IFtype(old(s695[s762].
+s675))=s663THENs678ELSEs677FI ELSEs679FI ELSEs677FI ELIF NOTexists(s695[s762].
+s675)THENs679ELIFtype(old(s695[s762].s675))<>s663THENs677ELSEmodify(s695[s762].
+s676);s678FI ELSEerrorstop(s778);s677FI.s779:cursor(s728,s762);out(s780);editget
+(s695[s762].s675);IFs695[s762].s675<>s689THENs762Fs695[s762].s675;IF NOTexists(
+s695[s762].s675)THENout(s781);IFno(s737*s782+s783)THEN LEAVEs777WITHs677ELSEs784
+FI ELIFtype(old(s695[s762].s675))=s663THENs784FI FI.s784:s695[s762].s676:=
+sequentialfile(output,s695[s762].s675).ENDPROCs777;BOOL PROCisincharety:TEXT VAR
+s696:=getcharety;IFs696=s689THEN FALSE ELSEpush(s696);TRUE FI ENDPROCisincharety
+;TEXT PROCs785(TEXT CONSTs786):INT VARs699:=int(s786);IF(s699>s684ANDs699<=s662)
+THENs695[s699].s675ELSEs786FI.ENDPROCs785;PROCreorganize(TEXT CONSTs755,BOOL VAR
+s787,s788,INT CONSTs789):DATASPACE VARs790;FILE VARs791,s792;TEXT VARs760;INT
+ VARs793,s699,s794,s710;getcursor(s794,s710);s788:=FALSE;IF NOTexists(s755)COR
+type(old(s755))<>s663THEN LEAVEreorganizeFI;s791:=sequentialfile(modify,s755);
+s793:=lineno(s791);input(s791);IF(lines(s791)<s795CANDsegments(s791)<s746)COR
+lines(s791)DIVsegments(s791)>=s664THENmodify(s791);toline(s791,s793);LEAVE
+reorganizeFI;disablestop;s790:=nilspace;s792:=sequentialfile(output,s790);IFs692
+THEN FORs699FROMs703UPTOlines(s791)REPcursor(s728,s789);put(s699);getline(s791,
+s760);putline(s792,s760);IFiserrorCORisincharetyTHENs724FI PER ELSE FORs699FROM
+s703UPTOlines(s791)REPgetline(s791,s760);putline(s792,s760);IFiserrorCOR
+isincharetyTHENs724FI PER FI;copyattributes(s791,s792);modify(s792);toline(s792,
+s793);forget(s755,quiet);copy(s790,s755);forget(s790);s787:=TRUE.s724:cursor(
+s728,lines(s791));forget(s790);s788:=TRUE;cursor(s794,s710);enablestop;LEAVE
+reorganize.ENDPROCreorganize;INT PROCs796(TEXT CONSTs690):INT VARs797,s758:=s684
+;TEXT VARs767;s682:=s684;scan(s690);REPnextsymbol(s767,s797);IFs797=s745THEN IF
+s682=s684THENs758:=int(s767)FI;s682INCRs703ELIFs797<>s722THENs682:=s684FI UNTIL
+s797=s722ORs682=s684PER;s758ENDPROCs796;TEXT PROCs798:s667+text(s683)+s668
+ENDPROCs798;ENDPACKETeditmonitor;PACKETmpgglobalmanagerDEFINESmonitor,break,
+endglobalmanager,begin,beginpassword,managermessage,managerquestion,freemanager,
+stdmanager,mpgmanager,freeglobalmanager,globalmanager:LETs832="",s840="checkoff;
+endglobalmanager(TRUE);",s841="warnings off;sysout("""");sysin("""");",s842="mon
+itor",s847="Task-Passwort :",s848="Beginn-Passwort:",s854=2,s856=1,s860="Kein Z
+ugriffsrecht auf Task """,s861="""",s867="Falscher Auftrag fuer Task """,s875="-
+",s876="Passwort falsch",s881=""" existiert nicht",s882=""" loeschen",s885=""" u
+eberschreiben",s888=" ",s899="break:1.0end:2.0monitor:3.0stdbeginproc:4.1",s900=
+"Gib ",s901="-Kommando :",s902=0,s903=3,s904=4,s916=""3""13""5"",s920=6,s932="gi
+b kommando :",s936=""7"Speicher Engpass! Dateien loeschen!"13""10"",s938=5,s939=
+7,s940=8,s941=9,s942=10,s943=11,s944=12,s945=13,s946=14,s947=15,s948=16,s949=17,
+s950=18,s951=19;LETs799=0,s800=1,s801=2,s802=3,s803=4,s804=5,s805=6,s806=4,s807=
+9,s808=11,s809=12,s810=13,s811=14,s812=15,s813=17,s814=24,s815=100,s816=""7""13"
+"10""5"Fehler : ",s817=""13""10"";DATASPACE VARs818:=nilspace;BOUND STRUCT(TEXT
+s819,s820,s821)VARs822;BOUND TEXT VARs823;TASK VARs824,s825;FILE VARs826;INT VAR
+s827,s828,s829,s830;TEXT VARs831:=s832,s833,s834,s835:=s832,s836,s837,s838;TEXT
+ VARs839:=s840+s841+s842;BOOL VARs843,s844;PROCmpgmanager(PROC(DATASPACE VAR,INT
+ CONST,INT CONST,TASK CONST)s845):IFonlineTHEN TEXT VARs846;put(s847);
+getsecretline(s846);IFs846<>s832THENtaskpassword(s846)FI;put(s848);getsecretline
+(s846);IFs846<>s832THENbeginpassword(s846)FI FI;s844:=FALSE;globalmanager(PROC(
+DATASPACE VAR,INT CONST,INT CONST,TASK CONST)s845)ENDPROCmpgmanager;PROC
+globalmanager:mpgmanager(PROC(DATASPACE VAR,INT CONST,INT CONST,TASK CONST)
+stdmanager)ENDPROCglobalmanager;PROCglobalmanager(PROC(DATASPACE VAR,INT CONST,
+INT CONST,TASK CONST)s845):s843:=TRUE;s849(PROC(DATASPACE VAR,INT CONST,INT
+ CONST,TASK CONST)s845)ENDPROCglobalmanager;PROCs849(PROC(DATASPACE VAR,INT
+ CONST,INT CONST,TASK CONST)s845):s919;setautonom;disablestop;commanddialogue(
+FALSE);s825:=niltask;s851;REPwait(s818,s828,s824);IFs828<>s804THENs855;s845(s818
+,s828,s830,s824)ELIFs824=s825THENs857;s845(s818,s828,s830,s824)ELSEs858FI;s850;
+s853UNTIL(NOTs843)AND(NOTs844)PER;commanddialogue(TRUE);resetautonom.s850:IF
+iserrorTHENforget(s818);s818:=nilspace;s823:=s818;CONCR(s823):=errormessage;
+clearerror;send(s824,s801,s818)FI.s851:INT VARs852:=heapsize.s853:IFheapsize>
+s852+s854THENcollectheapgarbage;s852:=heapsizeFI.s855:s830:=s856;s829:=s828;s825
+:=s824.s857:s830INCRs856;s828:=s829.s858:forget(s818);s818:=nilspace;send(s824,
+s800,s818)ENDPROCs849;PROCfreeglobalmanager:mpgmanager(PROC(DATASPACE VAR,INT
+ CONST,INT CONST,TASK CONST)freemanager)ENDPROCfreeglobalmanager;PROCstdmanager(
+DATASPACE VARs818,INT CONSTs828,s859,TASK CONSTs824):IF(s828=s806ANDs862)CORs863
+THENfreemanager(s818,s828,s859,s824)ELSEerrorstop(s860+name(myself)+s861)FI.s862
+:(s864ORs865)ANDs843.s863:s864ORs865.s864:s824<supervisorORs824=supervisor.s865:
+s824<myselfENDPROCstdmanager;PROCfreemanager(DATASPACE VARs818,INT CONSTs828,
+s859,TASK CONSTs824):enablestop;IFs828>s815ANDs824=supervisorTHENs893ELIFs828=
+s806ANDs843THENs869ELSEs866FI.s866:s868;SELECTs828OF CASEs808:s879CASEs809:s883
+CASEs810:s889CASEs811:s880CASEs812:s890CASEs813:s891CASEs814:s907OTHERWISE
+errorstop(s867+name(myself)+s861)ENDSELECT.s868:IFs828>=s808ANDs828<=s811ANDs859
+=s856THENs822:=s818;s834:=s822.s819FI.s869:BOUND STRUCT(TEXTs870,s871,TASKs872,
+PROCAs873)VARs874:=s818;IFs835=s874.s871ANDs835<>s875THENs877ELIFs874.s871=s832
+THENs878ELSEerrorstop(s876)FI.s877:begin(s818,PROCs912,s827);send(s824,s827,s818
+).s878:send(s824,s807,s818).s879:IFreadpermission(s834,s822.s821)CORs824<
+supervisorTHENforget(s818);s818:=old(s834);send(s824,s799,s818)ELSEerrorstop(
+s876)FI.s880:s822:=s818;s834:=s822.s819;IF NOTexists(s834)THENmanagermessage(
+s861+s834+s881,s824)ELIFs830=s856THENmanagerquestion(s861+s834+s882,s824)ELIF
+writepermission(s834,s822.s820)CORs824<supervisorTHENforget(s834,quiet);send(
+s824,s799,s818)ELSEerrorstop(s876)FI.s883:IFs830=s856THENs884ELSEs886FI.s884:IF
+writepermission(s834,s822.s820)CORs824<supervisorTHENs838:=s834;s836:=s822.s820;
+s837:=s822.s821;IFexists(s834)THENmanagerquestion(s861+s834+s885,s824)ELSEsend(
+s824,s804,s818)FI;ELSEerrorstop(s876)FI.s886:forget(s838,quiet);copy(s818,s838);
+enterpassword(s838,s836,s837);forget(s818);s818:=nilspace;send(s824,s799,s818);
+s887.s887:replace(s836,s856,LENGTHs836*s888);replace(s837,s856,LENGTHs837*s888).
+s889:IFexists(s834)THENsend(s824,s799,s818)ELSEsend(s824,s805,s818)FI.s890:
+forget(s818);s818:=nilspace;s826:=sequentialfile(output,s818);list(s826);send(
+s824,s799,s818).s891:BOUND THESAURUS VARs892:=s818;s892:=all;send(s824,s799,s818
+).s893:TEXT VARs894,s895;INT VARs896,s897;TEXT CONSTs898:=s899;disablestop;call(
+supervisor,s828,s818,s827);forget(s818);IFs827=s799THEN IFs844THEN
+endglobalmanager(TRUE);LEAVEs893FI;s905;REPcommanddialogue(TRUE);getcommand(s900
++name(myself)+s901);analyzecommand(s898,s902,s896,s897,s894,s895);SELECTs896OF
+ CASEs856:s919CASEs854,s903:s843:=FALSE;s844:=FALSE;LEAVEs893CASEs904:s839:=s894
+OTHERWISEdocommandENDSELECT UNTIL NOTonlinePER;commanddialogue(FALSE);s919;
+setautonom;s906FI;enablestop.s905:IFs831<>s832THENout(s816);out(s831);out(s817);
+s831:=s832FI.s906:IFiserrorTHENs831:=errormessage;clearerrorFI.s907:FILE VARs908
+:=sequentialfile(input,s818);WHILE NOTeof(s908)REPgetline(s908,s833);IFexists(
+s833)THENforget(s833,quiet)FI PER;send(s824,s799,s818).ENDPROCfreemanager;PROC
+managerquestion(TEXT CONSTs909):forget(s818);s818:=nilspace;s823:=s818;s823:=
+s909;send(s824,s803,s818)ENDPROCmanagerquestion;PROCmanagerquestion(TEXT CONST
+s909,TASK CONSTs910):forget(s818);s818:=nilspace;s823:=s818;s823:=s909;send(s910
+,s803,s818)ENDPROCmanagerquestion;PROCmanagermessage(TEXT CONSTs911):forget(s818
+);s818:=nilspace;s823:=s818;s823:=s911;send(s824,s802,s818)ENDPROCmanagermessage
+;PROCmanagermessage(TEXT CONSTs911,TASK CONSTs910):forget(s818);s818:=nilspace;
+s823:=s818;s823:=s911;send(s910,s802,s818)ENDPROCmanagermessage;PROCs912:do(s839
+)ENDPROCs912;PROCbegin(TEXT CONSTs913):TASK VARs914;begin(s913,PROCmonitor,s914)
+ENDPROCbegin;PROCbeginpassword(TEXT CONSTs915):s917;s835:=s915;display(s916);
+covertracks.s917:replace(s835,s856,LENGTHs835*s888)ENDPROCbeginpassword;PROC
+endglobalmanager(BOOL CONSTs918):s843:=NOTs918;s844:=NOTs918ENDPROC
+endglobalmanager;PROCs919:eumelmustadvertise;s921(s920)ENDPROCs919;PROCbreak:IF
+s843THENs919;LEAVEbreakFI;s844:=TRUE;s843:=FALSE;s849(PROC(DATASPACE VAR,INT
+ CONST,INT CONST,TASK CONST)stdmanager)ENDPROCbreak;PROCs921(INT CONSTs922):
+DATASPACE VARs923:=nilspace;INT VARs924;call(supervisor,s922,s923,s924);IFs924=
+s801THEN BOUND TEXT VARs925:=s923;forget(s923);errorstop(s925)FI;forget(s923)
+ENDPROCs921;LETs926="edit:1.01end:3.0run:4.01runagain:6.0insert:7.01forget:9.01r
+ename:11.2copy:12.2list:13.0storageinfo:14.0taskinfo:15.0fetch:16.1save:17.01sav
+eall:19.0";INT VARs927,s928,s929;TEXT VARs930,s931;PROCmonitor:disablestop;s929
+:=heapsize;REPcommanddialogue(TRUE);sysin(s832);sysout(s832);s933;getcommand(
+s932);analyzecommand(s926,s904,s927,s928,s930,s931);s937;s853PER.s853:IFheapsize
+>s929+s904THENcollectheapgarbage;s929:=heapsizeFI.s933:INT VARs934,s935;storage(
+s934,s935);IFs935>s934THENout(s936)FI.ENDPROCmonitor;PROCs937:enablestop;SELECT
+s927OF CASEs856:editCASEs854:edit(s930)CASEs903:endCASEs904:runCASEs938:run(s930
+)CASEs920:runagainCASEs939:insertCASEs940:insert(s930)CASEs941:forgetCASEs942:
+forget(s930)CASEs943:rename(s930,s931)CASEs944:copy(s930,s931)CASEs945:listCASE
+s946:storageinfoCASEs947:taskinfoCASEs948:fetch(s930)CASEs949:saveCASEs950:save(
+s930)CASEs951:saveallOTHERWISEdocommandENDSELECT.ENDPROCs937;ENDPACKET
+mpgglobalmanager
diff --git a/app/mpg/1987/src/RUCTEPLT.ELA b/app/mpg/1987/src/RUCTEPLT.ELA new file mode 100644 index 0000000..684c358 --- /dev/null +++ b/app/mpg/1987/src/RUCTEPLT.ELA @@ -0,0 +1,326 @@ +PACKET ructerm plot DEFINES (* M. Staubermann, 23.11.86 *)
+ drawing area,
+ begin plot,
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+ get cursor ,
+
+ testbit, where,
+ pages ,
+ circle, ellipse, fill, box, filled box,
+ get screen ,
+ put screen :
+
+LET max x = 279 , {Abmessungen : 280 x 192}
+ max y = 191 ,
+
+ hor faktor = 11.2 , {***** x pixel / x cm *****}
+ vert faktor = 11.29412 , {***** y pixel / y cm *****}
+
+
+ delete = 0 , {Farbcodes}
+ std = 1 ,
+ black = 5 ,
+ white = 6 ,
+ yellow = 7 ;
+(* lilac = 8 ,
+
+ durchgehend = 1 , {Linientypen}
+ gepunktet = 2 ,
+ kurz gestrichelt = 3 ,
+ lang gestrichelt = 4 ,
+ strichpunkt = 5 ,
+ strichpunktpunkt = 6 ;*)
+
+LET POS = STRUCT (INT x, y) ;
+
+POS VAR pos ;
+INT VAR i ;
+
+clear ;
+
+TEXT PROC text word (INT CONST i) :
+ TEXT VAR t := " " ;
+ replace (t, 1, i) ;
+ t
+ENDPROC text word ;
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 25.0; y cm := 17.0; {***** Horizontale und vertikale *****}
+ {***** Gráe in Zentimetern. *****}
+ x pixel := maxx; y pixel := maxy{***** Koordinaten des rechten *****}
+ {***** oberen Punktes. *****}
+END PROC drawing area;
+
+PROC begin plot :
+ out (""27"$")
+ENDPROC begin plot ;
+
+PROC end plot :
+ out (""27"%")
+ENDPROC end plot ;
+
+PROC where (INT VAR x, y) :
+ REP UNTIL incharety = "" PER ;
+ out (""27";") ;
+ x := (incharety (1000) + incharety (1000)) ISUB 1 ;
+ y := (incharety (1000) + incharety (1000)) ISUB 1
+ENDPROC where ;
+
+BOOL PROC testbit :
+ TEXT VAR t ;
+ REP UNTIL incharety = "" PER ;
+ out (""27"-") ;
+ inchar (t) ;
+ bit (code (t), 0)
+ENDPROC testbit ;
+
+PROC clear :
+ pos := POS:(0, 0) ;
+ out (""27"O0"27"y") ; (* Clear und Cursor (0,0) *)
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ INT CONST farbe := abs (foreground) ;
+ set linetype ;
+ set colour ;
+ set thickness .
+
+set colour :
+ IF farbe = std OR farbe = yellow OR farbe = white
+ THEN out (""27"O21")
+ ELSE out (""27"O20")
+ FI ;
+ IF farbe = delete OR farbe = black THEN out (""27"O41") (* AND *)
+ ELIF foreground < 0 AND thickness >= 0 THEN out (""27"O42") (* XOR *)
+ ELIF foreground < 0{AND thickness < 0} THEN out (""27"O43") (* COPY *)
+ ELSE out (""27"O40") (* SET *)
+ FI .
+
+set thickness :
+ IF thickness > 0 AND thickness < 16
+ THEN out (""27"O1" + code (thickness + 32))
+ FI .
+
+set linetype:
+ IF linetype < 7 AND linetype > 0
+ THEN out (""27"O3" + code (line type + 32))
+ ELSE out (""27"O6" + text word (line type) + ""27"O37") ;
+ FI .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ TEXT VAR cmd := ""27"v" ;
+ cmd CAT text (x) ;
+ cmd CAT "," ;
+ cmd CAT text (y) ;
+ cmd CAT ";" ;
+ out (cmd) ;
+ pos := POS:(x,y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ TEXT VAR cmd := ""27"w" ;
+ cmd CAT text (x) ;
+ cmd CAT "," ;
+ cmd CAT text (y) ;
+ cmd CAT ";" ;
+ out (cmd) ;
+ pos := POS : (x, y)
+
+END PROC draw;
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+ TEXT VAR cmd := ""27"&"27"N" ;
+ cmd CAT code (72 + int (angle / 5.0) MOD 72) ;
+ cmd CAT code (int (hor faktor * width + 0.5)) ;
+ cmd CAT code (int (vert faktor * height + 0.5)) ;
+ out (cmd) ;
+ out (record) ;
+ out (""27"N"0""0""0"") ;
+ move (pos.x, pos.y) .
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+ get cursor (t, x, y, -1, -1, -1, -1)
+END PROC get cursor;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1) :
+ get cursor (t, x, y, x0, y0, x1, y1, FALSE)
+ENDPROC get cursor ;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y, INT CONST x0, y0, x1, y1,
+ BOOL CONST only one key):
+ BOOL VAR hop key := FALSE ;
+ t := "" ;
+ check;
+ init cursor;
+ REP set cursor;
+ get step;
+ set cursor;
+ move cursor
+ UNTIL only one key PER .
+
+init cursor:
+ POS CONST old pos :: pos ;
+ REP UNTIL incharety = "" PER ;
+ out (""27"5") ;
+ TEXT VAR old params ;
+ inchar (old params) ;
+ out (""27"O5a") ; (* Strichdicke 1, XOR, Gelb *)
+ INT VAR delta := 1 ;
+ x := pos.x ;
+ y := pos.y .
+
+set cursor:
+ IF x0 >= 0 AND y0 >= 0
+ THEN move (x0, y0) ;
+ draw (x, y)
+ FI;
+ IF x1 >= 0 AND y1 >= 0
+ THEN move (x1, y1) ;
+ draw (x, y)
+ FI;
+ out (""24"") . (* Fadenkreuz an/aus *)
+
+get step:
+ hop key := t = ""1"" ;
+ t := incharety (1);
+ IF t <> ""
+ THEN delta INCR 1
+ ELSE delta := 1 ;
+ inchar (t)
+ FI .
+
+move cursor:
+ IF hop key
+ THEN hop mode
+ ELSE single key
+ FI ;
+ check .
+
+single key :
+ SELECT code (t) OF
+ CASE 1 :
+ CASE 2, 54 : x INCR delta (* right, '6' *)
+ CASE 3, 56 : y INCR delta (* up, '8' *)
+ CASE 8, 52 : x DECR delta (* left, '4' *)
+ CASE 10, 50 : y DECR delta(* down, '2' *)
+ CASE 55 : x DECR delta ; y INCR delta (* '7' *)
+ CASE 57 : x INCR delta ; y INCR delta (* '9' *)
+ CASE 49 : x DECR delta ; y DECR delta (* '1' *)
+ CASE 51 : x INCR delta ; y DECR delta (* '3' *)
+ OTHERWISE leave get cursor
+ ENDSELECT .
+
+hop mode :
+ SELECT code (t) OF
+ CASE 1 : t := "" ; x := 0 ; y := max y ;
+ CASE 2, 54 : x := max x
+ CASE 3, 56 : y := max y
+ CASE 8, 52 : x := 0
+ CASE 10, 50 : y := 0
+ CASE 55 : x := 0 ; y := max y
+ CASE 57 : x := max x ; y := max y
+ CASE 49 : x := 0 ; y := 0
+ CASE 51 : x := max x ; y := 0
+ OTHERWISE t := ""1"" + t ; leave get cursor
+ ENDSELECT .
+
+leave get cursor:
+ out (""27"O5" + old params) ;
+ move (old pos.x, old pos.y);
+ LEAVE get cursor .
+
+check :
+ IF x < 0
+ THEN x := 0 ; out (""7"")
+ ELIF x > max x
+ THEN x := max x ; out (""7"") FI ;
+
+ IF y < 0
+ THEN y := 0 ; out (""7"")
+ ELIF y > max y
+ THEN y := max y ; out (""7"") FI .
+
+END PROC get cursor;
+
+PROC get screen (TEXT CONST name):
+ IF exists (name)
+ THEN get screen (old (name))
+ ELSE get screen (new (name))
+ FI ;
+END PROC get screen;
+
+PROC get screen (DATASPACE CONST to ds) :
+ BOUND ROW 16 ROW 256 INT VAR screen := to ds ;
+ INT VAR i, j ;
+ REP UNTIL incharety = "" PER ;
+ FOR i FROM 0 UPTO 16 REP
+ out (""27"\"0""2""0"" + code (i * 2)) ;
+ FOR j FROM 1 UPTO 256 REP
+ screen (i)(j) := (incharety (1000) + incharety (1000)) ISUB 1
+ PER ;
+ PER
+END PROC get screen;
+
+PROC put screen (TEXT CONST name):
+ IF exists (name)
+ THEN put screen (old (name))
+ ELSE errorstop ("Der Datenraum """ + name + """ existiert nicht") FI
+END PROC put screen;
+
+PROC put screen (DATASPACE CONST from ds) :
+ BOUND ROW 4096 INT VAR screen :: from ds ;
+ out (""27"/"0""32""0""0"") ;
+ FOR i FROM 1 UPTO 4096 REP
+ out (textword (screen (i)))
+ PER
+END PROC put screen;
+
+PROC pages (INT CONST bits) :
+ out (""27"O7" + code (bits + 32))
+ENDPROC pages ;
+
+INT PROC pages :
+ TEXT VAR t ;
+ REP UNTIL incharety = "" PER ;
+ out (""27"4") ;
+ inchar (t) ;
+ code (t) AND 7
+ENDPROC pages ;
+
+PROC circle (INT CONST radius) :
+ IF radius > 0
+ THEN out (""27"K" + text (radius) + ",0;") ;
+ FI
+ENDPROC circle ;
+
+PROC ellipse (INT CONST x rad, y rad, REAL CONST from, to) :
+ out (""27"s" + text (x rad) + "," + text (yrad) + "," +
+ text (72 + int (from / 5.0) MOD 72) + "," +
+ text (72 + int (to / 5.0) MOD 72) + ";")
+ENDPROC ellipse ;
+
+PROC box (INT CONST width, height) :
+ out (""27"J" + text (width) + "," + text (height) + ";")
+ENDPROC box ;
+
+PROC filled box (INT CONST width, height) : (* Width max. 255 *)
+ out (""27"N" + code (width) + code (height)) ; (* Groáes inverses Blank *)
+ put (""0""27"&"27"O41"27"G0 "27"N"0""0""0"") (* ausgeben *)
+ENDPROC filled box ;
+
+PROC fill (INT CONST pattern) :
+ out (""27"|" + code (pattern + 32))
+ENDPROC fill ;
+
+END PACKET ructerm plot ;
diff --git a/app/mpg/1987/src/STDPLOT.ELA b/app/mpg/1987/src/STDPLOT.ELA new file mode 100644 index 0000000..542b032 --- /dev/null +++ b/app/mpg/1987/src/STDPLOT.ELA @@ -0,0 +1,234 @@ +PACKET std plot DEFINES drawing area,
+ begin plot,
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+ get cursor:
+
+LET delete = 0, {Farbcodes}
+ std = 1,
+ black = 5,
+ white = 6,
+
+ durchgehend = 1, {Linientypen}
+ gepunktet = 2,
+ kurz gestrichelt = 3,
+ lang gestrichelt = 4,
+ strichpunkt = 5,
+
+ empty = 0, {Punktsymbole}
+ high = 1,
+ low = 2,
+ both = 3;
+
+LET POS = STRUCT (INT x, y);
+
+ROW 79 ROW 24 INT VAR screen;
+BOOL VAR colour :: TRUE, action :: TRUE;
+POS VAR pos :: POS : (0, 0);
+
+clear;
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 25.0; y cm := 17.0; {***** Horizontale und vertikale *****}
+ {***** Gráe in Zentimetern. *****}
+ x pixel := 79; y pixel := 48 {***** Koordinaten des rechten *****}
+ {***** oberen Punktes. *****}
+END PROC drawing area;
+
+PROC begin plot :
+ENDPROC begin plot ;
+
+PROC end plot :
+ENDPROC end plot ;
+
+PROC clear :
+ INT VAR i, j;
+ colour := TRUE;
+ action := TRUE;
+ pos := POS : (0, 0);
+
+ FOR i FROM 1 UPTO 24
+ REP screen [1] [i] := 0 PER;
+ FOR i FROM 2 UPTO 79
+ REP screen [i] := screen [1] PER;
+ page;
+ out (""6""23""0"") .
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ colour := foreground > 0;
+ action := linetype <> 0 .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ out (""6""+ code (23-y DIV 2) + code (x));
+ pos := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ IF action
+ THEN vector (x-pos.x, y-pos.y) FI;
+ pos := POS : (x, y) .
+
+END PROC draw;
+
+PROC vector (INT CONST dx , dy) :
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (pos.y, pos.x, dy, dx, 1, 1)
+ ELIF dy > 0 THEN vector (pos.x, pos.y, dx, dy, 1, 1)
+
+ ELIF dy > -dx THEN vector (pos.x, pos.y, dx, -dy, 1,-1)
+ ELSE vector (pos.y, pos.x, -dy, dx,-1, 1) FI
+
+ ELSE IF dy > -dx THEN vector (pos.y, pos.x, dy, -dx, 1,-1)
+ ELIF dy > 0 THEN vector (pos.x, pos.y, -dx, dy,-1, 1)
+
+ ELIF dy > dx THEN vector (pos.x, pos.y, -dx, -dy,-1,-1)
+ ELSE vector (pos.y, pos.x, -dy, -dx,-1,-1) FI
+ FI .
+
+ENDPROC vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
+ INT VAR i;
+ prepare first step ;
+ point;
+ FOR i FROM 1 UPTO dx
+ REP do one step PER .
+
+prepare first step :
+ INT VAR up right error := dy - dx,
+ right error := dy,
+ old error := 0 .
+
+do one step:
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ point ;
+ old error INCR right error .
+
+point :
+ IF (pos.y AND 1) = 0
+ THEN lower point
+ ELSE upper point FI .
+
+lower point :
+ out (""6""+ code (23-pos.y DIV 2) + code (pos.x));
+ IF colour
+ THEN set lower point
+ ELSE reset lower point FI .
+
+set lower point:
+ SELECT screen [pos.x+1] [pos.y DIV 2+1] OF
+ CASE empty : out (","8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := low
+ CASE high : out ("|"8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := both
+ ENDSELECT .
+
+reset lower point:
+ SELECT screen [pos.x+1] [pos.y DIV 2+1] OF
+ CASE low : out (" "8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := empty
+ CASE both : out ("'"8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := high
+ ENDSELECT .
+
+upper point :
+ out (""6""+ code (23-pos.y DIV 2) + code (pos.x));
+ IF colour
+ THEN set upper point
+ ELSE reset upper point FI .
+
+set upper point:
+ SELECT screen [pos.x+1] [pos.y DIV 2+1] OF
+ CASE empty : out ("'"8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := high
+ CASE low : out ("|"8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := both
+ ENDSELECT .
+
+reset upper point:
+ SELECT screen [pos.x+1] [pos.y DIV 2+1] OF
+ CASE high : out (" "8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := empty
+ CASE both : out (","8"");
+ screen [pos.x+1] [pos.y DIV 2+1] := low
+ ENDSELECT .
+
+END PROC vector;
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+ out (subtext (record, 1, 79-pos.x));
+ out (""6""+ code (23-pos.y DIV 2) + code (pos.x));
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+ x := pos.x;
+ y := pos.y;
+ REP out (""6""+ code (23-y DIV 2) + code (x));
+ inchar (t);
+ SELECT code (t) OF
+ CASE 2 : x INCR 1
+ CASE 3 : y INCR 1
+ CASE 8 : x DECR 1
+ CASE 10: y DECR 1
+ CASE 1 : out (""0""1"" + text (x, 3) + "," + text (y, 3) + " "13""16"")
+ OTHERWISE leave get cursor ENDSELECT;
+ check
+ PER .
+
+leave get cursor:
+ out (""6""+ code (23-pos.y DIV 2) + code (pos.x));
+ LEAVE get cursor .
+
+check :
+ IF x < 0
+ THEN x := 0;
+ out (""7"")
+ ELIF x > 47
+ THEN x := 47;
+ out (""7"")
+ FI;
+ IF y < 0
+ THEN y := 0;
+ out (""7"")
+ ELIF y > 78
+ THEN y := 78;
+ out (""7"")
+ FI .
+
+END PROC get cursor;
+
+PROC test (INT CONST x, y, TEXT CONST t):
+ out (""27";(" + text (x) + "," + text (y) + ") " + t + ""29"");
+ IF incharety (10000) = ""27""
+ THEN stop FI
+END PROC test;
+
+
+END PACKET std plot;
+
+
diff --git a/app/mpg/1987/src/TELEVPLT.ELA b/app/mpg/1987/src/TELEVPLT.ELA new file mode 100644 index 0000000..155eb02 --- /dev/null +++ b/app/mpg/1987/src/TELEVPLT.ELA @@ -0,0 +1,176 @@ +PACKET televideo plot DEFINES drawing area, { Autor: H. Indenbirken }
+ begin plot, { Stand: 31.01.85 }
+ end plot,
+ clear,
+ pen,
+ move,
+ draw,
+ get cursor,
+ cursor:
+
+
+LET delete = 0, {Farbcodes}
+ std = 1,
+ black = 5,
+ white = 6,
+
+ nothing = 0, {Linientypen}
+ durchgehend = 1,
+ gepunktet = 2,
+ kurz gestrichelt = 3,
+ lang gestrichelt = 4,
+ strichpunkt = 5,
+ mittel gestrichelt = 6,
+ punkt punkt strich = 7;
+
+INT VAR act thick :: 0;
+LET POS = STRUCT (INT x, y);
+
+POS VAR pos :: POS : (0, 0);
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 23.0; y cm := 13.7;
+ x pixel := 639; y pixel := 239
+END PROC drawing area;
+
+PROC begin plot :
+ page;
+ out (""27".0")
+ENDPROC begin plot ;
+
+PROC end plot :
+ out (""27".1")
+ENDPROC end plot ;
+
+PROC clear :
+ act thick := 0;
+ pos := POS : (0, 0);
+ out (""27"mCGD")
+END PROC clear;
+
+PROC pen (INT CONST background, foreground, thickness, linetype):
+ out (""27"m");
+ set background;
+ set foreground;
+ set thickness;
+ set linetype;
+ out ("D") .
+
+set background:
+ IF background = white
+ THEN out (""27"n1")
+ ELSE out (""27"n0") FI .
+
+set foreground:
+ IF foreground = delete
+ THEN out ("U0W1")
+ ELIF foreground < 0
+ THEN out ("U1W4")
+ ELSE out ("U1W1") FI .
+
+set thickness:
+ act thick := thickness .
+
+set linetype:
+ SELECT linetype OF
+ CASE durchgehend : out ("T1")
+ CASE gepunktet : out ("T3")
+ CASE kurz gestrichelt : out ("T6")
+ CASE lang gestrichelt : out ("T5")
+ CASE strichpunkt : out ("T4")
+ CASE mittel gestrichelt : out ("T2")
+ CASE punkt punkt strich : out ("T7")
+ END SELECT .
+
+END PROC pen;
+
+PROC move (INT CONST x, y) :
+ out (""27"mM" + text (x, y) + ";D");
+ pos := POS : (x, y)
+END PROC move;
+
+PROC draw (INT CONST x, y) :
+ IF act thick <> 0
+ THEN IF horizontal line
+ THEN thick y
+ ELSE thick x FI;
+ x MOVE y
+ ELSE out (""27"mL" + text (x, y) + ";D") FI;
+ pos := POS : (x, y) .
+
+horizontal line:
+ abs (pos.x-x) > abs (pos.y-y) .
+
+thick y:
+ INT VAR dy, old x :: pos.x-x ausgleich, new x :: x+x ausgleich;
+ FOR dy FROM 1 UPTO act thick
+ REP old x MOVE pos.y+dy;
+ new x DRAW y+dy;
+ old x MOVE pos.y-dy;
+ new x DRAW y-dy;
+ PER .
+
+x ausgleich:
+ IF pos.x <= x
+ THEN act thick
+ ELSE -act thick FI .
+
+thick x:
+ INT VAR dx, old y :: pos.y-y ausgleich, new y :: y+y ausgleich;
+ FOR dx FROM 1 UPTO act thick
+ REP pos.x+dx MOVE old y;
+ x+dx DRAW new y;
+ pos.x-dx MOVE old y;
+ x-dx DRAW new y;
+ PER .
+
+y ausgleich:
+ IF pos.y <= y
+ THEN act thick
+ ELSE -act thick FI .
+
+END PROC draw;
+
+PROC draw (TEXT CONST record, REAL CONST angle, height, width):
+ out (""27"m""" + record + """D")
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+PROC get cursor (TEXT VAR t, INT VAR x, y) :
+END PROC get cursor;
+
+OP MOVE (INT CONST x, y):
+ out (""27"mM" + text (x, y) + ";D")
+END OP MOVE;
+
+OP DRAW (INT CONST x, y):
+ out (""27"mL" + text (x, y) + ";D")
+END OP DRAW;
+
+PROC cursor (INT CONST no,x,y):
+ out (""27"m|" + text (no) + "~0H" + text (x, y) + ";D")
+END PROC cursor;
+
+TEXT PROC text (INT CONST x,y):
+ x text + "," + y text .
+
+x text:
+ IF x < 0
+ THEN "0"
+ ELIF x > 639
+ THEN "639"
+ ELSE text (x) FI .
+
+y text:
+ IF y < 0
+ THEN "0"
+ ELIF y > 639
+ THEN "639"
+ ELSE text (y) FI .
+
+END PROC text;
+
+END PACKET televideo plot
diff --git a/app/mpg/1987/src/VIDEOPLO.ELA b/app/mpg/1987/src/VIDEOPLO.ELA new file mode 100644 index 0000000..9721cad --- /dev/null +++ b/app/mpg/1987/src/VIDEOPLO.ELA @@ -0,0 +1,382 @@ +# Stand : 26.Juni 1985 #
+PACKET videostar plot DEFINES drawing area,
+ begin plot,
+ end plot,
+ clear,
+
+ background,
+ foreground,
+ thickness,
+ linetype,
+
+ move,
+ draw,
+ marker,
+
+ range,
+ clipping:
+
+LET begin vector = ""16"";
+LET max x = 679,
+ max y = 479; (* Direkt-Adressierung *)
+LET POS = STRUCT (INT x, y);
+POS VAR pos :: POS : (0, 0);
+
+INT VAR akt pen :: 1, akt pen line type :: 1;
+BOOL VAR check :: TRUE;
+INT VAR thick :: 0, i, x min :: 0, x max :: 679, y min :: 0, y max :: 479;
+TEXT VAR old pos :: "";
+
+PROC drawing area (REAL VAR x cm, y cm, INT VAR x pixel, y pixel) :
+ x cm := 27.0 ; y cm := 20.00;
+ x pixel := 679; y pixel := 479
+END PROC drawing area;
+
+PROC range (INT CONST h min, h max, v min, v max):
+ x min := h min; x max := h max;
+ y min := v min; y max := v max
+END PROC range;
+
+PROC clipping (BOOL CONST flag):
+ check := flag
+END PROC clipping;
+
+BOOL PROC clipping:
+ check
+END PROC clipping;
+
+PROC begin plot :
+ENDPROC begin plot ;
+
+PROC end plot :
+ out (""27"0@")
+ENDPROC end plot ;
+
+PROC clear :
+write (""29""27""140""27"/0d"24"")
+END PROC clear;
+
+PROC background (INT CONST desired, INT VAR realized):
+ realized := 0 (*Nur schwarzer Hintergrund mglich *)
+END PROC background;
+
+PROC foreground (INT CONST desired, INT VAR realized):
+ akt pen := desired;
+ realized := sign (desired) . (*Nur weiáer Sift mglich, aber *)
+ (*lschend, ndernd oder berschreibend *)
+END PROC foreground;
+
+PROC thickness (INT CONST desired, INT VAR realized):
+ thick := desired DIV 10;
+ realized := thick*2+1 (*Breite des Stiftes in Pixel *)
+END PROC thickness;
+
+PROC linetype (INT CONST desired, INT VAR realized):
+ IF desired <> akt pen linetype
+ THEN write (""29"") ; # Graphicmode on #
+ akt pen line type := desired;
+ write (type cmd);
+ write (""27"x"24"")
+ FI;
+ IF desired >= 0 AND desired <= 5
+ THEN realized := desired
+ ELSE realized := 0 FI .
+
+type cmd:
+ SELECT desired OF
+ CASE 1 : ""27"/a" # durchgngige Linie #
+ CASE 2 : ""27"/1;1a" # gepunktet #
+ CASE 3 : ""27"/3;3a" # kurz gestrichelt #
+ CASE 4 : ""27"/6;6a" # lang gestrichelt #
+ CASE 5 : ""27"/6;3;1;3a" # Strichpunkt #
+ OTHERWISE ""27"/a" END SELECT
+END PROC linetype;
+
+
+PROC move (INT CONST x, y) :
+ x MOVE y;
+ pos := POS:(x, y) .
+END PROC move;
+
+PROC draw (INT CONST x, y):
+ IF std thickness
+ THEN draw (pos.x, pos.y, x, y)
+ ELIF is point
+ THEN point (x, y, thick);
+ x MOVE y;
+ ELIF is horizontal line
+ THEN horizontal line (pos.x, pos.y, x, y, thick);
+ x MOVE y;
+ ELSE vertical line (pos.x, pos.y, x, y, thick);
+ x MOVE y
+ FI;
+ pos := POS:(x, y) .
+
+std thickness:
+ thick = 0 .
+
+is point:
+ pos.x = x AND pos.y = y .
+
+is horizontal line:
+ abs (pos.x-x) >= abs (pos.y-y) .
+
+END PROC draw;
+
+PROC point (INT CONST x, y, thick):
+ INT VAR i;
+ FOR i FROM -thick UPTO thick
+ REP line (x-thick, y+i, x+thick, y+i) PER
+
+END PROC point;
+
+PROC horizontal line (INT CONST from x, from y, to x, to y, thick):
+ IF from x > to x
+ THEN horizontal line (to x, to y, from x, from y, thick)
+ ELSE draw line FI .
+
+draw line:
+ INT VAR i;
+ calculate increase;
+ calculate limit points;
+ FOR i FROM -thick UPTO thick
+ REP calculate delta x;
+ line (x start+delta x, y start+i, x end+delta x, y end+i)
+ PER .
+
+calculate increase:
+ REAL VAR increase :: -dy / dx .
+
+calculate limit points:
+ INT CONST x start :: from x - thick,
+ x end :: to x + thick,
+ y start :: from y + int (increase * real (thick)),
+ y end :: to y - int (increase * real (thick)) .
+
+calculate delta x:
+ INT CONST delta x :: int (increase*real (i)) .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC horizontal line;
+
+PROC vertical line (INT CONST from x, from y, to x, to y, thick):
+ IF from y > to y
+ THEN vertical line (to x, to y, from x, from y, thick)
+ ELSE draw line FI .
+
+draw line:
+ INT VAR i;
+ calculate increase;
+ calculate limit points;
+ FOR i FROM -thick UPTO thick
+ REP calculate delta y;
+ line (x start+i, y start+delta y, x end+i, y end+delta y)
+ PER .
+
+calculate increase:
+ REAL VAR increase :: -dx / dy .
+
+calculate limit points:
+ INT CONST x start :: from x + int (increase * real (thick)),
+ x end :: to x - int (increase * real (thick)),
+ y start :: from y - thick,
+ y end :: to y + thick .
+
+calculate delta y:
+ INT CONST delta y :: int (increase*real (i)) .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC vertical line;
+
+PROC marker (INT CONST x, y, no, size):
+ IF no = 0
+ THEN draw cursor FI;
+ pos.x MOVE pos.y .
+
+draw cursor:
+ write(""29""27"/f"27""26"") .
+
+END PROC marker;
+
+PROC line (INT CONST from x, from y, to x, to y):
+ from x MOVE from y;
+ draw (from x, from y, to x, to y)
+END PROC line;
+
+PROC draw (INT CONST from x, from y, to x, to y):
+ IF check
+ THEN draw with clipping
+ ELSE to x DRAW to y FI .
+
+draw with clipping:
+ INT VAR x, y;
+ calculate parts of line;
+ IF both points inside
+ THEN to x DRAW to y
+ ELIF both points outside
+ THEN
+ ELIF first point outside
+ THEN intersection (to x, to y, to part, from x, from y, from part, x, y);
+ x MOVE y;
+ to x DRAW to y
+ ELIF second point outside
+ THEN intersection (from x, from y, from part, to x, to y, to part, x, y);
+ x DRAW y
+ ELSE check intersection FI .
+
+calculate parts of line:
+ INT CONST from part :: part (from x, from y),
+ to part :: part (to x, to y) .
+
+both points inside:
+ from part = 0 AND to part = 0 .
+
+both points outside:
+ (from part AND to part) <> 0 .
+
+first point outside:
+ from part <> 0 AND to part = 0 .
+
+second point outside:
+ to part <> 0 AND from part = 0 .
+
+check intersection:
+ intersection (to x, to y, to part, from x, from y, from part, x, y);
+ x MOVE y;
+ draw (x, y, to x, to y) .
+
+END PROC draw;
+
+INT PROC part (INT CONST x, y):
+ INT VAR index :: 0;
+ IF x > x max
+ THEN set bit (index, 0)
+ ELIF x < x min
+ THEN set bit (index, 1) FI;
+
+ IF y > y max
+ THEN set bit (index, 2)
+ ELIF y < y min
+ THEN set bit (index, 3) FI;
+
+ index
+
+END PROC part;
+
+PROC intersection (INT CONST from x, from y, from part, to x, to y, to part,
+ INT VAR x, y):
+ SELECT to part OF
+ CASE 1: right side
+ CASE 2: left side
+ CASE 4: up side
+ CASE 5: upright side
+ CASE 6: upleft side
+ CASE 8: down side
+ CASE 9: downright side
+ CASE 10: downleft side
+ OTHERWISE errorstop ("wrong partno.:" + text (to part)) ENDSELECT .
+
+right side:
+ y := from y + int (real (x max-from x)*(dy/dx));
+ x := x max .
+
+left side:
+ y := from y + int (real (x min-from x)*(dy/dx));
+ x := x min .
+
+up side:
+ x := from x + int (real (y max-from y)*(dx/dy));
+ y := y max .
+
+down side:
+ x := from x + int (real (y min-from y)*(dx/dy));
+ y := y min .
+
+upright side:
+ right side;
+ IF y > y max
+ THEN up side FI .
+
+downright side:
+ right side;
+ IF y < y min
+ THEN down side FI .
+
+upleft side:
+ left side;
+ IF y > y max
+ THEN up side FI .
+
+downleft side:
+ left side;
+ IF y < y min
+ THEN down side FI .
+
+dx: real (to x-from x) .
+dy: real (to y-from y) .
+
+END PROC intersection;
+
+PROC draw (TEXT CONST text, REAL CONST angle, height, thick) :
+INT CONST hoehe :: int(height);
+ IF akt pen linetype <> 0
+ THEN write (""29"");
+ write (old pos);
+ write (""31"");
+ write (size);
+ write (text);
+ write(""24"")
+ FI .
+
+size:
+ SELECT hoehe OF
+ CASE 1 : ""27"4"
+ CASE 2 : ""27"5"
+ CASE 3 : ""27"0"
+ CASE 4 : ""27"1"
+ CASE 5 : ""27"2"
+ CASE 6 : ""27"3"
+ OTHERWISE ""27"0" END SELECT . # Gráe 3 fr undefinierte Werte #
+
+END PROC draw;
+
+PROC draw (TEXT CONST record) :
+ draw (record, 0.0, 0.0, 0.0)
+END PROC draw;
+
+OP MOVE (INT CONST x, y) :
+ write (""29"");
+ old pos := koordinaten (x,y);
+ write (old pos);
+ write (""24"");
+END OP MOVE;
+
+OP DRAW (INT CONST x, y) :
+ IF akt pen line type = 0
+ THEN x MOVE y
+ ELSE write (""29""); (* plot ein *)
+ write (colour cmd);
+ write (old pos);
+ old pos := koordinaten (x,y);
+ write (old pos);
+ write (""24""); (* plot aus *)
+ FI .
+
+colour cmd:
+ IF akt pen = 0 THEN ""27"/1d" # lschend #
+ ELIF akt pen < 0 THEN ""27"/2d" # XOR #
+ ELSE ""27"/0" # normal #
+ FI .
+
+END OP DRAW;
+
+TEXT PROC koordinaten (INT CONST x,y):
+ code(32+((y DIV 32) AND 31)) + code(96+(y MOD 32)) +
+ code(32+((x DIV 32) AND 31)) + code(64+(x MOD 32))
+END PROC koordinaten;
+
+END PACKET videostar plot
diff --git a/app/mpg/1987/src/ZEICH610.DS b/app/mpg/1987/src/ZEICH610.DS Binary files differnew file mode 100644 index 0000000..c06b5eb --- /dev/null +++ b/app/mpg/1987/src/ZEICH610.DS diff --git a/app/mpg/1987/src/ZEICH912.DS b/app/mpg/1987/src/ZEICH912.DS Binary files differnew file mode 100644 index 0000000..fc55473 --- /dev/null +++ b/app/mpg/1987/src/ZEICH912.DS diff --git a/app/mpg/1987/src/ZEICHEN.DS b/app/mpg/1987/src/ZEICHEN.DS Binary files differnew file mode 100644 index 0000000..0c4927d --- /dev/null +++ b/app/mpg/1987/src/ZEICHEN.DS diff --git a/app/mpg/1987/src/matrix printer b/app/mpg/1987/src/matrix printer new file mode 100644 index 0000000..e5821ff --- /dev/null +++ b/app/mpg/1987/src/matrix printer @@ -0,0 +1,129 @@ +(* Version vom 21.10.87 BJ *)
+(* Standardoperationen *)
+(* printer line - Linienalgorithmus *)
+(* printer fill - Fuellalgorithmus *)
+
+PROC printer line (INT CONST x1,y1,x2,y2,
+ PROC (INT CONST, INT CONST) p set pixel):
+ INT VAR x,y,z,
+ a,b,d,
+ dx :: abs(x2-x1),
+ dy :: abs(y2-y1),
+ dp,dq;
+ IF dx <> 0 AND dy <> 0
+ THEN IF dy <= dx
+ THEN draw line 1
+ ELSE draw line 2
+ FI
+ ELSE IF dx = 0 AND dy <> 0
+ THEN draw vertical line
+ ELSE draw horizontal line
+ FI
+ FI.
+
+ draw line 1:
+ x := x1;
+ y := y1;
+ z := x2;
+ a := sign(x2-x1);
+ b := sign(y2-y1);
+ dp := dy * 2;
+ d := dp - dx;
+ dq := dp - 2 * dx;
+ setpoint;
+ WHILE x <> z REP
+ x := x + a;
+ IF d < 0
+ THEN d := d + dp
+ ELSE y := y + b;
+ d := d + dq
+ FI;
+ setpoint
+ PER.
+
+ draw line 2:
+ x := x1;
+ y := y1;
+ z := y2;
+ b := sign(x2-x1);
+ a := sign(y2-y1);
+ dp := dx * 2;
+ d := dp - dy;
+ dq := dp - 2 * dy;
+ setpoint;
+ WHILE y <> z REP
+ y := y + a;
+ IF d < 0
+ THEN d := d + dp
+ ELSE x := x + b;
+ d := d + dq
+ FI;
+ setpoint
+ PER.
+
+ draw vertical line:
+ a := sign(y2-y1);
+ x := x1;
+ y := y1;
+ z := y2;
+ setpoint;
+ WHILE y <> z REP
+ y := y + a;
+ setpoint
+ PER.
+
+ draw horizontal line:
+ a := sign(x2-x1);
+ x := x1;
+ y := y1;
+ z := x2;
+ setpoint;
+ WHILE x <> z REP
+ x := x + a;
+ setpoint
+ PER.
+
+ setpoint:
+ p set pixel (x,y)
+END PROC printer line;
+
+PROC printer fill (INT CONST xl, xr, y, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset):
+ INT VAR xl1 :: xl;
+ WHILE point(xl1,y) REP
+ xl1 INCR 1;
+ IF xl1 >= xr
+ THEN LEAVE printer fill
+ FI
+ PER;
+ INT VAR xrn :: xl1+1,
+ xln :: xl1;
+ WHILE NOT point(xrn,y) REP
+ pset(xrn,y);
+ xrn INCR 1
+ PER;
+ WHILE NOT point(xln,y) REP
+ pset(xln,y);
+ xln DECR 1
+ PER;
+ IF xrn > xr
+ THEN printer fill (xr, xrn-1,y-dir,-dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ ELSE printer fill (xrn, xr, y, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ FI;
+ IF xln < xl
+ THEN printer fill (xln+1,xl, y-dir,-dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ ELSE printer fill (xl,xln, y, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+ FI;
+ printer fill(xln+1, xrn-1, y+dir, dir,
+ BOOL PROC (INT CONST, INT CONST) point,
+ PROC (INT CONST, INT CONST) pset)
+END PROC printer fill;
diff --git a/app/mpg/1987/src/std primitives b/app/mpg/1987/src/std primitives new file mode 100644 index 0000000..dca20bd --- /dev/null +++ b/app/mpg/1987/src/std primitives @@ -0,0 +1,79 @@ +PROC std circle (INT CONST xp,yp,r,from,to):
+ moveto (xp,yp);
+ REAL VAR ang :: real (from MOD 360),
+ rad :: real(r),
+ max :: endwinkel,
+ cx :: real (xp),
+ cy :: real (yp),
+ ax0 :: cx,
+ ay0 :: cy,
+ ax1, ay1;
+
+ BOOL VAR fullcircle :: ang = 0.0 AND max = 360.0;
+ IF fullcircle
+ THEN move to (int (cx + rad * cosd (ang)+0.5),
+ int (cy + rad * -sind (ang)+0.5));
+ ang INCR 1.0
+ FI;
+ WHILE ang <= max REP
+ ax1 := cx + rad * cosd (ang);
+ ay1 := cy + rad * -sind (ang);
+ draw arc;
+ ang INCR 1.0
+ PER;
+ IF NOT fullcircle
+ THEN ax0 := cx;
+ ay0 := cy;
+ draw arc;
+ draw to (xp,yp)
+ ELSE move to (xp,yp)
+ FI.
+
+ draw arc:
+ IF clipped line (ax0,ay0,ax1,ay1)
+ THEN draw to (int (ax1+0.5), int (ay1+0.5))
+ FI;
+ ax0 := ax1;
+ ay0 := ay1.
+
+ endwinkel:
+ IF (to MOD 360) = 0
+ THEN 360.0
+ ELSE real (to MOD 360)
+ FI
+END PROC std circle;
+
+PROC std box (INT CONST x0, y0, x1, y1, pattern):
+ REAL VAR xx0 :: real (x0),
+ yy0 :: real (y0),
+ xx1 :: real (x0),
+ yy1 :: real (y1);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI;
+ xx0 := real (x0);
+ yy0 := real (y1);
+ xx1 := real (x1);
+ yy1 := real (y1);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI;
+ xx0 := real (x1);
+ yy0 := real (y1);
+ xx1 := real (x1);
+ yy1 := real (y0);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI;
+ xx0 := real (x1);
+ yy0 := real (y0);
+ xx1 := real (x0);
+ yy1 := real (y0);
+ IF clipped line (xx0,yy0,xx1,yy1)
+ THEN moveto (int (xx0), int (yy0));
+ drawto (int (xx1), int (yy1))
+ FI
+END PROC std box;
diff --git a/app/mpg/1987/src/terminal plot b/app/mpg/1987/src/terminal plot new file mode 100644 index 0000000..d4eccbd --- /dev/null +++ b/app/mpg/1987/src/terminal plot @@ -0,0 +1,113 @@ +(* Prozeduren zur Ausgabe auf ASCII-Terminals *)
+INT CONST up := 1 ,
+ right := 1 ,
+ down := -1 ,
+ left := -1 ;
+
+INT VAR x pos := 0 ,
+ y pos := 0 ,
+ new x pos ,
+ new y pos ;
+
+BOOL VAR plot := FALSE;
+TEXT CONST empty line :: 79 * " ";
+ROW 24 TEXT VAR display;
+
+
+PROC plot vector (INT CONST dx , dy) :
+
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (y pos, x pos, dy, dx, up, right)
+ ELIF dy > 0 THEN vector (x pos, y pos, dx, dy, right, up)
+
+ ELIF dy > -dx THEN vector (x pos, y pos, dx, -dy, right, down)
+ ELSE vector (y pos, x pos, -dy, dx, down, right)
+ FI
+ ELSE IF dy > -dx THEN vector (y pos, x pos, dy, -dx, up, left)
+ ELIF dy > 0 THEN vector (x pos, y pos, -dx, dy, left, up)
+
+ ELIF dy > dx THEN vector (x pos, y pos, -dx, -dy, left, down)
+ ELSE vector (y pos, x pos, -dy, -dx, down, left)
+ FI
+ FI .
+
+ENDPROC plot vector ;
+
+PROC vector (INT VAR x pos, y pos, INT CONST dx, dy, right, up) :
+
+ prepare first step ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO dx REP
+ do one step
+ PER .
+
+prepare first step :
+ point;
+ INT VAR old error := 0 ,
+ up right error := dy - dx ,
+ right error := dy .
+
+do one step :
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ point ;
+ old error INCR right error .
+
+ENDPROC vector ;
+
+
+PROC point :
+ IF x pos < 1
+ THEN x pos := 1
+ ELIF x pos > 78
+ THEN x pos := 78 FI;
+
+ IF y pos < 1
+ THEN y pos := 1
+ ELIF y pos > 47
+ THEN y pos := 47 FI;
+
+ INT CONST line :: y pos DIV 2;
+ BOOL CONST above :: (y pos MOD 2) = 1;
+ TEXT CONST point :: display [line+1] SUB (x pos+1),
+ new point :: calculated point;
+
+ replace (display [line+1], x pos+1, new point);
+ cursor (x pos, 24-line);
+ out (new point) .
+
+calculated point :
+ IF above
+ THEN IF point = "," OR point = "|"
+ THEN "|"
+ ELSE "'" FI
+ ELSE IF point = "'" OR point = "|"
+ THEN "|"
+ ELSE "," FI
+ FI
+
+END PROC point;
+
+REAL CONST real max int := real (max int);
+INT PROC round (REAL CONST x) :
+ IF x > real max int
+ THEN max int
+ ELIF x < 0.0
+ THEN 0
+ ELSE int (x + 0.5) FI
+
+END PROC round;
diff --git a/app/speedtest/1986/doc/MEM64180.PRT b/app/speedtest/1986/doc/MEM64180.PRT new file mode 100644 index 0000000..36f495e --- /dev/null +++ b/app/speedtest/1986/doc/MEM64180.PRT @@ -0,0 +1,103 @@ +#type("17.klein")#
+ BASIS 108 mit 64180, SHARD 8, 64180/6.144
+ =========================================
+
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16384
+Gesamtlaufzeit (CPU): 98.95774 msec
+
+ Steuerkonstrukte
+
+FOR REP .12208 msec
+WHILE REP .11903 msec
+UNTIL REP .10682 msec
+IF .03968 msec
+SELECT .17701 msec
+PROC .29299 msec
+PROC (INT) .35097 msec
+PROC (INT, INT) .40896 msec
+ ---------------
+ 1.61754 msec
+ Integer Operationen
+
+INT := (Paketdaten) .05188 msec
+INT := (Prozedurdaten) .07630 msec
+INT := (Parameter) .12818 msec
+ROW INT [i] .24416 msec
+INT = .06409 msec
+INT <= .06409 msec
+INT + .07630 msec
+INT * .18312 msec
+DIV .34487 msec
+INCR .05493 msec
+MOD .36623 msec
+abs (INT) .89727 msec
+min (INT , INT) .89117 msec
+ ----------------
+ 3.44259 msec
+ Real Operationen
+
+REAL := .07935 msec
+ROW REAL [i] .29299 msec
+REAL = .18617 msec
+REAL <= .13123 msec
+REAL + .44864 msec
+REAL * 1.36718 msec
+REAL / 2.64892 msec
+INCR 1.08344 msec
+MOD 5.84106 msec
+abs (REAL) .99799 msec
+min (REAL, REAL) .94610 msec
+ -----------------
+ 14.02307 msec
+ Text Operationen
+
+TEXT := (1) .08545 msec
+TEXT := (10) .45169 msec
+TEXT := (30) .55545 msec
+ROW TEXT [i] .30214 msec
+TEXT = (1) .10682 msec
+TEXT = (10) .35097 msec
+TEXT = (30) .58903 msec
+TEXT <= (1) .20753 msec
+TEXT <= (10) .38454 msec
+TEXT <= (30) .61649 msec
+TEXT * (Faktor 1) 1.41305 msec
+CAT (1) .34792 msec
+TEXT + (1) 1.15669 msec
+TEXT + (10) 2.22778 msec
+TEXT + (30) 2.73437 msec
+length (1) .07935 msec
+length (10) .07630 msec
+length (30) .08240 msec
+SUB (1) .17701 msec
+SUB (10) .17701 msec
+SUB (30) .22890 msec
+subtext (TEXT, INT, INT) (1) .22584 msec
+subtext (TEXT, INT, INT) (10) .22584 msec
+subtext (TEXT, INT, INT) (30) .27773 msec
+replace (TEXT, TEXT, INT) (1) .24721 msec
+replace (TEXT, TEXT, INT) (10) .24416 msec
+replace (TEXT, TEXT, INT) (30) .32045 msec
+text (TEXT, INT, INT) (1) 2.45971 msec
+text (TEXT, INT, INT) (10) 2.37426 msec
+text (TEXT, INT, INT) (30) 2.75268 msec
+pos (TEXT, TEXT, INT) (1) .30825 msec
+pos (TEXT, TEXT, INT) (10) .32351 msec
+pos (TEXT, TEXT, INT) (30) .42422 msec
+ ----------------
+ 22.53475 msec
+ Konvertierungs Operationen
+
+int (REAL) 2.21266 msec
+real (INT) 1.15058 msec
+int (TEXT) 10.32104 msec
+text (INT) 1.98376 msec
+text (INT, INT) 6.70776 msec
+text (REAL) 28.53393 msec
+text (REAL, INT, INT) 6.24389 msec
+code (INT) .07630 msec
+code (TEXT) .10987 msec
+ -----------------
+ 57.33979 msec
diff --git a/app/speedtest/1986/doc/MEMATARI.PRT b/app/speedtest/1986/doc/MEMATARI.PRT new file mode 100644 index 0000000..7512919 --- /dev/null +++ b/app/speedtest/1986/doc/MEMATARI.PRT @@ -0,0 +1,101 @@ + ATARI ST 68000-8
+ =====================
+
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+
+ Steuerkonstrukte
+
+FOR REP .64701 msec
+WHILE REP .54630 msec
+UNTIL REP .43338 msec
+IF .31130 msec
+SELECT .93389 msec
+PROC 1.43441 msec
+PROC (INT) 1.67247 msec
+PROC (INT, INT) 1.91967 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .36318 msec
+INT := (Prozedurdaten) .39370 msec
+INT := (Parameter) .58292 msec
+ROW INT [i] 1.05597 msec
+INT = .43643 msec
+INT <= .43643 msec
+INT + .50967 msec
+INT * .69890 msec
+DIV .73857 msec
+INCR .39980 msec
+MOD .75383 msec
+abs (INT) 3.92175 msec
+min (INT , INT) 3.86987 msec
+
+
+ Real Operationen
+
+REAL := .38760 msec
+ROW REAL [i] 1.06513 msec
+REAL = .85149 msec
+REAL <= .71721 msec
+REAL + .94305 msec
+REAL * 2.80168 msec
+REAL / 5.93298 msec
+INCR 3.35409 msec
+MOD 15.60154 msec
+abs (REAL) 4.12928 msec
+min (REAL, REAL) 3.98584 msec
+
+
+ Text Operationen
+
+TEXT := (1) .56461 msec
+TEXT := (10) 1.04376 msec
+TEXT := (30) 2.43850 msec
+ROW TEXT [i] 1.26350 msec
+TEXT = (1) .68974 msec
+TEXT = (10) 1.04376 msec
+TEXT = (30) 2.26759 msec
+TEXT <= (1) 1.08954 msec
+TEXT <= (10) 1.17195 msec
+TEXT <= (30) 2.39578 msec
+TEXT * (Faktor 1) 6.59525 msec
+CAT (1) 1.67552 msec
+TEXT + (1) 5.10590 msec
+TEXT + (10) 7.75194 msec
+TEXT + (30) 10.13245 msec
+length (1) .48221 msec
+length (10) .48221 msec
+length (30) .50357 msec
+SUB (1) .99188 msec
+SUB (10) .98883 msec
+SUB (30) 1.47409 msec
+subtext (TEXT, INT, INT) (1) 1.13532 msec
+subtext (TEXT, INT, INT) (10) 1.13227 msec
+subtext (TEXT, INT, INT) (30) 1.61448 msec
+replace (TEXT, TEXT, INT) (1) 1.15058 msec
+replace (TEXT, TEXT, INT) (10) 1.18721 msec
+replace (TEXT, TEXT, INT) (30) 1.73350 msec
+text (TEXT, INT, INT) (1) 10.85882 msec
+text (TEXT, INT, INT) (10) 10.23012 msec
+text (TEXT, INT, INT) (30) 11.81102 msec
+pos (TEXT, TEXT, INT) (1) 1.51682 msec
+pos (TEXT, TEXT, INT) (10) 1.56565 msec
+pos (TEXT, TEXT, INT) (30) 2.35000 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) 9.87304 msec
+real (INT) 5.28597 msec
+int (TEXT) 50.36318 msec
+text (INT) 5.92077 msec
+text (INT, INT) 26.21010 msec
+text (REAL) 124.03101 msec
+text (REAL, INT, INT) 27.72996 msec
+code (INT) .49747 msec
+code (TEXT) .65922 msec
+
diff --git a/app/speedtest/1986/doc/MEMB108.PRT b/app/speedtest/1986/doc/MEMB108.PRT new file mode 100644 index 0000000..ac9527c --- /dev/null +++ b/app/speedtest/1986/doc/MEMB108.PRT @@ -0,0 +1,99 @@ + Basis108 HD64180-6.144
+ ===========================
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+
+ Steuerkonstrukte
+
+FOR REP .17701 msec
+WHILE REP .18312 msec
+UNTIL REP .14344 msec
+IF .08545 msec
+SELECT .30214 msec
+PROC .48831 msec
+PROC (INT) .57682 msec
+PROC (INT, INT) .66838 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .10377 msec
+INT := (Prozedurdaten) .14344 msec
+INT := (Parameter) .21974 msec
+ROW INT [i] .38760 msec
+INT = .12208 msec
+INT <= .12513 msec
+INT + .14344 msec
+INT * .24721 msec
+DIV .57377 msec
+INCR .10987 msec
+MOD .60734 msec
+abs (INT) 1.57480 msec
+min (INT , INT) 1.41915 msec
+
+
+ Real Operationen
+
+REAL := .13429 msec
+ROW REAL [i] .41506 msec
+REAL = .28993 msec
+REAL <= .20143 msec
+REAL + .70805 msec
+REAL * 2.18519 msec
+REAL / 4.24220 msec
+INCR 1.73350 msec
+MOD 9.34505 msec
+abs (REAL) 1.55344 msec
+min (REAL, REAL) 1.47409 msec
+
+
+ Text Operationen
+
+TEXT := (1) .15565 msec
+TEXT := (10) .39980 msec
+TEXT := (30) .68058 msec
+ROW TEXT [i] .43338 msec
+TEXT = (1) .19227 msec
+TEXT = (10) .40286 msec
+TEXT = (30) .78740 msec
+TEXT <= (1) .35708 msec
+TEXT <= (10) .44864 msec
+TEXT <= (30) .82708 msec
+TEXT * (Faktor 1) 2.29201 msec
+CAT (1) .57987 msec
+TEXT + (1) 1.84948 msec
+TEXT + (10) 2.89324 msec
+TEXT + (30) 3.16792 msec
+length (1) .14649 msec
+length (10) .14344 msec
+length (30) .15260 msec
+SUB (1) .30825 msec
+SUB (10) .30825 msec
+SUB (30) .39370 msec
+subtext (TEXT, INT, INT) (1) .36318 msec
+subtext (TEXT, INT, INT) (10) .36318 msec
+subtext (TEXT, INT, INT) (30) .44253 msec
+replace (TEXT, TEXT, INT) (1) .41201 msec
+replace (TEXT, TEXT, INT) (10) .41506 msec
+replace (TEXT, TEXT, INT) (30) .53409 msec
+text (TEXT, INT, INT) (1) 4.08961 msec
+text (TEXT, INT, INT) (10) 3.72337 msec
+text (TEXT, INT, INT) (30) 4.05298 msec
+pos (TEXT, TEXT, INT) (1) .51578 msec
+pos (TEXT, TEXT, INT) (10) .54019 msec
+pos (TEXT, TEXT, INT) (30) .66227 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) 3.59519 msec
+real (INT) 1.92272 msec
+int (TEXT) 17.15803 msec
+text (INT) 1.99902 msec
+text (INT, INT) 9.44882 msec
+text (REAL) 45.09553 msec
+text (REAL, INT, INT) 10.03479 msec
+code (INT) .14039 msec
+code (TEXT) .19532 msec
diff --git a/app/speedtest/1986/doc/MEMB1082.PRT b/app/speedtest/1986/doc/MEMB1082.PRT new file mode 100644 index 0000000..b52bb8a --- /dev/null +++ b/app/speedtest/1986/doc/MEMB1082.PRT @@ -0,0 +1,112 @@ +#type("17.klein")#
+ Basis108/Urlader #326 HD64180-6.144 10.10.86
+ =====================================
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+Anmerkung: In der Version 1.8.0 (Urlader 175 #326) ist der Basis in fast
+allen Punkten schneller geworden als mit Urlader 173 #073 (bis zu 40%!).
+
+Langsamer sind die Vergleichsoperationen bei Texten auf dem Heap und die
+Integermultiplikation, sowie abhngige davon (ROW-TEXT Subscript mit mehr
+als zwei Elementen), da bei diesem Benchmakr die EUMEL0-INT-Multiplikation
+nicht durch den HD64180-Prozessorbefehl MULT ersetzt wurde.
+
+Der FMOV Befehl (REAL :=) ist schneller als auf der
+M24, sowie einige Vergleiche von langen Texten. Der Test auf der M24 war mit
+einem V30 Prozessor durchgefhrt worden.
+
+
+ Steuerkonstrukte
+
+FOR REP .17396 msec
+WHILE REP .17396 msec
+UNTIL REP .14955 msec
+IF .05799 msec
+SELECT .24721 msec
+PROC .41201 msec
+PROC (INT) .49441 msec
+PROC (INT, INT) .66532 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .07630 msec
+INT := (Prozedurdaten) .11292 msec
+INT := (Parameter) .18922 msec
+ROW INT [i] .34182 msec
+INT = .08851 msec
+INT <= .09156 msec
+INT + .10987 msec
+INT * .25942 msec
+DIV .48831 msec
+INCR .07630 msec
+MOD .51578 msec
+abs (INT) 1.28792 msec
+min (INT , INT) 1.27876 msec
+
+
+ Real Operationen
+
+REAL := .10987 msec (schneller als M24)
+ROW REAL [i] .40591 msec
+REAL = .25636 msec
+REAL <= .17701 msec
+REAL + .63175 msec
+REAL * 1.93798 msec (schneller als M24)
+REAL / 3.75084 msec
+INCR 1.55649 msec
+MOD 8.37148 msec
+abs (REAL) 1.43441 msec
+min (REAL, REAL) 1.35812 msec
+
+
+ Text Operationen
+
+TEXT := (1) .11903 msec
+TEXT := (10) .64091 msec
+TEXT := (30) .59513 msec
+ROW TEXT [i] .42727 msec
+TEXT = (1) .14955 msec (schneller als M24)
+TEXT = (10) .50052 msec
+TEXT = (30) .66838 msec (schneller als M24)
+TEXT <= (1) .29299 msec
+TEXT <= (10) .54019 msec
+TEXT <= (30) .71415 msec (schneller als M24)
+TEXT * (Faktor 1) 2.03259 msec
+CAT (1) .49136 msec
+TEXT + (1) 1.66331 msec
+TEXT + (10) 2.57889 msec
+TEXT + (30) 2.79863 msec
+length (1) .10987 msec
+length (10) .10987 msec
+length (30) .11597 msec
+SUB (1) .25026 msec
+SUB (10) .25026 msec
+SUB (30) .32351 msec
+subtext (TEXT, INT, INT) (1) .32045 msec
+subtext (TEXT, INT, INT) (10) .32045 msec
+subtext (TEXT, INT, INT) (30) .39370 msec
+replace (TEXT, TEXT, INT) (1) .34792 msec
+replace (TEXT, TEXT, INT) (10) .35097 msec
+replace (TEXT, TEXT, INT) (30) .45779 msec
+text (TEXT, INT, INT) (1) 3.54331 msec
+text (TEXT, INT, INT) (10) 3.40902 msec
+text (TEXT, INT, INT) (30) 3.75084 msec
+pos (TEXT, TEXT, INT) (1) .43643 msec
+pos (TEXT, TEXT, INT) (10) .45779 msec
+pos (TEXT, TEXT, INT) (30) .56461 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) 3.17097 msec
+real (INT) 1.65110 msec
+int (TEXT) 14.84160 msec
+text (INT) 2.84746 msec
+text (INT, INT) 9.62888 msec
+text (REAL) 41.02728 msec
+text (REAL, INT, INT) 8.95746 msec
+code (INT) .10682 msec
+code (TEXT) .15260 msec
diff --git a/app/speedtest/1986/doc/MEMBIC10.PRT b/app/speedtest/1986/doc/MEMBIC10.PRT new file mode 100644 index 0000000..259688d --- /dev/null +++ b/app/speedtest/1986/doc/MEMBIC10.PRT @@ -0,0 +1,100 @@ + BICOS SYSTEM 286/20 80286-10
+ ===================================
+
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+
+ Steuerkonstrukte
+
+FOR REP .03357 msec
+WHILE REP .02747 msec
+UNTIL REP .02442 msec
+IF .01221 msec
+SELECT .07630 msec
+PROC .08240 msec
+PROC (INT) .09461 msec
+PROC (INT, INT) .10987 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .01526 msec
+INT := (Prozedurdaten) .02136 msec
+INT := (Parameter) .03357 msec
+ROW INT [i] .09766 msec
+INT = .02136 msec
+INT <= .02136 msec
+INT + .01831 msec
+INT * .06104 msec
+DIV .07019 msec
+INCR .01221 msec
+MOD .07019 msec
+abs (INT) .31435 msec
+min (INT , INT) .25331 msec
+
+
+ Real Operationen
+
+REAL := .04273 msec
+ROW REAL [i] .12818 msec
+REAL = .10071 msec
+REAL <= .06714 msec
+REAL + .24416 msec
+REAL * .92474 msec
+REAL / 1.70604 msec
+INCR .49441 msec
+MOD 3.42733 msec
+abs (REAL) .37234 msec
+min (REAL, REAL) .33877 msec
+
+
+ Text Operationen
+
+TEXT := (1) .04883 msec
+TEXT := (10) .24721 msec
+TEXT := (30) .20448 msec
+ROW TEXT [i] .14039 msec
+TEXT = (1) .06104 msec
+TEXT = (10) .20753 msec
+TEXT = (30) .31740 msec
+TEXT <= (1) .10987 msec
+TEXT <= (10) .21669 msec
+TEXT <= (30) .32656 msec
+TEXT * (Faktor 1) .49747 msec
+CAT (1) .18312 msec
+TEXT + (1) .45169 msec
+TEXT + (10) .74162 msec
+TEXT + (30) .77825 msec
+length (1) .04273 msec
+length (10) .04273 msec
+length (30) .04273 msec
+SUB (1) .09461 msec
+SUB (10) .09156 msec
+SUB (30) .12208 msec
+subtext (TEXT, INT, INT) (1) .11597 msec
+subtext (TEXT, INT, INT) (10) .11597 msec
+subtext (TEXT, INT, INT) (30) .14344 msec
+replace (TEXT, TEXT, INT) (1) .12208 msec
+replace (TEXT, TEXT, INT) (10) .12208 msec
+replace (TEXT, TEXT, INT) (30) .15565 msec
+text (TEXT, INT, INT) (1) .80877 msec
+text (TEXT, INT, INT) (10) .83928 msec
+text (TEXT, INT, INT) (30) .96136 msec
+pos (TEXT, TEXT, INT) (1) .15870 msec
+pos (TEXT, TEXT, INT) (10) .16480 msec
+pos (TEXT, TEXT, INT) (30) .20143 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) .79045 msec
+real (INT) .35708 msec
+int (TEXT) 4.05603 msec
+text (INT) .61649 msec
+text (INT, INT) 2.32253 msec
+text (REAL) 12.34511 msec
+text (REAL, INT, INT) 2.25539 msec
+code (INT) .03968 msec
+code (TEXT) .05493 msec
diff --git a/app/speedtest/1986/doc/MEMBIC8.PRT b/app/speedtest/1986/doc/MEMBIC8.PRT new file mode 100644 index 0000000..315e1c2 --- /dev/null +++ b/app/speedtest/1986/doc/MEMBIC8.PRT @@ -0,0 +1,101 @@ + BICOS 286/20 INTEL80286-8
+ ==========================================
+
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+
+ Steuerkonstrukte
+
+FOR REP .04273 msec
+WHILE REP .03968 msec
+UNTIL REP .03357 msec
+IF .01831 msec
+SELECT .10071 msec
+PROC .10377 msec
+PROC (INT) .12208 msec
+PROC (INT, INT) .13734 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .01831 msec
+INT := (Prozedurdaten) .02442 msec
+INT := (Parameter) .04273 msec
+ROW INT [i] .12513 msec
+INT = .02442 msec
+INT <= .02136 msec
+INT + .02442 msec
+INT * .07935 msec
+DIV .08545 msec
+INCR .01831 msec
+MOD .08545 msec
+abs (INT) .39980 msec
+min (INT , INT) .32045 msec
+
+
+ Real Operationen
+
+REAL := .05188 msec
+ROW REAL [i] .16480 msec
+REAL = .12208 msec
+REAL <= .08240 msec
+REAL + .30825 msec
+REAL * 1.17805 msec
+REAL / 2.16688 msec
+INCR .63175 msec
+MOD 4.30324 msec
+abs (REAL) .47000 msec
+min (REAL, REAL) .42117 msec
+
+
+ Text Operationen
+
+TEXT := (1) .06104 msec
+TEXT := (10) .30519 msec
+TEXT := (30) .25636 msec
+ROW TEXT [i] .17396 msec
+TEXT = (1) .07935 msec
+TEXT = (10) .25636 msec
+TEXT = (30) .39675 msec
+TEXT <= (1) .13734 msec
+TEXT <= (10) .26857 msec
+TEXT <= (30) .40896 msec
+TEXT * (Faktor 1) .61954 msec
+CAT (1) .22890 msec
+TEXT + (1) .57377 msec
+TEXT + (10) .93389 msec
+TEXT + (30) .98883 msec
+length (1) .04883 msec
+length (10) .05188 msec
+length (30) .05188 msec
+SUB (1) .11903 msec
+SUB (10) .11903 msec
+SUB (30) .15565 msec
+subtext (TEXT, INT, INT) (1) .14344 msec
+subtext (TEXT, INT, INT) (10) .14955 msec
+subtext (TEXT, INT, INT) (30) .18006 msec
+replace (TEXT, TEXT, INT) (1) .15565 msec
+replace (TEXT, TEXT, INT) (10) .15565 msec
+replace (TEXT, TEXT, INT) (30) .19532 msec
+text (TEXT, INT, INT) (1) 1.02545 msec
+text (TEXT, INT, INT) (10) 1.06208 msec
+text (TEXT, INT, INT) (30) 1.21467 msec
+pos (TEXT, TEXT, INT) (1) .20143 msec
+pos (TEXT, TEXT, INT) (10) .21058 msec
+pos (TEXT, TEXT, INT) (30) .25331 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) .99799 msec
+real (INT) .44864 msec
+int (TEXT) 5.13947 msec
+text (INT) .78130 msec
+text (INT, INT) 2.93597 msec
+text (REAL) 15.58323 msec
+text (REAL, INT, INT) 2.85662 msec
+code (INT) .04883 msec
+code (TEXT) .07019 msec
+
diff --git a/app/speedtest/1986/doc/MEMCLA15.PRT b/app/speedtest/1986/doc/MEMCLA15.PRT new file mode 100644 index 0000000..cd9213e --- /dev/null +++ b/app/speedtest/1986/doc/MEMCLA15.PRT @@ -0,0 +1,100 @@ +
+ Classis AT 15 MHz / 80286
+ =========================
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+
+ Steuerkonstrukte
+
+FOR REP .02442 msec
+WHILE REP .02136 msec
+UNTIL REP .01831 msec
+IF .00916 msec
+SELECT .04883 msec
+PROC .05188 msec
+PROC (INT) .06104 msec
+PROC (INT, INT) .06714 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .00610 msec
+INT := (Prozedurdaten) .01221 msec
+INT := (Parameter) .02136 msec
+ROW INT [i] .06104 msec
+INT = .00916 msec
+INT <= .00916 msec
+INT + .00916 msec
+INT * .03662 msec
+DIV .04273 msec
+INCR .00916 msec
+MOD .04273 msec
+abs (INT) .18006 msec
+min (INT , INT) .16786 msec
+
+
+ Real Operationen
+
+REAL := .02442 msec
+ROW REAL [i] .08240 msec
+REAL = .07019 msec
+REAL <= .04883 msec
+REAL + .16786 msec
+REAL * .62260 msec
+REAL / 1.12312 msec
+INCR .33571 msec
+MOD 2.29506 msec
+abs (REAL) .25331 msec
+min (REAL, REAL) .22584 msec
+
+
+ Text Operationen
+
+TEXT := (1) .03052 msec
+TEXT := (10) .15870 msec
+TEXT := (30) .13429 msec
+ROW TEXT [i] .09156 msec
+TEXT = (1) .03968 msec
+TEXT = (10) .13734 msec
+TEXT = (30) .21058 msec
+TEXT <= (1) .07325 msec
+TEXT <= (10) .14039 msec
+TEXT <= (30) .21364 msec
+TEXT * (Faktor 1) .32656 msec
+CAT (1) .11903 msec
+TEXT + (1) .30214 msec
+TEXT + (10) .49441 msec
+TEXT + (30) .51883 msec
+length (1) .02442 msec
+length (10) .02442 msec
+length (30) .02442 msec
+SUB (1) .06104 msec
+SUB (10) .06104 msec
+SUB (30) .08240 msec
+subtext (TEXT, INT, INT) (1) .07630 msec
+subtext (TEXT, INT, INT) (10) .07630 msec
+subtext (TEXT, INT, INT) (30) .09156 msec
+replace (TEXT, TEXT, INT) (1) .07935 msec
+replace (TEXT, TEXT, INT) (10) .07935 msec
+replace (TEXT, TEXT, INT) (30) .10377 msec
+text (TEXT, INT, INT) (1) .54325 msec
+text (TEXT, INT, INT) (10) .55545 msec
+text (TEXT, INT, INT) (30) .63480 msec
+pos (TEXT, TEXT, INT) (1) .10071 msec
+pos (TEXT, TEXT, INT) (10) .10682 msec
+pos (TEXT, TEXT, INT) (30) .13123 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) .54630 msec
+real (INT) .23500 msec
+int (TEXT) 2.72844 msec
+text (INT) .41506 msec
+text (INT, INT) 1.55039 msec
+text (REAL) 8.32570 msec
+text (REAL, INT, INT) 1.56870 msec
+code (INT) .02747 msec
+code (TEXT) .03357 msec
diff --git a/app/speedtest/1986/doc/MEMRUC12.PRT b/app/speedtest/1986/doc/MEMRUC12.PRT new file mode 100644 index 0000000..b9a8225 --- /dev/null +++ b/app/speedtest/1986/doc/MEMRUC12.PRT @@ -0,0 +1,101 @@ +#type ("17.klein")#
+ ruc-AT 80286/12 MHz
+ ========================
+
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+
+ Steuerkonstrukte
+
+FOR REP .03052 msec
+WHILE REP .03052 msec
+UNTIL REP .02747 msec
+IF .01221 msec
+SELECT .06409 msec
+PROC .06714 msec
+PROC (INT) .07935 msec
+PROC (INT, INT) .08851 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .00916 msec
+INT := (Prozedurdaten) .01221 msec
+INT := (Parameter) .02747 msec
+ROW INT [i] .07935 msec
+INT = .01526 msec
+INT <= .01221 msec
+INT + .01221 msec
+INT * .04883 msec
+DIV .05493 msec
+INCR .00916 msec
+MOD .05799 msec
+abs (INT) .22584 msec
+min (INT , INT) .21364 msec
+
+
+ Real Operationen
+
+REAL := .03052 msec
+ROW REAL [i] .10682 msec
+REAL = .08851 msec
+REAL <= .06409 msec
+REAL + .21058 msec
+REAL * .79351 msec
+REAL / 1.42831 msec
+INCR .42727 msec
+MOD 2.91155 msec
+abs (REAL) .32045 msec
+min (REAL, REAL) .28383 msec
+
+
+ Text Operationen
+
+TEXT := (1) .03968 msec
+TEXT := (10) .20143 msec
+TEXT := (30) .16786 msec
+ROW TEXT [i] .11292 msec
+TEXT = (1) .04883 msec
+TEXT = (10) .17091 msec
+TEXT = (30) .26552 msec
+TEXT <= (1) .08851 msec
+TEXT <= (10) .18006 msec
+TEXT <= (30) .27162 msec
+TEXT * (Faktor 1) .42422 msec
+CAT (1) .14955 msec
+TEXT + (1) .38149 msec
+TEXT + (10) .62260 msec
+TEXT + (30) .66532 msec
+length (1) .03357 msec
+length (10) .03357 msec
+length (30) .03357 msec
+SUB (1) .07630 msec
+SUB (10) .07630 msec
+SUB (30) .09766 msec
+subtext (TEXT, INT, INT) (1) .09766 msec
+subtext (TEXT, INT, INT) (10) .09461 msec
+subtext (TEXT, INT, INT) (30) .11903 msec
+replace (TEXT, TEXT, INT) (1) .10377 msec
+replace (TEXT, TEXT, INT) (10) .10071 msec
+replace (TEXT, TEXT, INT) (30) .13123 msec
+text (TEXT, INT, INT) (1) .68974 msec
+text (TEXT, INT, INT) (10) .71415 msec
+text (TEXT, INT, INT) (30) .81182 msec
+pos (TEXT, TEXT, INT) (1) .12818 msec
+pos (TEXT, TEXT, INT) (10) .13429 msec
+pos (TEXT, TEXT, INT) (30) .16786 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) .69279 msec
+real (INT) .29909 msec
+int (TEXT) 3.45480 msec
+text (INT) .52799 msec
+text (INT, INT) 1.95935 msec
+text (REAL) 10.56583 msec
+text (REAL, INT, INT) 1.98376 msec
+code (INT) .03357 msec
+code (TEXT) .04883 msec
diff --git a/app/speedtest/1986/doc/MEMV30.PRT b/app/speedtest/1986/doc/MEMV30.PRT new file mode 100644 index 0000000..0d259be --- /dev/null +++ b/app/speedtest/1986/doc/MEMV30.PRT @@ -0,0 +1,100 @@ + M 24 mit V 30 V 30 /8Mhz
+ =============================
+
+
+Wiederholungsfaktor fr schnelle Operationen : 32766
+Wiederholungsfaktor fr langsame Operationen : 16383
+
+
+ Steuerkonstrukte
+
+FOR REP .07325 msec
+WHILE REP .07019 msec
+UNTIL REP .06409 msec
+IF .03968 msec
+SELECT .18006 msec
+PROC .18312 msec
+PROC (INT) .21058 msec
+PROC (INT, INT) .24416 msec
+
+
+ Integer Operationen
+
+INT := (Paketdaten) .03052 msec
+INT := (Prozedurdaten) .04273 msec
+INT := (Parameter) .07325 msec
+ROW INT [i] .20143 msec
+INT = .04273 msec
+INT <= .03968 msec
+INT + .04273 msec
+INT * .12513 msec
+DIV .13734 msec
+INCR .03052 msec
+MOD .13734 msec
+abs (INT) .58292 msec
+min (INT , INT) .54325 msec
+
+
+ Real Operationen
+
+REAL := .13123 msec
+ROW REAL [i] .26857 msec
+REAL = .20143 msec
+REAL <= .14039 msec
+REAL + .51273 msec
+REAL * 2.10584 msec
+REAL / 3.72337 msec
+INCR 1.11091 msec
+MOD 7.51389 msec
+abs (REAL) .77825 msec
+min (REAL, REAL) .70500 msec
+
+
+ Text Operationen
+
+TEXT := (1) .10071 msec
+TEXT := (10) .48526 msec
+TEXT := (30) .55545 msec
+ROW TEXT [i] .28078 msec
+TEXT = (1) .17701 msec
+TEXT = (10) .40896 msec
+TEXT = (30) .75078 msec
+TEXT <= (1) .21974 msec
+TEXT <= (10) .42727 msec
+TEXT <= (30) .77214 msec
+TEXT * (Faktor 1) 1.03766 msec
+CAT (1) .36929 msec
+TEXT + (1) .95221 msec
+TEXT + (10) 1.69688 msec
+TEXT + (30) 1.94104 msec
+length (1) .08545 msec
+length (10) .08545 msec
+length (30) .08851 msec
+SUB (1) .18922 msec
+SUB (10) .18922 msec
+SUB (30) .26247 msec
+subtext (TEXT, INT, INT) (1) .24110 msec
+subtext (TEXT, INT, INT) (10) .23805 msec
+subtext (TEXT, INT, INT) (30) .29299 msec
+replace (TEXT, TEXT, INT) (1) .24721 msec
+replace (TEXT, TEXT, INT) (10) .24721 msec
+replace (TEXT, TEXT, INT) (30) .32656 msec
+text (TEXT, INT, INT) (1) 1.72740 msec
+text (TEXT, INT, INT) (10) 1.77013 msec
+text (TEXT, INT, INT) (30) 2.27675 msec
+pos (TEXT, TEXT, INT) (1) .32351 msec
+pos (TEXT, TEXT, INT) (10) .33266 msec
+pos (TEXT, TEXT, INT) (30) .40591 msec
+
+
+ Konvertierungs Operationen
+
+int (REAL) 1.68467 msec
+real (INT) .75993 msec
+int (TEXT) 8.32570 msec
+text (INT) .93389 msec
+text (INT, INT) 4.52298 msec
+text (REAL) 26.61295 msec
+text (REAL, INT, INT) 5.20662 msec
+code (INT) .08240 msec
+code (TEXT) .11292 msec
diff --git a/app/speedtest/1986/src/convert operation b/app/speedtest/1986/src/convert operation new file mode 100644 index 0000000..903f2e5 --- /dev/null +++ b/app/speedtest/1986/src/convert operation @@ -0,0 +1,396 @@ +PACKET convert DEFINES real to int,
+ int to real,
+ text to int,
+ int to text,
+ int to text 2,
+ real to text,
+ real to text 2,
+ code int,
+ code text :
+
+
+(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+INT VAR index,
+ first int,
+ i ;
+
+
+REAL VAR begin,
+ end,
+ act result,
+ first real ;
+
+
+TEXT VAR single text :: "*",
+ free text ;
+
+
+
+
+PROC real to int (INT CONST frequency) :
+
+ first real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := int (first real)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real to int s (frequency)
+
+END PROC real to int ;
+
+
+
+
+PROC real to int s (INT CONST frequency) :
+
+ first real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := int (first real)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("int (REAL)", act result * msec factor (frequency) - for corr)
+
+END PROC real to int s ;
+
+
+
+
+PROC int to real (INT CONST frequency) :
+
+ first int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := real (first int)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int to real s (frequency)
+
+END PROC int to real ;
+
+
+
+
+PROC int to real s (INT CONST frequency) :
+
+ first int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := real (first int)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("real (INT)", act result * msec factor (frequency) - for corr)
+
+END PROC int to real s ;
+
+
+
+
+PROC text to int (INT CONST frequency) :
+
+ free text := "1111" ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := int (free text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text to int s (frequency)
+
+END PROC text to int ;
+
+
+
+
+PROC text to int s (INT CONST frequency) :
+
+ free text := "1111" ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := int (free text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("int (TEXT)", act result * msec factor (frequency) - for corr)
+
+END PROC text to int s ;
+
+
+
+
+PROC int to text (INT CONST frequency) :
+
+ first int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first int) ;
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int to text s (frequency)
+
+END PROC int to text ;
+
+
+
+
+PROC int to text s (INT CONST frequency) :
+
+ first int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first int) ;
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("text (INT)", act result * msec factor (frequency) - for corr)
+
+END PROC int to text s ;
+
+
+
+
+PROC int to text 2 (INT CONST frequency) :
+
+ first int := 1 ;
+ i := 3 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first int, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int to text 2 s (frequency)
+
+END PROC int to text 2 ;
+
+
+
+
+PROC int to text 2 s (INT CONST frequency) :
+
+ first int := 1 ;
+ i := 3 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first int, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("text (INT, INT)", act result * msec factor (frequency) - for corr)
+
+END PROC int to text 2 s ;
+
+
+
+
+PROC real to text (INT CONST frequency) :
+
+ first real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first real)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real to text s (frequency)
+
+END PROC real to text ;
+
+
+
+
+PROC real to text s (INT CONST frequency) :
+
+ first real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first real)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("text (REAL)", act result * msec factor (frequency) - for corr)
+
+END PROC real to text s ;
+
+
+
+
+PROC real to text 2 (INT CONST frequency) :
+
+ first real := 1.0 ;
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first real, i, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real to text 2 s (frequency)
+
+END PROC real to text 2 ;
+
+
+
+
+PROC real to text 2 s (INT CONST frequency) :
+
+ first real := 1.0 ;
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (first real, i, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("text (REAL, INT, INT)", act result * msec factor (frequency) - for corr)
+
+END PROC real to text 2 s ;
+
+
+
+
+PROC code int (INT CONST frequency) :
+
+ i := 65 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := code (i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ code int s (frequency)
+
+END PROC code int ;
+
+
+
+
+PROC code int s (INT CONST frequency) :
+
+ i := 65 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := code (i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("code (INT)", act result * msec factor (frequency) - for corr)
+
+END PROC code int s ;
+
+
+
+
+PROC code text (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := code (single text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ code text s (frequency)
+
+END PROC code text ;
+
+
+
+
+PROC code text s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := code (single text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("code (TEXT)", act result * msec factor (frequency) - for corr)
+
+END PROC code text s ;
+
+
+END PACKET convert ;
diff --git a/app/speedtest/1986/src/gen.benchmark b/app/speedtest/1986/src/gen.benchmark new file mode 100644 index 0000000..bb53ecc --- /dev/null +++ b/app/speedtest/1986/src/gen.benchmark @@ -0,0 +1,98 @@ +(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+LET max quantity = 99,
+ pagelength = 20 ;
+
+ROW max quantity TEXT VAR prog list ;
+
+INT VAR prog counter :: 0,
+ namelength :: 0,
+ counter,
+ storage size,
+ used storage ;
+
+
+
+PROC announce (TEXT CONST prog name) :
+
+ prog counter INCR 1 ;
+ prog list [prog counter] := prog name ;
+ IF NOT exists (prog name)
+ THEN fetch (prog name, archive)
+ FI ;
+ IF LENGTH prog name > namelength
+ THEN namelength := LENGTH prog name
+ FI ;
+
+END PROC announce ;
+
+
+
+PROC execute :
+
+ INT CONST first page :: 1,
+ last page :: (prog counter DIV pagelength) + 1 ;
+
+ INT VAR pagenumber,
+ linenumber,
+ act linenumber,
+ act first line,
+ act last line ;
+
+ FOR page number FROM first page UPTO last page
+ REP act first line := (pagenumber - 1) * pagelength + 1 ;
+ act last line := min (prog counter, pagenumber * pagelength) ;
+ FOR act line number FROM act first line UPTO act last line
+ REP display (""1""4"") ;
+ display (" Stand der Benchmark Insertierung ") ;
+ IF last page > 1
+ THEN display ("(" + text (pagenumber) + ". von " + text (last page) + " Seiten) :")
+ ELSE display (":")
+ FI ;
+ display (""13""10""13""10"") ;
+ FOR linenumber FROM act first line UPTO act last line
+ REP IF linenumber = act linenumber
+ THEN display (" " + ""15""8"" + prog list [linenumber] + ""14""8""5"")
+ ELSE display (" " + prog list [linenumber] + ""5"")
+ FI ;
+ display (""13""10"")
+ PER ;
+ display (""6"" + code (act linenumber - act first line + 2) + code (namelength + 20)) ;
+ insert (prog list [act linenumber]) ;
+ #forget (prog list [act linenumber], quiet)#
+ PER
+ PER ;
+ display (""1""4"") ;
+ display ("Insertierung abgeschlossen!") ;
+ display (""13""10"") ;
+ IF yes ("Benchmark starten")
+ THEN do ("test speed")
+ FI ;
+
+END PROC execute ;
+
+
+
+check off ;
+announce ("notice") ;
+announce ("run down logic") ;
+announce ("integer operation") ;
+announce ("real operation") ;
+announce ("text operation") ;
+announce ("convert operation") ;
+announce ("speed tester") ;
+
+
+display (""1""4"") ;
+execute ;
+release (archive) ;
+#forget ("gen.benchmark", quiet) ;#
+check on ;
+
+
+
diff --git a/app/speedtest/1986/src/integer operation b/app/speedtest/1986/src/integer operation new file mode 100644 index 0000000..90ef0f2 --- /dev/null +++ b/app/speedtest/1986/src/integer operation @@ -0,0 +1,614 @@ +PACKET integer operation DEFINES int assign global,
+ int assign local,
+ int assign param,
+ int equal,
+ int lequal,
+ int abs,
+ int min,
+ int incr,
+ row int,
+ int div,
+ int mod,
+ int add,
+ int mult :
+
+
+(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+ROW 10 INT VAR introw ;
+
+
+REAL VAR begin,
+ end,
+ act result,
+ int assign factor ;
+
+
+INT VAR first int,
+ second int,
+ third int,
+ rest,
+ i ,
+ index ;
+
+
+
+PROC int assign global (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int
+ END REP ;
+ end := clock (0);
+
+ act result := end - begin ;
+
+ int assign global s (frequency)
+
+END PROC int assign global ;
+
+
+
+
+PROC int assign global s (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int
+ END REP ;
+ end := clock (0);
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ int assign factor := act result * msec factor (frequency) - for corr ;
+
+ notice result ("INT := (Paketdaten)", int assign factor) ;
+
+END PROC int assign global s ;
+
+
+
+
+PROC int assign local (INT CONST frequency) :
+
+ INT VAR number one :: 0,
+ number two :: 1 ;
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ number one := number two
+ END REP ;
+ end := clock (0);
+
+ act result := end - begin ;
+
+ int assign local s (frequency)
+
+END PROC int assign local ;
+
+
+
+
+PROC int assign local s (INT CONST frequency) :
+
+ INT VAR number one :: 0,
+ number two :: 1 ;
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ number one := number two
+ END REP ;
+ end := clock (0);
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INT := (Prozedurdaten)", act result * msec factor (frequency) - for corr) ;
+
+END PROC int assign local s ;
+
+
+
+
+PROC int assign param (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ int assign (first int, second int, frequency) ;
+ first int := 0 ;
+ int assign s (first int, second int, frequency)
+
+END PROC int assign param ;
+
+
+
+
+PROC int assign (INT VAR one, INT CONST two, frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ one := two
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+END PROC int assign ;
+
+
+
+
+PROC int assign s (INT VAR one, INT CONST two, frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ one := two
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INT := (Parameter)", act result * msec factor (frequency) - for corr) ;
+
+END PROC int assign s ;
+
+
+
+
+PROC row int (INT CONST frequency) :
+
+ i := 7 ;
+ int row [i] := 0 ;
+ first int := 10000 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ introw [i] := first int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ row int s (frequency)
+
+END PROC row int ;
+
+
+
+
+PROC row int s (INT CONST frequency) :
+
+ i := 7 ;
+ int row [i] := 0 ;
+ first int := 10000 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ introw [i] := first int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("ROW INT [i]", act result * msec factor (frequency) - for corr) ;
+
+END PROC row int s ;
+
+
+
+
+PROC int equal (INT CONST frequency) :
+
+ first int := 10 ;
+ second int := 10 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first int = second int
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int equal s (frequency)
+
+END PROC int equal ;
+
+
+
+
+PROC int equal s (INT CONST frequency) :
+
+ first int := 10 ;
+ second int := 10 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first int = second int
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INT =", act result * msec factor (frequency) - for corr)
+
+END PROC int equal s ;
+
+
+
+
+PROC int lequal (INT CONST frequency) :
+
+ first int := 10 ;
+ second int := 11 ;
+ begin := clock(0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first int <= second int
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int lequal s (frequency)
+
+END PROC int lequal ;
+
+
+
+
+PROC int lequal s (INT CONST frequency) :
+
+ first int := 10 ;
+ second int := 11 ;
+ begin := clock(0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first int <= second int
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INT <=", act result * msec factor (frequency) - for corr)
+
+END PROC int lequal s ;
+
+
+
+
+PROC int add (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ third int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int + third int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int add s (frequency)
+
+END PROC int add ;
+
+
+
+
+PROC int add s (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ third int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int + third int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INT +", act result * msec factor (frequency) - for corr)
+
+END PROC int add s ;
+
+
+
+
+PROC int mult (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 99 ;
+ third int := 11 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int * third int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int mult s (frequency)
+
+END PROC int mult ;
+
+
+
+
+PROC int mult s (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 99 ;
+ third int := 11 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int * third int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INT *", act result * msec factor (frequency) - for corr)
+
+END PROC int mult s ;
+
+
+
+
+PROC int div (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 10001 ;
+ third int := 99 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int DIV third int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int div s (frequency)
+
+END PROC int div ;
+
+
+
+
+PROC int div s (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 10001 ;
+ third int := 99 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int := second int DIV third int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("DIV", act result * msec factor (frequency) - for corr)
+
+END PROC int div s ;
+
+
+
+
+PROC int mod (INT CONST frequency) :
+
+ first int := 9999 ;
+ second int := 55 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ rest := first int MOD second int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int mod s (frequency)
+
+END PROC int mod ;
+
+
+
+
+PROC int mod s (INT CONST frequency) :
+
+ first int := 9999 ;
+ second int := 55 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ rest := first int MOD second int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("MOD", act result * msec factor (frequency) - for corr)
+
+END PROC int mod s ;
+
+
+
+
+PROC int incr (INT CONST frequency) :
+
+ first int:= 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int INCR second int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int incr s (frequency)
+
+END PROC int incr ;
+
+
+
+
+PROC int incr s (INT CONST frequency) :
+
+ first int:= 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int INCR second int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INCR" , act result * msec factor (frequency) - for corr) ;
+
+END PROC int incr s ;
+
+
+
+
+PROC int abs (INT CONST frequency) :
+
+ first int := - 10000 ;
+ second int := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ second int := abs (first int)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int abs s (frequency)
+
+END PROC int abs ;
+
+
+
+
+PROC int abs s (INT CONST frequency) :
+
+ first int := - 10000 ;
+ second int := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ second int := abs (first int)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("abs (INT)", act result * msec factor (frequency) - for corr) ;
+
+END PROC int abs s ;
+
+
+
+
+PROC int min (INT CONST frequency) :
+
+ i := 0 ;
+ first int := 9999 ;
+ second int := 10000 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := min (first int, second int)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ int min s (frequency)
+
+END PROC int min ;
+
+
+
+
+PROC int min s (INT CONST frequency) :
+
+ i := 0 ;
+ first int := 9999 ;
+ second int := 10000 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := min (first int, second int)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("min (INT , INT)", act result * msec factor (frequency) - for corr) ;
+
+END PROC int min s ;
+
+
+END PACKET integer operation ;
diff --git a/app/speedtest/1986/src/notice b/app/speedtest/1986/src/notice new file mode 100644 index 0000000..ea1bca9 --- /dev/null +++ b/app/speedtest/1986/src/notice @@ -0,0 +1,102 @@ +PACKET notice DEFINES notice material,
+ notice heading,
+ notice operation,
+ notice result,
+ notice frequency,
+ notice runtime,
+ output mem :
+
+
+(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+FILE VAR mem ;
+
+
+
+PROC notice result (TEXT CONST operation, REAL CONST runtime) :
+
+ TEXT VAR layout :: "" ;
+
+ layout CAT (operation + (40 - LENGTH operation) * " " + text (runtime, 10, 5) + " msec") ;
+ putline (mem, layout)
+
+END PROC notice result ;
+
+
+
+PROC notice material (TEXT CONST name) :
+
+ TEXT VAR layout :: "" ;
+
+ layout CAT (" " + name) ;
+ line (mem, 4) ;
+ putline (mem, layout) ;
+ layout := " " + LENGTH name * "=" ;
+ putline (mem, layout) ;
+ line (mem, 3)
+
+END PROC notice material ;
+
+
+
+PROC notice heading (TEXT CONST name) :
+
+ TEXT VAR layout :: "" ;
+
+ layout CAT (" " + name) ;
+ line (mem,2) ;
+ putline (mem, layout) ;
+ line (mem, 1) ;
+
+ display (""6""+code(21)+code(0)) ;
+ display (""5""13"") ;
+ display (""15""+" "+name+" "+""14"")
+
+END PROC notice heading ;
+
+
+
+PROC notice frequency (INT CONST frequency 1, frequency 2) :
+
+ line (mem, 1) ;
+ put (mem, "Wiederholungsfaktor fr schnelle Operationen : "+text (frequency 1)) ;
+ line (mem, 1) ;
+ put (mem, "Wiederholungsfaktor fr langsame Operationen : "+text (frequency 2)) ;
+ line (mem, 1)
+
+END PROC notice frequency ;
+
+
+
+PROC notice operation (TEXT CONST operation) :
+
+ display(""6""+code(22)+code(0)) ;
+ display (""5""13"") ;
+ display (""15""+" "+ operation +" "+""14"") ;
+
+END PROC notice operation ;
+
+
+
+PROC notice runtime (REAL CONST runtime) :
+
+ line (mem, 3) ;
+ putline (mem, "Gesamtlaufzeit : " + text (runtime)) ;
+
+END PROC notice runtime ;
+
+
+
+PROC output mem :
+
+ mem := sequential file (output, "memory")
+
+END PROC output mem ;
+
+
+END PACKET notice ;
diff --git a/app/speedtest/1986/src/real operation b/app/speedtest/1986/src/real operation new file mode 100644 index 0000000..2d63d1b --- /dev/null +++ b/app/speedtest/1986/src/real operation @@ -0,0 +1,519 @@ +PACKET real operation DEFINES real assign,
+ row real,
+ real add,
+ real mult,
+ real div,
+ real incr,
+ real mod,
+ real equal,
+ real lequal,
+ real abs,
+ real min :
+
+
+(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+ROW 10 REAL VAR real row ;
+
+
+
+INT VAR index,
+ i ;
+
+
+REAL VAR begin,
+ end,
+ first real,
+ second real,
+ third real,
+ rest,
+ act result,
+ real assign factor ;
+
+
+
+
+PROC real assign (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real assign s (frequency)
+
+END PROC real assign ;
+
+
+
+
+PROC real assign s (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ real assign factor := act result * msec factor (frequency) - for corr ;
+
+ notice result ("REAL :=", real assign factor) ;
+
+END PROC real assign s ;
+
+
+
+
+PROC row real (INT CONST frequency) :
+
+ first real := 1.0 ;
+ i := 7 ;
+ real row [i] := 0.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ real row [i] := first real
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ row real s (frequency)
+
+END PROC row real ;
+
+
+
+
+PROC row real s (INT CONST frequency) :
+
+ first real := 1.0 ;
+ i := 7 ;
+ real row [i] := 0.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ real row [i] := first real
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("ROW REAL [i]", act result * msec factor (frequency) - for corr) ;
+
+END PROC row real s ;
+
+
+
+
+PROC real equal (INT CONST frequency) :
+
+ first real := 10.0 ;
+ second real := 10.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first real = second real
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real equal s (frequency)
+
+END PROC real equal ;
+
+
+
+
+PROC real equal s (INT CONST frequency) :
+
+ first real := 10.0 ;
+ second real := 10.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first real = second real
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("REAL =", act result * msec factor (frequency) - for corr)
+
+END PROC real equal s ;
+
+
+
+
+PROC real lequal (INT CONST frequency) :
+
+ first real := 10.0 ;
+ second real := 11.0 ;
+ begin := clock(0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first real <= second real
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real lequal s (frequency)
+
+END PROC real lequal ;
+
+
+
+
+PROC real lequal s (INT CONST frequency) :
+
+ first real := 10.0 ;
+ second real := 11.0 ;
+ begin := clock(0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF first real <= second real
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("REAL <=", act result * msec factor (frequency) - for corr)
+
+END PROC real lequal s ;
+
+
+
+
+PROC real add (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.0 ;
+ third real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real + third real
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real add s (frequency)
+
+END PROC real add ;
+
+
+
+
+PROC real add s (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.0 ;
+ third real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real + third real
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("REAL +", act result * msec factor (frequency) - for corr) ;
+
+END PROC real add s ;
+
+
+
+
+PROC real mult (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.001 ;
+ third real := 1.001 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real * third real
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real mult s (frequency)
+
+END PROC real mult ;
+
+
+
+
+PROC real mult s (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.001 ;
+ third real := 1.001 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real * third real
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("REAL *", act result * msec factor (frequency) - for corr) ;
+
+END PROC real mult s ;
+
+
+
+
+PROC real div (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 10000.0 ;
+ third real := 1.0001 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real / third real
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real div s (frequency)
+
+END PROC real div ;
+
+
+
+
+PROC real div s (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 10000.0 ;
+ third real := 1.0001 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := second real / third real
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("REAL /", act result * msec factor (frequency) - for corr) ;
+
+END PROC real div s ;
+
+
+
+
+PROC real incr (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real INCR second real
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real incr s (frequency)
+
+END PROC real incr ;
+
+
+
+
+PROC real incr s (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real INCR second real
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("INCR", act result * msec factor (frequency) - for corr) ;
+
+END PROC real incr s ;
+
+
+
+
+PROC real mod (INT CONST frequency) :
+
+ first real := 9999.9 ;
+ second real := 21.21 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ rest := first real MOD second real
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real mod s (frequency)
+
+END PROC real mod ;
+
+
+
+
+PROC real mod s (INT CONST frequency) :
+
+ first real := 9999.9 ;
+ second real := 21.21 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ rest := first real MOD second real
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("MOD", act result * msec factor (frequency) - for corr) ;
+
+END PROC real mod s ;
+
+
+
+
+PROC real abs (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := - 12345.6 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := abs (second real)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real abs s (frequency)
+
+END PROC real abs ;
+
+
+
+
+PROC real abs s (INT CONST frequency) :
+
+ first real := 0.0 ;
+ second real := - 12345.6 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first real := abs (second real)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("abs (REAL)", act result * msec factor (frequency) - for corr) ;
+
+END PROC real abs s ;
+
+
+
+
+PROC real min (INT CONST frequency) :
+
+ first real := 10000.0 ;
+ second real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ rest := min (first real, second real)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ real min s (frequency)
+
+END PROC real min ;
+
+
+
+
+PROC real min s (INT CONST frequency) :
+
+ first real := 10000.0 ;
+ second real := 1.0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ rest := min (first real, second real)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("min (REAL, REAL)", act result * msec factor (frequency) - for corr) ;
+
+END PROC real min s ;
+
+
+END PACKET real operation ;
diff --git a/app/speedtest/1986/src/run down logic b/app/speedtest/1986/src/run down logic new file mode 100644 index 0000000..49f0f0f --- /dev/null +++ b/app/speedtest/1986/src/run down logic @@ -0,0 +1,429 @@ +PACKET run down logic DEFINES for loop,
+ msec factor,
+ for corr,
+ while loop,
+ until loop,
+ if,
+ select,
+ proc,
+ proc one param int,
+ proc two param int :
+
+
+(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+INT VAR first int,
+ second int,
+ index ;
+
+REAL VAR for loop corr,
+ begin,
+ end,
+ int incr corr,
+ act result ;
+
+BOOL VAR is initialized :: FALSE,
+ situation :: TRUE ;
+
+
+
+PROC for loop (INT CONST frequency) :
+
+ notice operation ("FOR LOOP") ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ for loop s (frequency)
+
+END PROC for loop ;
+
+
+
+PROC for loop s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ for loop corr := act result * msec factor (frequency) ;
+
+ notice result ("FOR REP",for loop corr)
+
+END PROC for loop s ;
+
+
+
+PROC initialize int incr corr (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int INCR second int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ initialize int incr corr s (frequency)
+
+END PROC initialize int incr corr ;
+
+
+
+PROC initialize int incr corr s (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ first int INCR second int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ int incr corr := act result * msec factor (frequency) - for corr ;
+
+END PROC initialize int incr corr s ;
+
+
+
+PROC while loop (INT CONST frequency) :
+
+ IF NOT is initialized
+ THEN initialize int incr corr (frequency)
+ FI ;
+
+ notice operation ("WHILE LOOP") ;
+ first int := 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ WHILE first int < frequency
+ REP
+ first int INCR second int
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ while loop s (frequency)
+
+END PROC while loop ;
+
+
+
+PROC while loop s (INT CONST frequency) :
+
+ first int := 0 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ WHILE first int < frequency
+ REP
+ first int INCR second int
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("WHILE REP", act result * msec factor (frequency) - int incr corr) ;
+
+END PROC while loop s ;
+
+
+
+PROC until loop (INT CONST frequency) :
+
+ IF NOT is initialized
+ THEN initialize int incr corr (frequency)
+ FI ;
+
+ notice operation ("UNTIL LOOP") ;
+ first int := 1 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ REP
+ first int INCR second int
+ UNTIL first int > frequency
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ until loop s (frequency)
+
+END PROC until loop ;
+
+
+
+PROC until loop s (INT CONST frequency) :
+
+ first int := 1 ;
+ second int := 1 ;
+ begin := clock (0) ;
+ REP
+ first int INCR second int
+ UNTIL first int > frequency
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > act result
+ THEN act result := end - begin
+ FI ;
+
+ notice result("UNTIL REP", act result * msec factor (frequency) - int incr corr)
+
+END PROC until loop s ;
+
+
+
+PROC if (INT CONST frequency) :
+
+ notice operation ("IF") ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF situation
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ if s (frequency)
+
+END PROC if ;
+
+
+
+PROC if s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF situation
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("IF", act result * msec factor (frequency) - for corr) ;
+
+END PROC if s ;
+
+
+
+PROC select (INT CONST frequency) :
+
+ notice operation ("SELECT") ;
+ first int := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ SELECT first int OF
+ CASE 0 :
+ OTHERWISE
+ END SELECT
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ select s (frequency)
+
+END PROC select ;
+
+
+
+PROC select s (INT CONST frequency) :
+
+ first int := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ SELECT first int OF
+ CASE 0 :
+ OTHERWISE
+ END SELECT
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("SELECT", act result * msec factor (frequency) - for corr) ;
+
+END PROC select s ;
+
+
+
+PROC proc (INT CONST frequency) :
+
+ notice operation ("PROC") ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ nilproc
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ proc s (frequency)
+
+END PROC proc ;
+
+
+
+PROC proc s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ nilproc
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("PROC", act result * msec factor (frequency) - for corr) ;
+
+END PROC proc s ;
+
+
+
+PROC proc one param int (INT CONST frequency) :
+
+ notice operation ("PROC one param INT") ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ nilproc (first int)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ proc one param int s (frequency)
+
+END PROC proc one param int ;
+
+
+
+PROC proc one param int s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ nilproc (first int)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("PROC (INT)", act result * msec factor (frequency) - for corr) ;
+
+END PROC proc one param int s ;
+
+
+
+PROC proc two param int (INT CONST frequency) :
+
+ notice operation ("PROC two param INT") ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ nilproc (first int, second int)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ proc two param int s (frequency)
+
+END PROC proc two param int ;
+
+
+
+PROC proc two param int s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ nilproc (first int, second int)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("PROC (INT, INT)", act result * msec factor (frequency) - for corr) ;
+
+END PROC proc two param int s ;
+
+
+
+PROC nilproc :
+END PROC nilproc ;
+
+
+
+PROC nilproc (INT CONST number one) :
+END PROC nilproc ;
+
+
+
+PROC nilproc (INT CONST number one, number two) :
+END PROC nilproc ;
+
+
+
+REAL PROC for corr :
+
+ for loop corr
+
+END PROC for corr ;
+
+
+
+REAL PROC msec factor (INT CONST frequency) :
+
+ 1000.0 / real (frequency)
+
+END PROC msec factor ;
+
+
+END PACKET run down logic ;
diff --git a/app/speedtest/1986/src/speed tester b/app/speedtest/1986/src/speed tester new file mode 100644 index 0000000..37f937f --- /dev/null +++ b/app/speedtest/1986/src/speed tester @@ -0,0 +1,209 @@ +PACKET speed tester DEFINES test speed :
+
+
+(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+PROC test speed :
+
+ INT VAR frequency 1,
+ frequency 2 ;
+
+ TEXT VAR name of material,
+ name of the heart of material,
+ high,
+ low ;
+
+ REAL VAR begin,
+ end ;
+
+
+ page ;
+ cursor (1,3) ;
+ out (""15""+" EUMEL SPEED TESTER "+" "+" EUMEL SPEED TESTER "+" "+" EUMEL SPEED TESTER "+""14"") ;
+ cursor (1,6) ;
+ put ("Bitte gib Name/Typbezeichnung des Test-PC ein") ;
+ line ;
+ getline (name of material) ;
+ line ;
+ put ("Bitte gib Prozessortyp/Taktfrequenz ein") ;
+ line ;
+ getline (name of the heart of material) ;
+ line ;
+ name of material CAT " " ;
+
+ output mem ;
+ notice material (name of material + name of the heart of material) ;
+
+ REP
+ output mem ;
+ putline ("Bitte gib Genauigkeitsfaktor fuer schnelle Operationen ein") ;
+ put ("Voreingestellt ist maxint --> ") ;
+ getline (high) ;
+ line ;
+ IF high = ""
+ THEN frequency 1 := 32766
+ ELSE frequency 1 := int (high)
+ FI ;
+ putline ("Bitte gib Genauigkeitsfaktor fuer langsame Operationen ein") ;
+ put ("Voreingestellt ist maxint Div 2 --> ") ;
+ getline (low) ;
+ IF low = ""
+ THEN frequency 2 := maxint DIV 2
+ ELSE frequency 2 := int (low)
+ FI ;
+ notice frequency (frequency 1, frequency 2) ;
+
+ begin := clock (0) ;
+
+
+ test run down logic ;
+ test integer operation ;
+ test real operation ;
+ test text operation ;
+ test convert ;
+
+ end := clock (0) ;
+ page ;
+ put ("Gesamtlaufzeit : ") ;
+ put (time (end-begin)) ;
+ line (2) ;
+ put ("Taste drcken oder warten") ;
+ pause (600) ;
+
+
+ page ;
+ cursor (1,5) ;
+ out (""5""13"") ;
+ IF yes ("Ergebnis anschauen")
+ THEN edit ("memory") ;
+ page
+ FI ;
+
+ cursor (1,5) ;
+ out (""5""13"") ;
+ IF yes ("Ergebnis loeschen")
+ THEN forget ("memory",quiet)
+ FI ;
+
+ cursor (1,5) ;
+ out (""5""13"")
+ UNTIL no ("Neuer test")
+ END REP .
+
+
+test run down logic :
+
+notice heading ("Steuerkonstrukte") ;
+
+for loop (frequency 1) ;
+while loop (frequency 1) ;
+until loop (frequency 1) ;
+if (frequency 1) ;
+select (frequency 1) ;
+proc (frequency 1) ;
+proc one param int (frequency 1) ;
+proc two param int (frequency 1) .
+
+
+
+test integer operation :
+
+notice heading ("Integer Operationen") ;
+
+int assign global (frequency 1) ;
+int assign local (frequency 1) ;
+int assign param (frequency 1) ;
+row int (frequency 1) ;
+int equal (frequency 1) ;
+int lequal (frequency 1) ;
+int add (frequency 1) ;
+int mult (frequency 1) ;
+int div (frequency 1) ;
+int incr (frequency 1) ;
+int mod (frequency 1) ;
+int abs (frequency 1) ;
+int min (frequency 1) .
+
+
+
+test real operation :
+
+notice heading ("Real Operationen") ;
+
+real assign (frequency 1) ;
+row real (frequency 1) ;
+real equal (frequency 1) ;
+real lequal (frequency 1) ;
+real add (frequency 1) ;
+real mult (frequency 2) ;
+real div (frequency 2) ;
+real incr (frequency 1) ;
+real mod (frequency 2) ;
+real abs (frequency 1) ;
+real min (frequency 1) .
+
+
+
+test text operation :
+
+notice heading ("Text Operationen") ;
+
+text assign 1 (frequency 1) ;
+text assign 10 (frequency 1) ;
+text assign 30 (frequency 1) ;
+row text (frequency 1) ;
+text equal 1 (frequency 1) ;
+text equal 10 (frequency 1) ;
+text equal 30 (frequency 1) ;
+text lequal 1 (frequency 1) ;
+text lequal 10 (frequency 1) ;
+text lequal 30 (frequency 1) ;
+text mult (frequency 1) ;
+cat (frequency 1) ;
+text add 1 (frequency 1) ;
+text add 10 (frequency 2) ;
+text add 30 (frequency 2) ;
+text length 1 (frequency 1) ;
+text length 10 (frequency 1) ;
+text length 30 (frequency 1) ;
+text sub 1 (frequency 1) ;
+text sub 10 (frequency 1) ;
+text sub 30 (frequency 1) ;
+subtext 1 (frequency 1) ;
+subtext 10 (frequency 1) ;
+subtext 30 (frequency 1) ;
+replace 1 (frequency 1) ;
+replace 10 (frequency 1) ;
+replace 30 ( frequency 1) ;
+text 1 (frequency 2) ;
+text 10 (frequency 2) ;
+text 30 (frequency 2) ;
+pos 1 (frequency 1) ;
+pos 10 (frequency 1) ;
+pos 30 (frequency 1) .
+
+
+
+test convert :
+
+notice heading ("Konvertierungs Operationen") ;
+
+real to int (frequency 1) ;
+int to real (frequency 1) ;
+text to int (frequency 2) ;
+int to text (frequency 1) ;
+int to text 2 (frequency 2) ;
+real to text (frequency 2) ;
+real to text 2 (frequency 2) ;
+code int (frequency 1) ;
+code text (frequency 1) ;
+
+
+END PROC test speed ;
+
+END PACKET speed tester
diff --git a/app/speedtest/1986/src/text operation b/app/speedtest/1986/src/text operation new file mode 100644 index 0000000..30ad2ba --- /dev/null +++ b/app/speedtest/1986/src/text operation @@ -0,0 +1,1401 @@ +PACKET text operation DEFINES text assign 1,
+ text assign 10,
+ text assign 30,
+ row text,
+ text mult,
+ cat,
+ text equal 1,
+ text equal 10,
+ text equal 30,
+ text lequal 1,
+ text lequal 10,
+ text lequal 30,
+ text add 1,
+ text add 10,
+ text add 30,
+ text length 1,
+ text length 10,
+ text length 30,
+ text sub 1,
+ text sub 10,
+ text sub 30,
+ subtext 1,
+ subtext 10,
+ subtext 30,
+ replace 1,
+ replace 10,
+ replace 30,
+ text 1,
+ text 10,
+ text 30,
+ pos 1,
+ pos 10,
+ pos 30 :
+
+
+(***************************************************************************)
+(* *)
+(* Autor: A. Steinmann Copyright (C): HRZ - Unibi *)
+(* *)
+(***************************************************************************)
+
+
+ROW 10 TEXT VAR text row ;
+
+INT VAR index,
+ i,
+ j ;
+
+REAL VAR begin,
+ end,
+ act result,
+ text assign factor ;
+
+TEXT VAR single text :: "*",
+ short text :: "ELAN/EUMEL",
+ long text :: "Ein Multi User Betriebssystem!",
+ free text ;
+
+
+
+
+PROC text assign 1 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := single text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text assign 1 s (frequency)
+
+END PROC text assign 1 ;
+
+
+
+
+PROC text assign 1 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := single text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ text assign factor := act result * msec factor (frequency) - for corr ;
+
+ notice result ("TEXT := (1)", text assign factor)
+
+END PROC text assign 1 s ;
+
+
+
+
+PROC text assign 10 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := short text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text assign 10 s (frequency)
+
+END PROC text assign 10 ;
+
+
+
+
+PROC text assign 10 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := short text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT := (10)", act result * msec factor (frequency) - for corr)
+
+END PROC text assign 10 s ;
+
+
+
+
+PROC text assign 30 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := long text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text assign 30 s (frequency)
+
+END PROC text assign 30 ;
+
+
+
+
+PROC text assign 30 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := long text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT := (30)", act result * msec factor (frequency) - for corr)
+
+END PROC text assign 30 s ;
+
+
+
+
+PROC row text (INT CONST frequency) :
+
+ i := 7 ;
+ text row [i] := "" ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ text row [i] := single text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ row text s (frequency)
+
+END PROC row text ;
+
+
+
+
+PROC row text s (INT CONST frequency) :
+
+ i := 7 ;
+ text row [i] := "" ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ text row [i] := single text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("ROW TEXT [i]", act result * msec factor (frequency) - for corr)
+
+END PROC row text s ;
+
+
+
+
+PROC text equal 1 (INT CONST frequency) :
+
+ free text := single text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text = single text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text equal 1 s (frequency)
+
+END PROC text equal 1 ;
+
+
+
+
+PROC text equal 1 s (INT CONST frequency) :
+
+ free text := single text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text = single text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT = (1)", act result * msec factor (frequency) - for corr)
+
+END PROC text equal 1 s ;
+
+
+
+
+PROC text equal 10 (INT CONST frequency) :
+
+ free text := short text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text = short text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text equal 10 s (frequency)
+
+END PROC text equal 10 ;
+
+
+
+
+PROC text equal 10 s (INT CONST frequency) :
+
+ free text := short text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text = short text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT = (10)", act result * msec factor (frequency) - for corr)
+
+END PROC text equal 10 s ;
+
+
+
+
+PROC text equal 30 (INT CONST frequency) :
+
+ free text := long text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text = long text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text equal 30 s (frequency)
+
+END PROC text equal 30 ;
+
+
+
+
+PROC text equal 30 s (INT CONST frequency) :
+
+ free text := long text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text = long text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT = (30)", act result * msec factor (frequency) - for corr)
+
+END PROC text equal 30 s ;
+
+
+
+
+PROC text lequal 1 (INT CONST frequency) :
+
+ free text := single text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text <= single text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text lequal 1 s (frequency)
+
+END PROC text lequal 1 ;
+
+
+
+
+PROC text lequal 1 s (INT CONST frequency) :
+
+ free text := single text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text <= single text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT <= (1)", act result * msec factor (frequency) - for corr)
+
+END PROC text lequal 1 s ;
+
+
+
+
+PROC text lequal 10 (INT CONST frequency) :
+
+ free text := short text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text <= short text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text lequal 10 s (frequency)
+
+END PROC text lequal 10 ;
+
+
+
+
+PROC text lequal 10 s (INT CONST frequency) :
+
+ free text := short text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text <= short text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT <= (10)", act result * msec factor (frequency) - for corr)
+
+END PROC text lequal 10 s ;
+
+
+
+
+PROC text lequal 30 (INT CONST frequency) :
+
+ free text := long text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text <= long text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text lequal 30 s (frequency)
+
+END PROC text lequal 30 ;
+
+
+
+
+PROC text lequal 30 s (INT CONST frequency) :
+
+ free text := long text ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ IF free text <= long text
+ THEN
+ FI
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT <= (30)", act result * msec factor (frequency) - for corr)
+
+END PROC text lequal 30 s ;
+
+
+
+
+PROC text mult (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := i * single text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text mult s (frequency)
+
+END PROC text mult ;
+
+
+
+
+PROC text mult s (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := i * single text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT * (Faktor 1)", act result * msec factor (frequency) - for corr)
+
+END PROC text mult s ;
+
+
+
+
+PROC cat (INT CONST frequency) :
+
+ free text := "" ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text CAT single text ;
+ free text := ""
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ cat s (frequency)
+
+END PROC cat ;
+
+
+
+
+PROC cat s (INT CONST frequency) :
+
+ free text := "" ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text CAT single text ;
+ free text := ""
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("CAT (1)", act result * msec factor (frequency) - for corr)
+
+END PROC cat s ;
+
+
+
+
+PROC text add 1 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := single text + single text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text add 1 s (frequency)
+
+END PROC text add 1 ;
+
+
+
+
+PROC text add 1 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := single text + single text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT + (1)", act result * msec factor (frequency) - for corr)
+
+END PROC text add 1 s ;
+
+
+
+PROC text add 10 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := short text + short text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text add 10 s (frequency)
+
+END PROC text add 10 ;
+
+
+
+
+PROC text add 10 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := short text + short text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT + (10)", act result * msec factor (frequency) - for corr)
+
+END PROC text add 10 s ;
+
+
+
+
+PROC text add 30 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := long text + long text
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text add 30 s (frequency)
+
+END PROC text add 30 ;
+
+
+
+
+PROC text add 30 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := long text + long text
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("TEXT + (30)", act result * msec factor (frequency) - for corr)
+
+END PROC text add 30 s ;
+
+
+
+
+PROC text length 1 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := length (single text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text length 1 s (frequency)
+
+END PROC text length 1 ;
+
+
+
+
+PROC text length 1 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := length (single text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("length (1)", act result * msec factor (frequency) - for corr)
+
+END PROC text length 1 s ;
+
+
+
+
+PROC text length 10 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := length (short text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text length 10 s (frequency)
+
+END PROC text length 10 ;
+
+
+
+
+PROC text length 10 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := length (short text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("length (10)", act result * msec factor (frequency) - for corr)
+
+END PROC text length 10 s ;
+
+
+
+
+PROC text length 30 (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := length (long text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text length 30 s (frequency)
+
+END PROC text length 30 ;
+
+
+
+
+PROC text length 30 s (INT CONST frequency) :
+
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ i := length (long text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("length (30)", act result * msec factor (frequency) - for corr)
+
+END PROC text length 30 s ;
+
+
+
+
+PROC text sub 1 (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := single text SUB i
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text sub 1 s (frequency)
+
+END PROC text sub 1 ;
+
+
+
+
+PROC text sub 1 s (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := single text SUB i
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("SUB (1)", act result * msec factor (frequency) - for corr)
+
+END PROC text sub 1 s ;
+
+
+
+
+PROC text sub 10 (INT CONST frequency) :
+
+ i := 7 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := short text SUB i
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text sub 10 s (frequency)
+
+END PROC text sub 10 ;
+
+
+
+
+PROC text sub 10 s (INT CONST frequency) :
+
+ i := 7 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := short text SUB i
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("SUB (10)", act result * msec factor (frequency) - for corr)
+
+END PROC text sub 10 s ;
+
+
+
+
+PROC text sub 30 (INT CONST frequency) :
+
+ i := 17 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := long text SUB i
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text sub 30 s (frequency)
+
+END PROC text sub 30 ;
+
+
+
+
+PROC text sub 30 s (INT CONST frequency) :
+
+ i := 17 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := long text SUB i
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("SUB (30)", act result * msec factor (frequency) - for corr)
+
+END PROC text sub 30 s ;
+
+
+
+
+PROC subtext 1 (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := subtext (single text , i, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ subtext 1 s (frequency)
+
+END PROC subtext 1 ;
+
+
+
+
+PROC subtext 1 s (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := subtext (single text , i, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("subtext (TEXT, INT, INT) (1)", act result * msec factor (frequency) - for corr)
+
+END PROC subtext 1 s ;
+
+
+
+
+PROC subtext 10 (INT CONST frequency) :
+
+ i := 7 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := subtext (short text , i, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ subtext 10 s (frequency)
+
+END PROC subtext 10 ;
+
+
+
+
+PROC subtext 10 s (INT CONST frequency) :
+
+ i := 7 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := subtext (short text , i, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("subtext (TEXT, INT, INT) (10)", act result * msec factor (frequency) - for corr)
+
+END PROC subtext 10 s ;
+
+
+
+
+PROC subtext 30 (INT CONST frequency) :
+
+ i := 17 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := subtext (long text , i, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ subtext 30 s (frequency)
+
+END PROC subtext 30 ;
+
+
+
+
+PROC subtext 30 s (INT CONST frequency) :
+
+ i := 17 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := subtext (long text , i, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("subtext (TEXT, INT, INT) (30)", act result * msec factor (frequency) - for corr)
+
+END PROC subtext 30 s ;
+
+
+
+
+PROC replace 1 (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ replace (single text, i, single text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ replace 1 s (frequency)
+
+END PROC replace 1 ;
+
+
+
+
+PROC replace 1 s (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ replace (single text, i, single text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("replace (TEXT, TEXT, INT) (1)", act result * msec factor (frequency) - for corr)
+
+END PROC replace 1 s ;
+
+
+
+
+PROC replace 10 (INT CONST frequency) :
+
+ i := 7 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ replace (short text, i, single text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ replace 10 s (frequency)
+
+END PROC replace 10 ;
+
+
+
+
+PROC replace 10 s (INT CONST frequency) :
+
+ i := 7 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ replace (short text, i, single text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("replace (TEXT, TEXT, INT) (10)", act result * msec factor (frequency) - for corr)
+
+END PROC replace 10 s ;
+
+
+
+
+PROC replace 30 (INT CONST frequency) :
+
+ i := 17 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ replace (long text, i, single text)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ replace 30 s (frequency)
+
+END PROC replace 30 ;
+
+
+
+
+PROC replace 30 s (INT CONST frequency) :
+
+ i := 17 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ replace (long text, i, single text)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("replace (TEXT, TEXT, INT) (30)", act result * msec factor (frequency) - for corr)
+
+END PROC replace 30 s ;
+
+
+
+
+PROC text 1 (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (single text, i, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text 1 s (frequency)
+
+END PROC text 1 ;
+
+
+
+
+PROC text 1 s (INT CONST frequency) :
+
+ i := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (single text, i, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("text (TEXT, INT, INT) (1)", act result * msec factor (frequency) - for corr)
+
+END PROC text 1 s ;
+
+
+
+
+PROC text 10 (INT CONST frequency) :
+
+ i := 7 ;
+ j := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (short text, j, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text 10 s (frequency)
+
+END PROC text 10 ;
+
+
+
+
+PROC text 10 s (INT CONST frequency) :
+
+ i := 7 ;
+ j := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (short text, j, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("text (TEXT, INT, INT) (10)", act result * msec factor (frequency) - for corr)
+
+END PROC text 10 s ;
+
+
+
+
+PROC text 30 (INT CONST frequency) :
+
+ i := 17 ;
+ j := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (long text, j, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ text 30 s (frequency)
+
+END PROC text 30 ;
+
+
+
+
+PROC text 30 s (INT CONST frequency) :
+
+ i := 17 ;
+ j := 1 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ free text := text (long text, j, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("text (TEXT, INT, INT) (30)", act result * msec factor (frequency) - for corr)
+
+END PROC text 30 s ;
+
+
+
+
+PROC pos 1 (INT CONST frequency) :
+
+ i := 1 ;
+ j := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ j := pos (single text, single text, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ pos 1 s (frequency)
+
+END PROC pos 1 ;
+
+
+
+
+PROC pos 1 s (INT CONST frequency) :
+
+ i := 1 ;
+ j := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ j := pos (single text, single text, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("pos (TEXT, TEXT, INT) (1)", act result * msec factor (frequency) - for corr)
+
+END PROC pos 1 s ;
+
+
+
+
+PROC pos 10 (INT CONST frequency) :
+
+ i := 1 ;
+ j := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ j := pos (short text, single text, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ pos 10 s (frequency)
+
+END PROC pos 10 ;
+
+
+
+
+PROC pos 10 s (INT CONST frequency) :
+
+ i := 1 ;
+ j := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ j := pos (short text, single text, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("pos (TEXT, TEXT, INT) (10)", act result * msec factor (frequency) - for corr)
+
+END PROC pos 10 s ;
+
+
+
+
+PROC pos 30 (INT CONST frequency) :
+
+ i := 1 ;
+ j := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ j := pos (long text, single text, i)
+ END REP ;
+ end := clock (0) ;
+
+ act result := end - begin ;
+
+ pos 30 s (frequency)
+
+END PROC pos 30 ;
+
+
+
+
+PROC pos 30 s (INT CONST frequency) :
+
+ i := 1 ;
+ j := 0 ;
+ begin := clock (0) ;
+ FOR index FROM 1 UPTO frequency
+ REP
+ j := pos (long text, single text, i)
+ END REP ;
+ end := clock (0) ;
+
+ IF act result > end - begin
+ THEN act result := end - begin
+ FI ;
+
+ notice result ("pos (TEXT, TEXT, INT) (30)", act result * msec factor (frequency) - for corr)
+
+END PROC pos 30 s ;
+
+
+END PACKET text operation ;
|