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/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 +++ 35 files changed, 13762 insertions(+) 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 (limited to 'app/mpg/1987/src') 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; -- cgit v1.2.3