From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- app/misc-games/unknown/src/LINDWURM.ELA | 337 +++++ app/misc-games/unknown/src/SCHIFFEV.ELA | 424 ++++++ app/misc-games/unknown/src/SCHIFFEV2.ELA | 409 ++++++ app/mpg/1987/doc/GDOKKURZ.ELA | 119 ++ app/mpg/1987/doc/GRAPHIK.doc.e | 2234 ++++++++++++++++++++++++++++++ app/mpg/1987/doc/PLOTBOOK.ELA | 660 +++++++++ app/mpg/1987/src/ATPLOT.ELA | 438 ++++++ app/mpg/1987/src/B108PLOT.ELA | 642 +++++++++ app/mpg/1987/src/BASISPLT.ELA | 781 +++++++++++ app/mpg/1987/src/DIPCHIPS.DS | Bin 0 -> 9216 bytes app/mpg/1987/src/FUPLOT.ELA | 319 +++++ app/mpg/1987/src/GRAPHIK.Basis | 1573 +++++++++++++++++++++ app/mpg/1987/src/GRAPHIK.Configurator | 945 +++++++++++++ app/mpg/1987/src/GRAPHIK.Fkt | 1378 ++++++++++++++++++ app/mpg/1987/src/GRAPHIK.Install | 82 ++ app/mpg/1987/src/GRAPHIK.Manager | 900 ++++++++++++ app/mpg/1987/src/GRAPHIK.Plot | 1156 ++++++++++++++++ app/mpg/1987/src/GRAPHIK.Turtle | 138 ++ app/mpg/1987/src/GRAPHIK.list | 22 + app/mpg/1987/src/HRZPLOT.ELA | 150 ++ app/mpg/1987/src/INCRPLOT.ELA | 405 ++++++ app/mpg/1987/src/M20PLOT.ELA | 419 ++++++ app/mpg/1987/src/MTRXPLOT.ELA | 416 ++++++ app/mpg/1987/src/Muster | 73 + app/mpg/1987/src/NEC P-9 2-15.MD.GCONF | 219 +++ app/mpg/1987/src/PCPLOT.ELA | 276 ++++ app/mpg/1987/src/PICFILE.ELA | 446 ++++++ app/mpg/1987/src/PICPLOT.ELA | 241 ++++ app/mpg/1987/src/PICTURE.ELA | 521 +++++++ app/mpg/1987/src/PLOTSPOL.ELA | 129 ++ app/mpg/1987/src/PUBINSPK.ELA | 654 +++++++++ app/mpg/1987/src/RUCTEPLT.ELA | 326 +++++ app/mpg/1987/src/STDPLOT.ELA | 234 ++++ app/mpg/1987/src/TELEVPLT.ELA | 176 +++ app/mpg/1987/src/VIDEOPLO.ELA | 382 +++++ app/mpg/1987/src/ZEICH610.DS | Bin 0 -> 10752 bytes app/mpg/1987/src/ZEICH912.DS | Bin 0 -> 9216 bytes app/mpg/1987/src/ZEICHEN.DS | Bin 0 -> 9728 bytes app/mpg/1987/src/matrix printer | 129 ++ app/mpg/1987/src/std primitives | 79 ++ app/mpg/1987/src/terminal plot | 113 ++ app/speedtest/1986/doc/MEM64180.PRT | 103 ++ app/speedtest/1986/doc/MEMATARI.PRT | 101 ++ app/speedtest/1986/doc/MEMB108.PRT | 99 ++ app/speedtest/1986/doc/MEMB1082.PRT | 112 ++ app/speedtest/1986/doc/MEMBIC10.PRT | 100 ++ app/speedtest/1986/doc/MEMBIC8.PRT | 101 ++ app/speedtest/1986/doc/MEMCLA15.PRT | 100 ++ app/speedtest/1986/doc/MEMRUC12.PRT | 101 ++ app/speedtest/1986/doc/MEMV30.PRT | 100 ++ app/speedtest/1986/src/convert operation | 396 ++++++ app/speedtest/1986/src/gen.benchmark | 98 ++ app/speedtest/1986/src/integer operation | 614 ++++++++ app/speedtest/1986/src/notice | 102 ++ app/speedtest/1986/src/real operation | 519 +++++++ app/speedtest/1986/src/run down logic | 429 ++++++ app/speedtest/1986/src/speed tester | 209 +++ app/speedtest/1986/src/text operation | 1401 +++++++++++++++++++ 58 files changed, 22630 insertions(+) create mode 100644 app/misc-games/unknown/src/LINDWURM.ELA create mode 100644 app/misc-games/unknown/src/SCHIFFEV.ELA create mode 100644 app/misc-games/unknown/src/SCHIFFEV2.ELA create mode 100644 app/mpg/1987/doc/GDOKKURZ.ELA create mode 100644 app/mpg/1987/doc/GRAPHIK.doc.e create mode 100644 app/mpg/1987/doc/PLOTBOOK.ELA create mode 100644 app/mpg/1987/src/ATPLOT.ELA create mode 100644 app/mpg/1987/src/B108PLOT.ELA create mode 100644 app/mpg/1987/src/BASISPLT.ELA create mode 100644 app/mpg/1987/src/DIPCHIPS.DS create mode 100644 app/mpg/1987/src/FUPLOT.ELA create mode 100644 app/mpg/1987/src/GRAPHIK.Basis create mode 100644 app/mpg/1987/src/GRAPHIK.Configurator create mode 100644 app/mpg/1987/src/GRAPHIK.Fkt create mode 100644 app/mpg/1987/src/GRAPHIK.Install create mode 100644 app/mpg/1987/src/GRAPHIK.Manager create mode 100644 app/mpg/1987/src/GRAPHIK.Plot create mode 100644 app/mpg/1987/src/GRAPHIK.Turtle create mode 100644 app/mpg/1987/src/GRAPHIK.list create mode 100644 app/mpg/1987/src/HRZPLOT.ELA create mode 100644 app/mpg/1987/src/INCRPLOT.ELA create mode 100644 app/mpg/1987/src/M20PLOT.ELA create mode 100644 app/mpg/1987/src/MTRXPLOT.ELA create mode 100644 app/mpg/1987/src/Muster create mode 100644 app/mpg/1987/src/NEC P-9 2-15.MD.GCONF create mode 100644 app/mpg/1987/src/PCPLOT.ELA create mode 100644 app/mpg/1987/src/PICFILE.ELA create mode 100644 app/mpg/1987/src/PICPLOT.ELA create mode 100644 app/mpg/1987/src/PICTURE.ELA create mode 100644 app/mpg/1987/src/PLOTSPOL.ELA create mode 100644 app/mpg/1987/src/PUBINSPK.ELA create mode 100644 app/mpg/1987/src/RUCTEPLT.ELA create mode 100644 app/mpg/1987/src/STDPLOT.ELA create mode 100644 app/mpg/1987/src/TELEVPLT.ELA create mode 100644 app/mpg/1987/src/VIDEOPLO.ELA create mode 100644 app/mpg/1987/src/ZEICH610.DS create mode 100644 app/mpg/1987/src/ZEICH912.DS create mode 100644 app/mpg/1987/src/ZEICHEN.DS create mode 100644 app/mpg/1987/src/matrix printer create mode 100644 app/mpg/1987/src/std primitives create mode 100644 app/mpg/1987/src/terminal plot create mode 100644 app/speedtest/1986/doc/MEM64180.PRT create mode 100644 app/speedtest/1986/doc/MEMATARI.PRT create mode 100644 app/speedtest/1986/doc/MEMB108.PRT create mode 100644 app/speedtest/1986/doc/MEMB1082.PRT create mode 100644 app/speedtest/1986/doc/MEMBIC10.PRT create mode 100644 app/speedtest/1986/doc/MEMBIC8.PRT create mode 100644 app/speedtest/1986/doc/MEMCLA15.PRT create mode 100644 app/speedtest/1986/doc/MEMRUC12.PRT create mode 100644 app/speedtest/1986/doc/MEMV30.PRT create mode 100644 app/speedtest/1986/src/convert operation create mode 100644 app/speedtest/1986/src/gen.benchmark create mode 100644 app/speedtest/1986/src/integer operation create mode 100644 app/speedtest/1986/src/notice create mode 100644 app/speedtest/1986/src/real operation create mode 100644 app/speedtest/1986/src/run down logic create mode 100644 app/speedtest/1986/src/speed tester create mode 100644 app/speedtest/1986/src/text operation (limited to 'app') 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 t”dlich."); + 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 ("l„nger. 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 ."); + 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 ) 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 L„ngen, 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 w„hrend des Spiels die Position an der "); + cursor(15,8); + putline("ein gegnerisches Schiff vermutet wird. Ein Signal ert”nt,"); + 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 ."); + 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 ) 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 vollst„ndig integriert + ist. + + Folgende Leistungsmerkmale zeichnen die MPG-Graphik aus: + - verbesserter und nun auch in der Paket-Hierarchie voll- + st„ndig Endger„tunabh„ngiger EUMEL-Graphik-Kern. + - umfassende Dokumentation der EUMEL-Graphik und des + MPG-Graphik-Systems. + - taskunabh„ngige und mehrbenutzerf„hige Ansteuerung der + Endger„te. + - normierte Ansteuerung der Endger„te auf unterster + Ebene. + - indirekte Graphik-Ausgabe. + - komfortable Steuerung der Graphik-Ausgabe. + - Vollst„ndige 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 Zeichens„tze in beliebiger + Gr”áe und Rotation. + - schnelles Clipping an den Kanten der Zeichenfl„che. + + Desweiteren: + - frei definierbare Farben in normierter RGB-Codierung. + - automatische Einstellung der EUMEL-Farben auf den + Endger„ten (abschaltbar). + - Automatische Pause nach Abschluá der Ausgabe + (abschaltbar, also auch unterbrechungslose Ausgabe + m”glich). + - šbereinanderzeichnen mehrerer Zeichnungen m”glich. + - leichte Anpassung und Integration neuer Endger„te bzw. + Endger„t-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) k”nnen 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 Endger„t-unabh„ngig m”glich ist. + +#type ("prop7.5-16")# +#on ("u")#Zum Graphik-Tasksystem:#off ("u")# +#type ("prop10-12")# + - Jede Task im 'GRAPHIK'-Zweig kann auf jedes Endger„t + direkt zugreifen, und aufgrund der normierten An- + steuerung der Endger„te k”nnen auch die (schnelleren) + Zeichnungs-Primitiva (Gerade ziehen, positionieren usw.) + bei Beachtung der Aufl”sung endger„tunabh„ngig + verwendet werden. + + - Die indirekte Ausgabe von PICFILEs ist ber die Task + 'PLOT' m”glich, dabei kann ber das Netz auch auf + Endger„te anderer Stationen zugegriffen werden. + +#type ("prop7.5-16")# +#on ("u")#Zur Ansteuerung der Endger„te:#off ("u")# +#type ("prop10-12")# + Vor der Ausgabe ist mit 'select plotter' das Endger„t + einzustellen, auf das ausgegeben werden soll. + Die vom Graphik-System verwendeten Konstanten + ('drawing area' usw.) beziehen sich nunmehr auf das + eingestellte Endger„t. + Bei Verwendung der Zeichnungs-Primitiva ist zu beachten, + das diese nur am Endger„t-Kanal sinnvoll sind (die šber- + einstimmung von Endger„t- und Task-Kanal wird aus Zeit- + grnden jedoch nicht berprft). + Die Ausgabe von PICFILEs erfolgt automatisch richtig, d.h. + am Endger„t-Kanal direkt, ansonsten indirekt ber die + 'PLOT', die zur Ausgabe dynamische Kanal-Server erzeugt. + +#type ("prop7.5-16")# +#on ("u")#Zur Mehrbenutzerf„higkeit:#off ("u")# +#type ("prop10-12")# + Da die Task 'PLOT' fr alle Endger„te auch als Spooler + arbeitet, k”nnen Graphiken als PICFILEs von beliebig vielen + Benutzern von jeder Task im Graphik-Zweig aus erstellt + und ausgegeben werden (Soweit der Endger„t-Kanal nicht + direkt genutzt wird), 'PLOT' sorgt dann fr die sequentielle + Ausgabe auf dem jeweils zugeordneten Endger„t. 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 Endger„t- + unabh„ngigen 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 Endger„ten beschreibt. + + 1.4 #ib(2," (1.4)")#PACKET devices#ie(2,"")# + - Allgemeine Verwaltung der verschiedenen Endger„te. + + + #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 Endger„t- + 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 ben”tigten + Basisoperationen. + + 3.2 #ib(2," (3.2)")#PACKET plotinterface#ie(2,"")# + - Paket zur Ansteuerung und Kontrolle der Endger„te. + + 3.3 #ib(2," (3.3)")#PACKET plot#ie(2,"")# + - Ausgabeprozeduren fr PICTURES bzw. PICFILES fr alle Endger„te. +#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 zun„chst 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' enth„lt 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 Endger„te neu- + konfiguriert('GRAPHIK.Configuration' also in Abh„ngigkeit von den ebenfalls + auf der Diskette vorhandenen Endger„t-Konfigurationsdateien neu erstellt + werden soll). Fehlt 'GRAPHIK.Configuration', so wird es zwangsl„ufig 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")#). Zus„tzlich kann sie den Plot- + manager in der Task 'PLOT' kontrollieren + + #ib(1)#2.0 Task: 'PLOT'#ie(1)##goalpage("plotmanager")# + + 'PLOT' enth„lt den Multispool-Manager des Graphik-Systems, der die indirekte + Ausgabe von PICFILES auf jedem Endger„t der Station erm”glicht. 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 Datenr„ume, also Eintr„ge 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 Aktivit„ten aller bzw. des + gew„hlten Spools. + + - 2.2 #ib(2," (2.2)")#clearspool#ie(2,"")# + Initialisiert nach Rckfrage alle bzw. den gew„hlten Spool; + s„mtliche Eintr„ge werden gel”scht, 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 S”hne + 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 Eintr„gen aller bzw. des gew„hlten 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 gew„hlten bzw. aller Spools wieder auf. + + - 2.6 #ib(2," (2.6)")#halt#ie(2,"")# + Unterbindet die weitere Ausgabe von Eintr„gen aller bzw. des + gew„hlten Spools; evtl. laufende Ausgaben werden jedoch nicht + abgebrochen. + + - 2.7 #ib(2," (2.7)")#select plotter#ie(2,"")# + Bietet als Auswahl die Endger„te der Station an; die obenge- + nannten Operationen wirken danach nur auf den gew„hlten Spool, + was durch die Žnderung des Prompts auf den Namen des gew„hlten + Endger„tes angezeigt wird. + Der Abbruch der Auswahloperation fhrt dementsprechend wieder + zur Einstellung 'All-Plotter'. + Das aktuell zu kontrollierende Endger„t kann jedoch auch mit + den Standard-Auswahloperationen gew„hlt werden; diese lassen + aber auch die Wahl von Plottern anderer Stationen zu, was im + Plotmanager als 'All-Plotter' gewertet wird. + + Folgende Funktionen k”nnen 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 Eintr„ge zum L”schen + an. + + - 2.9 #ib(2," (2.9)")#first#ie(2,"")# + Bietet im Dialog alle dem ersten Eintrag nachfolgenden Eintr„ge + 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 gel”scht. + 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 Endger„t-Zeichenfl„che unter + Bercksichtigung des eingestellten Teils der Zeichenfl„che ('viewport') + und des Fensters ('window'). + - Bereitstellung des Datentyps PICTURE, der die gemeinsame Manipulation + von Objekten erm”glicht. + - Bereitstellung des Datentyps PICFILE, der die gemeinsame Manipulation + von PICTURES hinsichtlich ihrer Ausgabe erm”glicht. + - Bereitstellung des Datentyps PLOTTER, der die freie Auswahl von End- + ger„ten erm”glicht, 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 Endger„t-Zeichenfl„che begrenzt. + Es wird zurckgeliefert, ob Teile der bergebenen Geraden inner- + halb der Zeichenfl„che 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) + - Tr„gt in die bergebenen Variablen die Ausmaáe der aktuellen + Endger„t-Zeichenfl„che 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 eintr„gt. + + 1.4 BOOL PROC #ib(2," (1.4)")#newvalues#ie(2," (PROC)")# + - Intern verwendete Prozedur, die anzeigt, ob die Transformations- + matrix ver„ndert 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 Endger„t-Zeichenfl„che + 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 zus„tzlich 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 Zeichenfl„che 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 Endger„t-Zeichenfl„che in + Welt- oder Ger„tekoordinaten, 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 Zeichenfl„che in cm. + 'hor max;vert max' - Position der oberen rechten Ecke der ver- + wendeten Zeichenfl„che in cm. + + 2. Angabe in Ger„tekoordinaten: + Es wird eine Angabe in Ger„tekoordinaten angenommen, wenn + hor max < 2.0 und vert max < 2.0 gilt. + Die Werte werden als Bruchteile der Gr”áe der gesamten Zei- + chenfl„che aufgefaát, wobei fr die horizontalen Werte zu- + s„tzlich das Verh„ltnis 'Horizontale/Vertikale' (i.d. Regel > 1) + bercksichtigt wird. + Das bedeutet fr 'vert max' = 'hor max' = 1, + daá der obere Rand der spezifizierten Zeichenfl„che an der + Oberkante der Gesamt-Zeichenfl„che, und der rechte Rand an + der rechten Kante des durch die Gesamth”he der Zeichenfl„che + gegebenen Quadrates liegt (unverzerrt). + Soll die gesamte Zeichenfl„che genutzt werden, so ist 'hor min' + = 'vert min' = 0 und 'vert max' = 1 zu setzen; + 'hor max' dagegen auf das Verh„ltnis 'Horizontale/Vertikale' !. + Die halbe horizontale Verwendung der Zeichenfl„che ist durch + Halbierung des Seitenverh„ltnisses 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 Zeichenfl„che, 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 n„chsten 'set values'; die immer dann + notwendig wird, wenn die Zeichenfl„che oder das mit 'viewport' + eingestellte virtuelle Fenster ver„ndert 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 Dimensionalit„t + (2 - zweidimensional; 3 - dreidimensional); wobei die Dimensionali- + t„t 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 L„nge '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) + - Tr„gt in die bergebenen Variablen die gr”ssten 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 L„nge des Objekt-Verwaltungstextes von 'pic'. + + 2.18 PROC #ib(2," (2.18)")#move *#ie(2," (PROC)")# + (PICTURE VAR pic, REAL CONST x, y, z) + - F„hrt 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: Dimension : 2- oder 3-D + Zeichenstift-Nummer + <...> Objekteintr„ge + + Die Objekteintr„ge haben folgendes Format: + Objektcode <...> Parameter. + + Objektcodes fr: > Die Parameter entsprechen der + - draw 1 Parameterfolge der Prozeduren. + - move 2 + - text 3 > Vor dem Text wird als die + - move r 4 Textl„nge 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 -> zus„tzlich 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) + - Tr„gt 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) + - L”scht 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) + - Tr„gt 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) + - Tr„gt 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) + - Tr„gt 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) + - Tr„gt 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 Fl„chen + nicht gezeichnet werden, die Fl„chen sie also 'verdecken'. + Vordefiniert sind: + - color: + <0 - nicht standardisierte XOR-Modi + 0 - L”schstift + 1 - Standardfarbe d. Endger„tes (s/w) + 2 - rot + 3 - blau + 4 - grn + 5 - schwarz + 6 - weiss + n - Sonderfarben + - thickness: + 0 - Standardstrichst„rke d. Endger„tes + n - Strichst„rke in 1/10 mm + - linetype: + 0 - keine Linie + 1 - durchg„ngige Linie + 2 - gepunktete Linie + 3 - kurz gesrichelte Linie + 4 - lang gestrichelte Linie + 5 - Strichpunktlinie + (Standard-Definitionen, die Linetypes k”nnen + ber 'basisplot' auch ver„ndert 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' zus„tzlich 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 Zeichenfl„che 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 Zeichenfl„che, 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 Zeichenfl„che 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 Repr„sentation eines Endger„tes hinsichtlich + seiner Station, seines Kanals, seines Namens sowie seiner Zeichen- + fl„che. Dabei ist zu beachten, daá der gltige Endger„t- + 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- + ger„tes (Kein Endger„t 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) + - Tr„gt in die bergebenen Variablen die Maáe der + Zeichenfl„che des eingestellten Endger„tes 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) + - Tr„gt in die bergebenen Variablen die Maáe der Zeichenfl„che + 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- + ger„te. Wird intern vom 'device interface' verwendet, kann aber + auch im nachhinein zur Installation von Endger„ten anderer + Stationen oder zum Ausblenden von Endger„ten dienen. Nachdem + die Graphik installiert wurde, k”nnen jedoch keine neuen sta- + tionseigenen Endger„te 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 Endger„t-Descriptor 'kein Plotter'. + + 4.11 PLOTTER PROC #ib(2," (4.11)")#plotter#ie(2," (PROC)")# + - Liefert den Endger„t-Descriptor des eingestellten Endger„tes. + + 4.12 PLOTTER PROC #ib(2," (4.12)")#plotter#ie(2," (PROC)")# + (TEXT CONST descriptor) + - Liefert den Endger„t-Descriptor des durch 'descriptor' beschrie- + benen Endger„tes. + 'descriptor' hat folgendes Format: + //Endger„tname, + wobei nicht vorhandene Endger„te abgelehnt werden. + + 4.13 TEXT PROC #ib(2," (4.13)")#plotterinfo#ie(2," (PROC)")# + (TEXT CONST descriptor, INT CONST length) + - Liefert einen auf die L„nge '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 Endger„te in Form o.g. Descriptoren. + + 4.15 PROC #ib(2," (4.15)")#select plotter#ie(2," (PROC)")# + (PLOTTER CONST plotter) + - Stellt 'plotter' als aktuelles Endger„t ein. + + 4.16 PROC #ib(2," (4.16)")#select plotter#ie(2," (PROC)")# + (TEXT CONST descriptor) + - Stellt das durch 'descriptor' beschriebene Endger„t als aktuelles + Endger„t ein. + + 4.17 PROC #ib(2," (4.17)")#select plotter#ie(2," (PROC)")# + - Bietet eine Auswahl aller Endger„te an, und stellt das gew„hlte + als aktuelles Endger„t 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 Zeichenfl„che des Endger„ts abh„ngige Ansteuerung der verschiedenen + Endger„te. Es entspricht dabei dem Paket 'Endger„t.Basis' der EUMEL-Graphik, + geht aber teilweise ber dessen Leistungen hinaus.Hinweis: Falls diese Lei- + stung nicht bereits endger„tseitig 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- + tionsf„hig. + + #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' endger„tspezifisch 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 Zeichenfl„che des aktuellen Endger„tes, 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 m”glicher Farben fr das aktuelle Endger„t. + + 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 m”glich, 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.) endger„tspezifisch 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 Endger„t die Eingabe + einer Position mittels eines graphischen Cursors (i.d.R. + Fadenkreuz) erm”glichen. 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 zust„ndig, d.h der eingeschaltete Cursor ist + st„ndig 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 dazugeh”rigen Operationen auf dem aktuellen Endger„t 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 + Zeichenfl„che. + + 1.19 PROC #ib(2," (1.19)")#init plot#ie(2," (PROC)")# + - Initialisiert das aktuelle Endger„t zur graphischen Ausgabe, + (schaltet ggf. in den Graphik-Modus), wobei der Bildschirm jedoch + m”glichst nicht gel”scht 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 Endger„t 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 Endger„tes 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 Endger„t definierten Farben; + wobei die Farben jedoch nicht auf dem Endger„t 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 Zeichenfl„che. + - Kommunikations- und Kontrolloperationen auf die Task 'PLOT' zur + indirekten Ausgabe von PICFILES. + - Ausgabeoperationen auf den Datentyp PICTURE bzw. PICFILE unter Be- + rcksichtung des eingestellten Endger„tes. + 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- + ger„tspezifisch. + + #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 L„nge/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 Endger„t in seinen + Startzustand versetzt wird, und dem Transformationspaket die + Abmessungen der Zeichenfl„che mitgeteilt werden. + + 2.4 PROC #ib(2," (2.4)")#box *#ie(2," (PROC)")# + - Zeichnet eine Umrahmung der gesamten Zeichenfl„che (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 H”he/Breite 'height;width'. + + 2.11 PROC #ib(2," (2.11)")#draw *#ie(2," (PROC)")# + - s.o., jedoch in Standard-Ausrichtung (0 Grad) und + Standard-H”he/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 Fl„chen 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 Zeichenst„rke '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 gel”scht. + + 2.27 PROC #ib(2," (2.27)")#reset linetypes *#ie(2," (PROC)")# + - Setzt die Linientypen 1-6 auf Standard-Linientypen: 1 - durch- + g„ngige 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) + - Tr„gt 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) + - L„dt 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) + - L”scht nach Rckfrage das im Spool 'plotter' zur indirekten + Graphik-Ausgabe gespoolte task-eigene PICFILE 'picname'. + Bei Aufruf aus 'GRAPHIK' ist auch das L”schen fremder zur Ausgabe + gespoolter PICFILES m”glich. + + 3.3 PROC #ib(2," (3.3)")#erase#ie(2," (PROC)")# + (THESAURUS CONST piclist, PLOTTER CONST plotter) + - L”scht 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 L”schen fremder zur Ausgabe + gespoolter PICFILES m”glich. + + 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' zul„ssig. + + 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' zul„ssig. + + 3.8 PROC #ib(2," (3.8)")#list#ie(2," (PROC)")# + (FILE VAR list file, PLOTTER CONST plotter) + - Erzeugt in 'list file' eine Inhalts/Aktivit„tsbersicht des Spools + 'plotter'. + + 3.9 PROC #ib(2," (3.9)")#list#ie(2," (PROC)")# + (PLOTTER CONST plotter) + - Zeigt eine Inhalts/Aktivit„tsbersicht 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' zul„ssig. + + 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 vollst„ndiger 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 + Endger„ten. 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 endger„tspezifische 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 ben”tigt werden. Das Konfigurationsprogramm erkennt + diese Dateien an der Namensendung '.GCONF', und bietet diese zu + Programmbeginn zur Auswahl an. + Dann werden die gew„hlten Dateien inhaltlich untersucht und die relevan- + ten Informationen, Rmpfe der ben”tigten Prozeduren sowie alle vom Benut- + zer zus„tzlich eingetragenen globalen Objekte (globale Variablen, + LET-Objekte, zus„tzlich ben”tigte 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 ben”tigten Konfigurationsdateien sind relativ einfach zu erstellen, da + sich der Programmierer ausschlieálich mit der Realisation der geforderten + Leistungen auf einem Endger„t-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: ".GCONF" + Konfigurationsdateien zur Anbindung eines Endger„t-Types auf der + eigenen Station enthalten die ben”tigten 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 vollst„ndig festgelegt ist. + Daher ist es unzul„ssig, 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 + zus„tzlichen Prozeduren bzw. das Fehlen zus„tzlich ben”tigter 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 zus„tzlichen Paketes vergessen + wurde.) + Zudem ist zu beachten, daá die ben”tigten Prozedurrmpfe vom Kon- + figurationsprogramm in Refinements umgewandelt werden, und zus„tz- + 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. + (Zweckm„ssig: ... VAR endger„tname variablenname) + - Zus„tzliche Prozeduren und LET-Objekte ebenso eindeutig benannt + werden mssen. + - šberflssige Delimiter, die aber vom ELAN-Compiler nicht bem„ngelt + 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-Endger„ten) + - Prozedur-K”pfe bzw. -Enden allein in einer Zeile und an ihrem Anfang + stehen mssen. + + Namensgebung: "ENVIRONMENT.GCONF" + Dient zur verwaltungsseitigen Einbindung von Endger„ten anderer + Stationen, da fr diese Endger„te nur die Verwaltungsinformationen + ben”tigt 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 Endger„t-Anpassungen + ntzlich sein k”nnen, wie z.B. unten beschriebene Dateien: + - 'std primitives' + Enth„lt Prozeduren zur softwareseitigen Emulation von zwar gefor- + derten, hardwareseitig aber eventuell nicht bereitgestellten + Leistungen wie 'circle' und 'box'. + - 'matrix printer' + Enth„lt Prozeduren zur Erzeugung von Geraden und Fllmustern auf + einer Bitmatrix, die zur graphischen Ausgabe auf Druckern ben”tigt + wird. + - 'terminal plot' + Enth„lt grundlegende Prozeduren zur (behelfsm„áigen) Ausgabe von + Graphiken auf Ascii-Terminals (Zeichenorientiert, nicht graphikf„hig) + + 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 Endger„t 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 Endger„ten 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 k”nnen 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 k”nnen (s.o). + + 1.4 #ib(2," (1.4)")#LINK#ie(2,"")# + Syntax: LINK /, .... ; + - Dient zur Anbindung mehrerer Endger„te an einen Endger„t-Typ, + die hier genannten Kan„le werden eigenst„ndig verwaltet, aber + wie das bei 'PLOTTER' definierte Endger„t angesteuert; wobei fr + alle Endger„te der gleiche Name gilt, sie also durch die Kanal- + nummer unterschieden werden. + Durch Kommata getrennt, k”nnen mit dieser Anweisung beliebig + viele Endger„te zus„tzlich angebunden werden. + - : (INT) Stationsnummer des Endger„tes + (eigene Station) + - : (INT) Kanalnummer des Endger„tes + + 1.5 #ib(2," (1.5)")#PLOTTER#ie(2,"")# + Syntax: PLOTTER "Endger„tname",,, + ,,,; + - Dient zur Erkennung als Endger„t-Konfigurationsdatei, und zur + šbergabe der verwaltungsseitig ben”tigten + Endger„t-Spezifikationen: + - "Endger„tname": (TEXT) Name des Endger„tes + - : (INT) Stationsnummer des Endger„tes + (eigene Station) + - : (INT) Kanalnummer des Endger„tes + Jedes Endger„t wird ber diese drei Werte eindeutig identifiziert, + der Endger„tname kann also mehrfach verwendet werden. + - : (INT) X-Rasterkoordinate des letzten + Pixels in X-Richtung (i.d.R + adressierbare Pixel - 1) + - : (INT) Y-Rasterkoordinate des letzten + Pixels in Y-Richtung (s.o.) + - : (REAL) Breite der Zeichenfl„che in cm. + - : (REAL) H”he der Zeiuchenfl„che in cm. + (M”glichst 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- + ger„ten mit leerer Leistung zu implementieren.In 'type' ist die + tats„chlich 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 Endger„t diese Leistung nicht erbringen, + so muá 'std box' aus 'std.GCONF' mit gleichen Parametern aufge- + rufen werden. + 'pattern' als Fllmuster kann endger„tspezifisch 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 Endger„t 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: + - L”scht 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 ge„ndert. + + 2.6 PROC #ib(2," (2.6)")#endplot#ie(2," (PROC)")# + Syntax: PROC endplot: + - Schlieát die Graphik-Ausgabe auf einem Endger„t ab; evtl. Wechsel + in den Text-Modus, ggf. Cursor einschalten. + Bei Terminals sollte der Bildschirm nicht gel”scht werden. + + 2.7 PROC #ib(2," (2.7)")#fill#ie(2," (PROC)")# + Syntax: PROC fill (INT CONST x, y, pattern): + - Zus„tzliche vom System nicht verwendete Leistung zum Fllen von + Polygonen (rundum geschlossen), wobei die genau erbrachte Lei- + stung und die Bedingungen endger„tspezifisch 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 + Endger„ten mit leerer Leistung zu implementieren.In 'type' ist die + tats„chlich 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 Endger„t, 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 endger„tseitig 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 grunds„tzlich abgeschaltet. + Durch Einschalten des Cursors wird die Wirkung von 'home' + ver„ndert: + normal - 'home' positioniert die Zeichenposition auf + '0;0' + cursor - 'home' positioniert die Zeichenposition und + den graphischen Cursor auf die Mitte der + Zeichenfl„che. + + 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 Zeichenfl„che gesetzt werden. + + 2.12 PROC #ib(2," (2.12)")#initplot#ie(2," (PROC)")# + Syntax: PROC initplot: + - Bereitet die Graphik-Ausgabe auf einem Endger„t vor; evtl. + Wechsel in den Graphik-Modus, ggf. Cursor abschalten. + Bei Terminals sollte der Bildschirm nicht gel”scht 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 Zeichenfl„che 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 k”nnen systemseitig + verwendet werden: + 0 - Kreuz '+' + 1 - Kreuz diagonal 'x' + Weitere Typen k”nnen endger„tspezifisch 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- + ger„t ein. Dazu sind die vom Konfigurationsprogramm + hinzugefgten Prozeduren 'colors' und 'color' zu verwenden: + INT PROC colors + - Liefert die Anzahl der fr das Endger„t m”glichen 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 graphikf„higen Endger„te + zur Verfgung. + + #ib(1)#1.0 Allgemeines ber FKT#ie(1)# + Zu einer Zeichnung, wie sie mit 'FKT' erstellt werden kann, geh”ren + folgende Eigenschaften: + - Der Name der Zeichnung (zum Wiederfinden) + - Das Format + - Der Graph mit den Achsen bzw. dem Rahmen. + + Es k”nnen 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 gew„hlt. 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 Endger„ten stets so abgebildet wird, daá sie + unverzerrt in maximaler Gr”áe (also im gr”átm”glichen Quadrat) + gezeichnet wird. + + Der Funktionenplotter FKT ist in allen Sohntasks von 'GRAPHIK' verfg- + bar, zus„tzlich 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 Endger„t-Auswahlbereich, das Endger„t, auf dem eine + Zeichnung ausgegeben werden soll, kann mit den Tasten 'Links' bzw. + 'Rechts' eingestellt werden, wobei der Name des aktuell eingestellten + Endger„tes 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 zul„ssigen + 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 M”glichkeiten in eckigen, + Erkl„rungen 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 zul„ssig, 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, vollst„ndig aus Groábuchstaben) auftauchen. + + IF --+--> THEN --+--> ELSE --> END IF + | | + | | + +--- ELIF --+ + + + Es k”nnen 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 ge„ndert werden. + + Graphen mit Definitionslcken k”nnen auch in zwei oder mehr Teilen + erstellt werden, n„mlich jeweils ber den zusammenh„ngenden + Definitionsintervallen, die keine Lcke enthalten. Dazu muá jeweils + die Zeichnung erg„nzt (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 gew„hlte + Genauigkeit zu groá und sollte umgew„hlt 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 tats„chlichen Grenzen des Wertebereichs. + Erscheinen in der zug. Informationszeile Sterne, so ist die gew„hlte + Genauigkeit zu groá und sollte umgew„hlt werden. + + 3.4 #ib(2," (3.4)")#(z) Zeichnung anfertigen#ie(2,"")# + Eine Zeichnung kann auf allen zur Verfgung stehenden Ger„ten + ausgegeben werden, wenn sie erzeugt ist. + Mit diesem Menuepunkt werden die Zeichnungen nur erstellt, d.h. der + Graph erscheint noch nicht auf einem Ausgabeger„t. + Diese Zeichnungen werden dann im System aufbewahrt und k”nnen + somit mehrfach ausgegeben werden. + + Im Dialogbereich wird zun„chst der Name der Zeichnung angefordert, + dieser beginnt grunds„tzlich mit dem Prefix 'PICFILE.', das nicht + ver„ndert werden kann. + Dabei wird als Erg„nzung des Namens der Funktionsterm angeboten, so + daá die Zeichnung z.B. 'PICFILE.sin(x)' heiát. + Dieser Teil des Namens kann aber frei ver„ndert werden. + Existiert bereits eine Zeichnung gleichen Namens, so erscheint im + Dialogbereich eine Anfrage, wie verfahren werden soll, wobei + folgende M”glichkeiten genannt werden: + + - : Die alte Zeichnung wird gel”scht. + - : Der Name wird erneut zur Žnderung angeboten. + - : Die neue Zeichnung, welche hiernach erstellt wird, wird an die + schon existierende Zeichnung angah„ngt. 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 ge„ndert werden soll. + Nachdem die Zeichnung erstellt wurde, was durch den + Sttzpunkt-Z„hler angezeigt wird, muá noch die Farbe, in der der + Graph gezeichnet werden soll eingegeben werden. + + Fehlerquelle: Wertebereich ist noch nicht bestimmt (siehe 4). + Unzul„essiges 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 Endger„t#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 + ausgew„hlt 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 gew„hlt + werden, liegt der Ursprung nicht innerhalb der Zeichnung, so wird + grunds„tzlich 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 Endger„t ausgegeben. + + 3.6 #ib(2," (3.6)")#(t) Wertetafel erstellen lassen#ie(2,"")# + In dem gew„hlten Definitionsbereich kann eine Wertetafel erstellt + werden, die in einer von Ihnen gewnschten Schrittweite ermittelte + Funktionswerte zeigt. + Zun„chst wird die Schrittweite erfragt, dann die von FKT formatiert + erstellte Wertetafel gezeigt. + Diese befindet sich in einer Datei, die den Namen des zugeh”rigen + Funktionsterms tr„gt, existiert diese bereits, so wird die Wertetafel + erg„nzt. + Enth„lt diese Tafel Sterne, so mssen Sie die Genauigkeit umw„hlen + 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 + gew„hlt. + Die Schrittweite wurde zu klein gew„hlt. 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 gel”scht! + + 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 m”g- + 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 H”chstgrenze 512. + + Fehlerquelle: Zahl der Sttzpunkte ist fehlerhaft. + Nur ganze Zahlen aus dem Intervall [2;512] zul„ssig. + + 3.11 #ib(2," (3.11)")#(n) Nachkommastellenzahl w„hlen#ie(2,"")# + Hier kann die Zahl der angezeigten Nachkommastellen eingestellt + werden (intern wird immer h”chstm”gliche Genauigkeit verwendet). + Maximal sind neun Nachkommastellen zul„ssigt, jedoch kann die + Genauigkeit zu groá fr das Anzeigeformat werden; dann erscheinen + in der Anzeige Sterne (*************). + Es gilt grunds„tzlich: + 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 ausgew„hlten Zeichnungen werden nach noch- + maliger Rckfrage gel”scht. + + 3.14 #ib(2," (3.14)")#(A) Zeichnungen archivieren#ie(2,"")# + Nach Aufruf dieses Menuepunktes k”nnen 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 k”nnen Zeichnungen frei beschriftet werden. + Zun„chst wird im Dialogbereich erfragt, wie mit bereits bestehenden + Beschriftungen verfahren werden soll: + + - : Die nachfolgenden Texte werden zus„tzlich zu den schon + vorhandenen Beschriftungen angefgt. + - : Die vorhandenen Beschriftungen werden gel”scht, und es wird + zum Menue zurckgekehrt. + - : 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 Texth”he 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 M”glichkeit, sehr einfach zweidimensionale + Zeichnungen zu erstellen. Sie basiert auf dem in LOGO verwendeten Modell, in + dem eine Zeichenposition in jeweils eine bestimmte Richtung vorw„rts bzw. + rckw„rts bewegt werden kann, und die Zeichenrichtung ver„ndert 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 ver„ndert. + + 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”átm”glicher + 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 Endger„t ........... 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 w„hlen .................. 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. + Fehlerf„lle: + * left dimension <> right dimension + Es k”nnen 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 ver„ndert wird. + Fehlerf„lle: + * 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 Zeichenh”he #on("italics")#hight#off("italics")# und der Breite #on("italics")#bright#off("italics")# gezeich- + net. Der Anfang ist dabei die aktuelle Stiftposition, die nicht ver„ndert + wird. + Fehlerf„lle: + * 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). + Fehlerf„lle: + * 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). + Fehlerf„lle: + * 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 L„nge (x, y, z) relativ zur aktuellen Position. + Fehlerf„lle: + * 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 L„nge (x, y) relativ zur aktuellen Position. + Fehlerf„lle: + * 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. + Fehlerf„lle: + * 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 L„nge (x, y) cm relativ zur aktuellen Position. + Dabei werden die angegebenen Projektionsparameter nicht beachtet, + sondern die Angaben in #on("bold")#Zentimeter#off("bold")# berechnet. + Fehlerf„lle: + * 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. + Fehlerf„lle: + * 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. + Fehlerf„lle: + * 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) erh”ht. + Fehlerf„lle: + * 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) erh”ht. + Position. + Fehlerf„lle: + * 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. + Fehlerf„lle: + * 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 erh”ht. Dabei werden die an- + gegebenen Projektionsparameter nicht beachtet, sondern die Angaben in #on("bold")# + Zentimeter#off("bold")# berechnet. + Fehlerf„lle: + * 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 ver„ndert. + Fehlerf„lle: + * 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 ver„ndert. + Fehlerf„lle: + * 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. + Fehlerf„lle: + * 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. + Fehlerf„lle: + * 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. + Fehlerf„lle: + * 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). + Fehlerf„lle: + * 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). + Fehlerf„lle: + * 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")# + ver„ndert. + + 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")# + ver„ndert. + +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 zus„tzlich eine Achsenspiegelung. + Dabei werden nur die Werte von #on("italics")#draw, draw r, move #off("italics")# und #on("italics")#move r#off("italics")# + ver„ndert. + Fehlerf„lle: + * Picture is three dimensional + + PROC stretch (PICTURE VAR p, REAL CONST sx, sy, sz) + Zweck: s. o. + Fehlerf„lle: + * 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")# + ver„ndert. + Fehlerf„lle: + * Picture is three dimensional + + PROC translate (PICTURE VAR p, REAL CONST dx, dy, dz) + Zweck: s. o. + Fehlerf„lle: + * 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 + unver„ndert. + + +#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. + Fehlerf„lle: + * 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 m”glichst 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 Ann„herung fr das Ausgabeger„t 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 m”glich, 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 L”schstift und positive Farben + berschreiben (ersetzen) den alten Punkt mit folgenden Werten: + + 1 Standardfarbe des Endger„tes + 2 rot + 3 blau + 4 grn + 5 schwarz + 6 weiá + > 6 nicht normierte Sonderfarben + + + #on("bold")#Dicke:#off("bold")# 0 Standardstrichst„rke des Endger„tes, ansonsten Strichst„rke in + 1/10 mm. + + + #on("bold")#Linientyp:#off("bold")# + 0 keine sichtbare Linie + 1 durchg„ngige 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 M”glichkeiten mssen nicht an allen graphischen + Endger„ten vorhanden sein. Der ger„teabh„ngige Graphik-Treiber w„hlt + jeweils die bestm”gliche Ann„herung. + + Fehlerf„lle: + * 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 m”glich. + + 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 h„ufig 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 gew„hlte 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")# ver„ndern 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 L„nge darf ungleich 1 sein). + +viewport + PROC viewport (PICFILE VAR p, REAL CONST hormin, hormax, vertmin, + vertmax) : 1-709 + Zweck: Die Zeichenfl„che auf dem Endger„t, auf dem das Bild dargestellt werden + soll, wird spezifiziert. Dabei wird sowohl die Gr”áe als auch die relative + Lage der Zeichenfl„che definiert. Der linke untere Eckpunkt der physi- + kalischen Zeichenfl„che des Ger„tes hat die Koordinaten (0, 0). Die + definierte Zeichenfl„che 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 ger„teunabh„ngige als auch maástabgetreue Zeichnungen + m”glich sind, k”nnen die Koordinaten in zwei Arten spezifiziert werden: + a) #on("bold")#Ger„tekoordinaten#off("bold")# + Die Koordinaten k”nnen Werte von 0.0 bis 2.0 annehmen. Dabei + hat die krzere Seite der physikalischen Zeichenfl„che definitionsge- + m„á die L„nge 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”átm”gliche Quadrat, beginnend mit der linken unteren Ecke + der physikalischen Zeichenfl„che. In vielen F„llen 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 m”glich + ist. Da man oft quadratische Fenster (#on("italics")#window#off("italics")#) verwendet, wurde als + Standardeinstellung auch ein quadratisches #on("italics")#viewport#off("italics")# gew„hlt. + + 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, geh”ren zum definierten Fenster.Vektoren, die auáerhalb + dieses Fensters liegen, gehen ber die durch #on("italics")#viewport#off("italics")# Fl„che hinaus + (s.dort). + + Der Darstellungsmaástab ergibt sich als + + #ub# x max - x min #ue# + horizontale Seitenl„nge der Zeichenfl„che + + + #ub# y max - y min #ue# + vertikale Seitenl„nge der Zeichenfl„che + + 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, geh”ren 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 Zeichenfl„che abgebildet. + Anders als im zweidimensionalen Fall ist das Problem der Maásta„be + 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 K”rper 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 n”tig. + Fehlerf„lle: + * dataspace is no PICFILE + Der anzukoppelnde Datenraum hat einen unzul„ssigen 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 k”nnen nur maximal 1024 Picture (S„tze) 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")#. + Fehlerf„lle: + * 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 vorw„rts. + 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 vorw„rts. + 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: L”scht 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 ver„ndert. + +#page# + #on("italics")#Wo wir sind, da klappt nichts, + aber wir k”nnen 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 Fl„che 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 Fl„che*) +(* muá dann aber mit unsichtbaren Pixels begrenzt werden. *) +(* *) +(* Folgende Muster sind m”glich: *) +(* 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' (Schr„ges 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 Fl„che zu komplex wird, kann es vorkommen,*) +(* daá der interne Stack berl„uft. In diesem Fall wird nicht die *) +(* gesamte Fl„che 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 m”glich: *) +(* *) +(* 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 l”scht 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 w„hlen *) +(* 1 = Seite 1 als sichtbare Seite w„hlen *) +(* Bit 2 : *) +(* 0 = Seite 0 als bearbeitete Seite w„hlen *) +(* 1 = Seite 1 als bearbeitete Seite w„hlen *) +(* Bit 3, 4 : Verknpfung Patternbit: 0 1 *) +(* 0 OR setzen unver„ndert *) +(* 1 NAND l”schen unver„ndert *) +(* 2 XOR invertieren unver„ndert *) +(* 3 COPY l”schen 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 enth„lt 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 n„chste '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 n„chste '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 *) +(********************** Hardwareunabh„ngiger Teil ************************* +* * +* * +* Im Harwareunabh„ngigen 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: Zeichenfl„che * +* ((h min, h max), (v min, v max)) * +* Bei Werten < 2.0 werden die Werte als * +* Prozente interpretiert, ansonsten als * +* cm-Gr”ssen. * +* 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 Zeichenfl„che * +* reset  : L”scht 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 new file mode 100644 index 0000000..2cdd8e9 Binary files /dev/null and b/app/mpg/1987/src/DIPCHIPS.DS differ 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 = "Standard ot lau ruen 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 "); + 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("oordinatensystem oder 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 Zeichenfl„che *****} + 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 ausw„hlen *****} . + +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 Endger„t hardwarem„áig verschieden Linientypen *****} + {***** besitzt, k”nnen 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 Abh„ngigkeit 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 H”he 'height' und *****} +{**** der Breite 'width' gezeichnet. Falls die Hardware dieses *****} +{**** bereits erm”glicht, so mssen die Variable 'zeichen' und die *****} +{**** Prozedur Zeichensatz gel”scht werden. Der Datenraum *****} +{**** 'STD Zeichensatz' wird in diesem Fall nicht ben”tigt. *****} + 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) (* H”he: 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 H”he '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 Bl”cke (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); + +(* L”schen der Hiddenmaxima *); + reset; + +(* Ausgabe der Bildmatrix auf dem Endger„t *); + put screen; + +(* L”schen 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 H”he 'height' und *****} +{**** der Breite 'width' gezeichnet. Falls die Hardware dieses *****} +{**** bereits erm”glicht, so mssen die Variable 'zeichen' und die *****} +{**** Prozedur Zeichensatz gel”scht werden. Der Datenraum *****} +{**** 'STD Zeichensatz' wird in diesem Fall nicht ben”tigt. *****} + 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",,,,,,; + +LINK /,/....; + +COLORS ""; + + . + . + . + + +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) { H”he: 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 H”he '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 Bl”cke (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);IFs72s84THENs97ELSEreserve(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-s149s150THENerrorstop(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;IFs230s145THENs232ELIFs186<>s200ANDlength(s186) +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)s145THENout(s148); +s278;LEAVEs276FI;s184CATs304(s183);IFs196THENs278FI.s278:IFs277THENs211ELSE IF +s183s140.s295 +:IFs182=s140THENs296ELSEs297FI.s296:s183DECRs140;s223(s183);s211.s297:s303;s183 +DECRs140;s182DECRs140;s211ENDPROCs293;PROCs298:IFs299THENs300ELSEout(s148)FI. +s299:s183s181THENs301ELSEs302FI.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 )",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)ANDs616s640THENs637:=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)=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:s824s815ANDs824=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)CORs824s832THENout(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 m”glich *) +END PROC background; + +PROC foreground (INT CONST desired, INT VAR realized): + akt pen := desired; + realized := sign (desired) . (*Nur weiáer Sift m”glich, aber *) + (*l”schend, „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" # durchg„ngige 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" # l”schend # + 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 new file mode 100644 index 0000000..c06b5eb Binary files /dev/null and b/app/mpg/1987/src/ZEICH610.DS differ diff --git a/app/mpg/1987/src/ZEICH912.DS b/app/mpg/1987/src/ZEICH912.DS new file mode 100644 index 0000000..fc55473 Binary files /dev/null and b/app/mpg/1987/src/ZEICH912.DS differ diff --git a/app/mpg/1987/src/ZEICHEN.DS b/app/mpg/1987/src/ZEICHEN.DS new file mode 100644 index 0000000..0c4927d Binary files /dev/null and b/app/mpg/1987/src/ZEICHEN.DS differ 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 abh„ngige 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 ; -- cgit v1.2.3