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