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/GRAPHIK.Plot | 1156 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1156 insertions(+) create mode 100644 app/mpg/1987/src/GRAPHIK.Plot (limited to 'app/mpg/1987/src/GRAPHIK.Plot') 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 -- cgit v1.2.3