diff options
Diffstat (limited to 'app/mpg/1987/src/B108PLOT.ELA')
| -rw-r--r-- | app/mpg/1987/src/B108PLOT.ELA | 642 |
1 files changed, 642 insertions, 0 deletions
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 ;
|