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