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