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) *)
(* Füllt 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 gefüllt, die Fläche*)
(* muß dann aber mit unsichtbaren Pixels begrenzt werden. *)
(* *)
(* Folgende Muster sind möglich: *)
(* 0 = 'solid' (alles gefüllt) *)
(* 1 = 'lrs2' (jeder zweite Punkt, Zeilenweise versetzt) *)
(* 2 = 'row4' (jede 4. Zeile wird gefüllt) *)
(* 3 = 'row2' (jede 2. Zeile wird gefüllt) *)
(* 4 = 'col4' (jede 4. Spalte wird gefüllt) *)
(* 5 = 'col2' (jede 2. Spalte wird gefüllt) *)
(* 6 = 'grid4' (jede 4. Spalte/Zeile wird gefüllt) *)
(* 7 = 'grid2' (jede 2. Spalte/Zeile wird gefüllt) *)
(* 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 füllende Fläche zu komplex wird, kann es vorkommen,*)
(* daß der interne Stack überläuft. In diesem Fall wird nicht die *)
(* gesamte Fläche gefüllt 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 zurückgeliefert: *)
(* 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) *)
(* Füllt 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 : Verknüpfung 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 ausgeführt, 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- *)
(* knüpfung 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 ;