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 müssen 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;