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