program virker(ptfile);
(* Virker skidtet ? *)
const
dim1 = 10;
dim2 = 1;
nc = 2; (* antal pkt til afrunding *)
tk = 0.5; (* tykkelse af streger til omrids af kasser *)
tp = 1.0; (* tykkelse af pilestreger *)
pl = 10; (* lengde af kort pil *)
spx = 3; (* pilespids *)
spy = 1; (* pilespids *)
pt = 12; (* punktstorrelse af skrift *)
ht = 5; (* halv hojde af kasser *)
tx = 4; (* offset af tekster *)
ty = 1; (* offset af tekster *)
#include "alfaplot"
var
CKX, CKY, CLX, CLY, RXA, RYA : vektor;
x, y, x1, y1, x2, y2, x3, x4 : real;
i : integer;
#include "syntaks"
procedure JA(xj, yj : real);
begin
MESSAGE('Ja', 2, xj, yj);
end; (* JA *)
procedure NEJ(xj, yj : real);
begin
MESSAGE('Nej', 3, xj, yj);
end; (* NEJ *)
begin
rewrite(ptfile);
START(0, 'PROBLEML\351SNINGSSKEMA', 23);
ARX; x1 := x + 16; y1 := y - ht;
RD(x, y, 33, 'Virker skidtet?', 15); NEJ(x+1, y+1);
AR(x, y, x+pl+5, y, 1); x2 := x + 22;
RD(x, y, 45, 'Har du pillet ved det?', 22); JA(x+1, y+1);
x4 := x + pl*2 + (52 - 22)/2 - 2; AR(x, y, x4, y, 1);
SQ(x, y, 22, 'TUMPE', 5); x3 := x - 11;
x := x1; y := y1; JA(x+1, y-ht); AR(x, y, x, y-pl, 1);
x := x2; y := y1; NEJ(x+1, y-ht); AR(x, y, x, y-pl, 1);
x := x3; y := y1; AR(x, y, x, y-pl, 1);
x := x1 - 17; y := y - ht;
SQ(x, y, 34, 'Pil ikke ved det', 16); x := x2 - 21; y1 := y - ht;
RD(x, y, 42, 'F\331r du problemer?', 20); JA(x+1, y+1); ARX; x4 := x;
x := x + pl; JA(x-ht, y+1); AR(x, y, x-pl, y, 1); x := x + pl;
RD(x, y, 52, 'Er der nogen der ved det?', 25);
x := x1; y := y1; AR(x, y, x, y-pl*3-ht*8, 1);
x := x - 23; y := y - ht; SQ(x, y, 47, 'INGEN PROBLEMER', 15);
x := x1; y := y - ht; AR(x, y, x, y-pl, 1);
x := x2; y := y1; NEJ(x+1, y-ht); AR(x, y, x, y-pl, 1);
x := x3; y := y1; NEJ(x+1, y-ht); AR(x, y, x, y-pl, 1); y2 := y - pl - ht*3;
x := x4; y := y1 + ht; AR(x, y, x, y2, 1);
x := x2 - 13; y := y1 - ht - pl; SQ(x, y, 26, 'Sylt sagen', 10);
x := x2 - 13; AR(x, y, x1 , y, 1);
x := x3 - 12; SQ(x, y, 24, 'Glem det', 8);
x := x3; y := y - ht; AR(x, y, x, y-pl*2-ht*5, 0); x2 := x2 - 11;
AR(x, y, x1, y, 1); x := x4; y := y2; AR(x, y, x2+19, y, 1);
x := x2 - 18; SQ(x, y, 37, 'STAKKELS DIG', 12);
x := x2; y := y - ht; AR(x, y, x, y-pl, 1);
x := x2 - 32; y := y - ht; JA(x-ht, y+1); AR(x, y, x1 , y, 1); x := x2 - 32;
RD(x, y, 64, 'Kan du skyde skylden p\331 nogen?', 33); NEJ(x+1, y+1);
AR(x, y, x4, y, 0); AR(x, y, x, y2, 1);
ENDPL
end.
(* alfaplot version 4.1 10.7.1998 *)
type
matrix = array[0..dim2, 0..dim2] of real;
vektor = array[-1..dim1] of real;
tekst = packed array[1..60] of char;
xyzrec = record
xb, xe, yb, ye, zb, ze, dx, dy, dz, vx, vy, vz : real
end;
var
ptfile : text;
xyzvar : xyzrec;
global : record
overskrift, xticks, yticks, zticks : integer;
heading, intxax, intyax, intzax, bld, itl,cross,box : boolean;
xxxdisp, xxxmax, xxxorig, xxxscal, xsize, ysize,
yyydisp, yyymax, yyyorig, yyyscal : real
end;
procedure BEGINPL(i : integer);
begin
with global do
begin
heading := (i > 0); bld := false; itl := false;
intxax := false; intyax := false; intzax := false;
xticks := 1; yticks := 1; zticks := 1; cross := false;
overskrift := 812; xsize := 21.0; ysize := 29.5
end;
writeln(ptfile, '%! qmsplot version 4.1');
writeln(ptfile, '/pt {0.24 mul} def')
end; (* BEGINPL *)
procedure AREA(x, y : real);
var
a : timestamp;
z : real;
procedure outp(t : integer);
begin
if t < 10 then write(ptfile, '0', t:1)
else write(ptfile, t:2)
end; (* outp *)
begin
z := 300/2.54;
with global do
begin xxxdisp := (xsize - x)/2*z; xxxmax := x*z;
yyydisp := (ysize - y)/2*z; yyymax := y*z;
if heading then
begin
writeln(ptfile, '/Times-Roman findfont');
writeln(ptfile, '8 scalefont');
writeln(ptfile, 'setfont'); gettimestamp(a);
writeln(ptfile, ' 17 ', overskrift:4, ' moveto');
write(ptfile, '(', a.day:2,'.', a.month:2, '.');
outp(a.year); writeln(ptfile, ') show');
writeln(ptfile, ' 62 ', overskrift:4, ' moveto');
write(ptfile, '(', a.hour:2, ':'); outp(a.minute);
write(ptfile, ':'); outp(a.second); writeln(ptfile, ') show')
end;
writeln(ptfile, '/Times-Roman findfont');
writeln(ptfile, '12 scalefont');
writeln(ptfile, 'setfont');
end
end; (* AREA *)
procedure BOLD(b : boolean);
begin
global.bld := b
end; (* BOLD *)
procedure ITALIC(b : boolean);
begin
global.itl := b
end; (* ITALIC *)
procedure TIMES(i : real);
begin with global do
begin
write(ptfile, '/Times-');
if bld then write(ptfile, 'Bold');
if itl then write(ptfile, 'Italic');
if not(bld or itl) then write(ptfile, 'Roman');
writeln(ptfile, ' findfont ', i:5:1, ' scalefont setfont')
end
end; (* TIMES *)
procedure TIM(i : real);
begin with global do
begin
write(ptfile, '/Tim');
writeln(ptfile, ' findfont ', i:5:1, ' scalefont setfont')
end
end; (* TIM *)
procedure HELVETICA(i : integer);
begin with global do
begin
write(ptfile, '/Helvetica');
if bld then write(ptfile, '-Bold')
else if itl then write(ptfile, '-');
if itl then write(ptfile, 'Oblique');
writeln(ptfile, ' findfont ', i:4, ' scalefont setfont')
end
end; (* HELVETICA *)
procedure COURIER(i : integer);
begin with global do
begin
write(ptfile, '/Courier');
if bld then write(ptfile, '-Bold')
else if itl then write(ptfile, '-');
if itl then write(ptfile, 'Oblique');
writeln(ptfile, ' findfont ', i:4, ' scalefont setfont')
end
end; (* COURIER *)
procedure RGB(r, g, b : real);
begin
writeln(ptfile, r:7:3, g:7:3, b:7:3, ' setrgbcolor');
end; (* RGB *)
procedure CMYK(c, m, y, k : real);
begin
writeln(ptfile, c:7:3, m:7:3, y:7:3, k:7:3, ' setcmykcolor');
end; (* CMYK *)
procedure HSB(h, s, b : real);
begin
writeln(ptfile, h:7:3, s:7:3, b:7:3, ' sethsbcolor');
end; (* HSB *)
procedure INTXAX(b : boolean);
begin global.intxax := b end; (* INTXAX *)
procedure INTYAX(b : boolean);
begin global.intyax := b end; (* INTYAX *)
procedure INTZAX(b : boolean);
begin global.intzax := b end; (* INTZAX *)
procedure XTICKS(i : integer);
begin global.xticks := i end; (* XTICKS *)
procedure YTICKS(i : integer);
begin global.yticks := i end; (* YTICKS *)
procedure ZTICKS(i : integer);
begin global.zticks := i end; (* ZTICKS *)
procedure CROSS(b : boolean);
begin global.cross := b end; (* CROSS *)
procedure DASH;
begin writeln(ptfile, '[4 4] 0 setdash ') end; (* DASH *)
procedure BOX(b : boolean);
begin global.box := b end; (* BOX *)
procedure MOVE(x, y : real);
var ix, iy : integer;
begin
with global do
begin ix := round((x - xxxorig)*xxxscal + xxxdisp);
iy := round((y - yyyorig)*yyyscal + yyydisp);
end;
if ix < 0 then ix := 1; if ix > 9999 then ix := 9999;
if iy < 0 then iy := 1; if iy > 9999 then iy := 9999;
writeln(ptfile, ix:5, ' pt ', iy:5, ' pt moveto')
end; (* MOVE *)
procedure CONNPT(x, y : real);
var ix, iy : integer;
begin
with global do
begin ix := round((x - xxxorig)*xxxscal + xxxdisp);
iy := round((y - yyyorig)*yyyscal + yyydisp);
end;
if ix < 0 then ix := 1; if ix > 9999 then ix := 9999;
if iy < 0 then iy := 1; if iy > 9999 then iy := 9999;
writeln(ptfile, ix:5, ' pt ', iy:5, ' pt lineto')
end; (* CONNPT *)
procedure RLVEC(xf, yf, xt, yt, width : real);
begin
if width < 0.01 then width := 0.01;
if width > 50 then width := 50;
writeln(ptfile, 'newpath');
MOVE(xf, yf); CONNPT(xt, yt);
writeln(ptfile, width:6:2, ' setlinewidth stroke')
end; (* RLVEC *)
procedure MESSAGE(t : tekst; l : integer; x, y : real);
begin
MOVE(x, y); if l > 0 then writeln(ptfile, '(', t:l, ') show')
end; (* MESSAGE *)
procedure MESS(t : tekst; l : integer);
begin
if l > 0 then writeln(ptfile, '(', t:l, ') show')
end; (* MESS *)
procedure INTNO(i, l : integer; x, y : real);
begin
MOVE(x, y); if l > 0 then writeln(ptfile, '(', i:l, ') show')
end; (* INTNO *)
procedure INT(i, l : integer);
begin
if l > 0 then writeln(ptfile, '(', i:l, ') show')
end; (* INT *)
procedure REALNO(r : real; l, m : integer; x, y : real);
begin
MOVE(x,y); if l > 0 then writeln(ptfile, '(', r:l:m, ') show')
end; (* REALNO *)
procedure REA(r : real; l, m : integer);
begin
if l > 0 then writeln(ptfile, '(', r:l:m, ') show')
end; (* REA *)
procedure KOORD(xb, dx, xe, yb, dy, ye : real);
var
x, y, xa, ya, xt, yt, yy : real;
begin
with global do
begin xxxorig := xb; xxxscal := xxxmax/(xe - xb);
yyyorig := yb; yyyscal := yyymax/(ye - yb);
xt := 40/yyyscal; yt := 40/xxxscal;
end;
if global.cross then ya := 0 else ya := yb;
if dx <= xe - xb then RLVEC(xb, ya, xe, ya, 1);
yy := ya - xt*2.5;
if dx < xe - xb then
begin
y := ya - xt; x := xb/dx;
if x < 0 then x := - round(-x - 0.4999)*dx
else if x < 1000000 then x := round(x + 0.5)*dx;
while x <= xe do
begin RLVEC(x, ya, x, y, 0.5);
if global.intxax
then INTNO(round(x), 5, x-yt*1.5, yy)
else if dx > 0.08 then REALNO(x, 5, 1, x-yt, yy)
else REALNO(x, 7, 3, x-yt*1.5, yy);
x := x + dx
end;
if global.xticks > 1 then
begin
dx := dx/global.xticks; x := xb/dx; y := ya - xt*0.7;
if x < 0 then x := - round(-x - 0.49999)*dx
else x := round(x + 0.5)*dx;
while x <= xe do
begin RLVEC(x, ya, x, y, 0.2); x := x + dx end
end
end;
if global.cross then xa := 0 else xa := xb;
yy := xa - yt*4;
if dy <= ye - yb then RLVEC(xa, yb, xa, ye, 1);
if dy < ye - yb then
begin
x := xa - yt; y := yb/dy;
if y < 0 then y := - round(-y - 0.4999)*dy
else y := round(y + 0.5)*dy;
while y <= ye do
begin RLVEC(xa, y, x, y, 0.5);
if global.intyax
then INTNO(round(y), 5, yy, y)
else if dy > 0.08 then REALNO(y, 5, 1, yy, y)
else REALNO(y, 7, 3, yy, y);
y := y + dy
end;
if global.yticks > 1 then
begin
dy := dy/global.yticks; y := yb/dy; x := xa - yt*0.7;
if y < 0 then y := - round(-y - 0.49999)*dy
else y := round(y + 0.5)*dy;
while y <= ye do
begin RLVEC(xa, y, x, y, 0.2); y := y + dy end
end
end;
end; (* KOORD *)
procedure CURVE(var XX, YY : vektor; ib, ie : integer; width : real);
var
i : integer;
begin
writeln(ptfile, 'newpath');
MOVE(XX[ib], YY[ib]);
for i := ib+1 to ie do CONNPT(XX[i], YY[i]);
if width = 0 then writeln(ptfile, ' closepath fill');
if width < 0 then
begin write(ptfile, ' closepath '); width := - width end;
if width > 50 then width := 50;
if width > 0 then writeln(ptfile, width:5:2, ' setlinewidth stroke ')
end; (* CURVE *)
procedure MARK(x, y, mm, width : real; ind : integer);
var
xt, yt : real;
begin
xt := 150/25.4*mm/global.xxxscal; yt := 150/25.4*mm/global.yyyscal;
case ind of
0 : begin (* 0 = SQUARE *)
RLVEC(x-xt, y-yt, x+xt, y-yt, width);
RLVEC(x+xt, y+yt, x+xt, y-yt, width);
RLVEC(x+xt, y+yt, x-xt, y+yt, width);
RLVEC(x-xt, y-yt, x-xt, y+yt, width)
end;
1 : begin (* 1 = NABLA *)
RLVEC(x-xt, y+yt, x, y-yt, width);
RLVEC(x, y-yt, x+xt, y+yt, width);
RLVEC(x+xt, y+yt, x-xt, y+yt, width)
end;
2 : begin (* 2 = TRI *)
RLVEC(x-xt, y-yt, x, y+yt, width);
RLVEC(x, y+yt, x+xt, y-yt, width);
RLVEC(x+xt, y-yt, x-xt, y-yt, width)
end;
3 : begin (* 3 = PLUS *)
RLVEC(x-xt, y, x+xt, y, width);
RLVEC(x, y-yt, x, y+yt, width)
end;
4 : begin (* 4 = KRYDS *)
RLVEC(x-xt, y-yt, x+xt, y+yt, width);
RLVEC(x+xt, y-yt, x-xt, y+yt, width)
end;
otherwise begin (* 5 = DIAMOND *)
RLVEC(x-xt, y, x, y+yt, width);
RLVEC(x, y+yt, x+xt, y, width);
RLVEC(x+xt, y, x, y-yt, width);
RLVEC(x, y-yt, x-xt, y, width)
end
end
end; (* MARK *)
procedure SQUARE(x, y, width : real);
begin
MARK(x, y, 3, width, 0)
end; (* SQUARE *)
procedure NABLA(x, y, width : real);
begin
MARK(x, y, 3, width, 1)
end; (* NABLA *)
procedure TRI(x, y, width : real);
begin
MARK(x, y, 3, width, 2)
end; (* TRI *)
procedure PLUS(x, y, width : real);
begin
MARK(x, y, 3, width, 3)
end; (* PLUS *)
procedure KRYDS(x, y, width : real);
begin
MARK(x, y, 3, width, 4)
end; (* KRYDS *)
procedure DIAMOND(x, y, width : real);
begin
MARK(x, y, 3, width, 5)
end; (* DIAMOND *)
procedure DOT(x, y, mm : real);
begin
RLVEC(x, y, x+mm*300/25.4/global.xxxscal, y, mm*72/25.4)
end; (* DOT *)
procedure SCALE(var xyzvar : xyzrec; var FUNC : matrix;
var XX, YY : vektor; ib, ie, jb, je : integer);
var
min, max, v : real;
i, j : integer;
begin
min := FUNC[ib, jb]; max := min;
for i := ib to ie do
for j := jb to je do
begin v := FUNC[i,j];
if min > v then min := v;
if max < v then max := v
end;
with xyzvar do
begin
xb := XX[ib]; xe := XX[ie];
yb := YY[jb]; ye := YY[je];
zb := min; ze := max;
dx := 1; dy := 1; dz := 1;
if (xe - xb) < 1.5 then dx := 0.1;
if (ye - yb) < 1.5 then dy := 0.1;
if (ze - zb) < 1.5 then dz := 0.1;
vx := xe*2 - xb; vy := yb*2 - ye; vz := ze*2 - zb
end
end; (* SCALE *)
procedure KOORD3D(xyzvar : xyzrec);
var
x, xx, x1, x2, xt, xxb, xxe, z,
y, yy, y1, y2, yt, yr, zzb, zze : real;
begin
with xyzvar do with global do
begin
if vy > yb then vy := yb*2 - ye; yr := (yb - vy)/(ye - vy);
xxb := xb; xxe := xe; zzb := zb; zze := ze;
if vz > ze then zze := (ze - vz)*yr + vz;
if vz < zb then zzb := (zb - vz)*yr + vz;
if vx > xe then xxe := (xe - vx)*yr + vx;
if vx < xb then xxb := (xb - vx)*yr + vx;
xxxorig := xxb; xxxscal := xxxmax/(xxe - xxb); yt := 40/xxxscal;
yyyorig := zzb; yyyscal := yyymax/(zze - zzb); xt := 40/yyyscal;
if vz < zb then y := ze else begin y := zb; xt := - xt end;
yy := y + xt; y1 := (yy - y)*2.5 + y;
if dx <= xe - xb then
begin
RLVEC(xb, y, xe, y, 1); x := xb/dx;
if x < 0 then x := - round(-x - 0.49999)*dx
else x := round(x + 0.49999)*dx;
while x <= xe do
begin RLVEC(x, y, x, yy, 0.5);
if global.intxax
then INTNO(round(x), 5, x-yt*1.5, y1)
else if dx > 0.08 then REALNO(x, 5, 1, x-yt, y1)
else REALNO(x, 7, 3, x-yt*1.5, y1);
x := x + dx
end;
if global.xticks > 1 then
begin
dx := dx/global.xticks; x := xb/dx; yy := y + xt*0.7;
if x < 0 then x := - round(-x - 0.49999)*dx
else x := round(x + 0.5)*dx;
while x <= xe do
begin RLVEC(x, y, x, yy, 0.2); x := x + dx end
end
end;
if dz <= ze - zb then
begin
if vx >= xb then begin x := xb; yr := 1 end else x := xxb;
y1 := (zb - vz)*yr + vz; y2 := (ze - vz)*yr + vz;
RLVEC(x, y1, x, y2, 1); x1 := x - yt*4; z := zb/dz;
if z < 0 then z := - round(-z - 0.49999)*dz
else z := round(z + 0.49999)*dz;
yy := (y2 - y1)*dz/(ze - zb); x2 := z;
y := (z - vz)*yr + vz;
while x2 <= ze do
begin RLVEC(x-yt, y, x, y, 0.5);
if global.intzax then
INTNO(round(x2), 5, x1, y)
else if dz > 0.08 then REALNO(x2, 5, 1, x1, y)
else REALNO(x2, 7, 3, x1, y);
x2 := x2 + dz; y := y + yy
end; y2 := y - yy;
if global.zticks > 1 then
begin
dz := dz/global.zticks; yt := yt*0.7;
yy := yy/global.zticks; z := zb/dz;
if z < 0 then z := - round(-z - 0.49999)*dz
else z := round(z + 0.5)*dz;
y := (z - vz)*yr + vz;
while y < y2 do
begin RLVEC(x-yt, y, x, y, 0.2); y := y + yy end
end
end;
if dy <= ye - yb then
begin
if ((vz-zb)*(vz-ze) <= 0) and ((vx-xb)*(vx-xe) <= 0) then else
begin
if vz > zb then y1 := zb else y1 := ze;
y2 := (y1 - vz)*(yb - vy)/(ye - vy) + vz;
xt := 40/yyyscal; yt := 40/xxxscal;
if vx > xb
then begin x1 := xe; x2 := xxe; xt := 0; xx := yt*1.5 end
else begin x1 := xb; x2 := xxb;
xt := -xt*1.1; yt := -yt; xx := yt*3 end;
RLVEC(x1, y1, x2, y2, 1); yy := yb/dy;
if yy < 0 then yy := - round(-yy - 0.49999)*dy
else yy := round(yy + 0.49999)*dy;
while yy <= ye do
begin
yr := (yb - vy)/(yy - vy);
x := (x1 - vx)*yr + vx; y := (y1 - vz)*yr + vz;
RLVEC(x, y, x+yt, y, 0.5);
if intyax
then INTNO(round(yy), 5, x+xx, y+xt)
else if dy > 0.08 then REALNO(yy, 5, 1, x+xx, y+xt)
else REALNO(yy, 7, 3, x+xx, y+xt);
yy := yy + dy
end;
if yticks > 1 then
begin
dy := dy/yticks; yy := yb/dy; yt := yt*0.7;
if yy < 0 then yy := - round(-yy - 0.49999)*dy
else yy := round(yy + 0.5)*dy;
while yy <= ye do
begin
yr := (yb - vy)/(yy - vy);
x := (x1 - vx)*yr + vx; y := (y1 - vz)*yr + vz;
RLVEC(x, y, x+yt, y, 0.2); yy := yy + dy
end
end
end
end
end
end; (* KOORD3D *)
procedure FLADE(xyzvar : xyzrec; var FUNC : matrix; var XX, YY : vektor;
ib, ie, jb, je, code : integer; width : real);
var
ZX, ZY : matrix;
X, Y : vektor;
yr : real;
i, i1, i2, j : integer;
flag : boolean;
begin
with xyzvar do
begin
for j := jb to je do
begin
yr := YY[j] - vy; yr := (yb - vy)/yr;
for i := ib to ie do
begin
X[i] := (XX[i] - vx)*yr + vx; ZX[i,j] := X[i];
Y[i] := (FUNC[i,j] - vz)*yr + vz; ZY[i,j] := Y[i]
end end;
if (code mod 4) <> 2 then
begin
i1 := ib; i2 := ie; flag := false;
if (code mod 8) >= 4 then
begin flag := true;
if vx > xe then i2 := i2 + 1
else if vx < xb then i1 := i1 - 1
end;
for j := jb to je do
begin
yr := YY[j] - vy; yr := (yb - vy)/yr;
for i := ib to ie do
begin X[i] := ZX[i,j]; Y[i] := ZY[i,j] end;
X[i1] := ZX[ib,j]; X[i2] := ZX[ie,j];
if flag then
begin if vx > xe then Y[i2] := (zb - vz)*yr + vz
else if vx < xb then
Y[i1] := (zb - vz)*yr + vz
end;
CURVE(X, Y, i1, i2, width)
end
end;
if vz < zb then yr := ze else yr := zb;
if (code mod 4) >= 2 then
begin flag := false; i1 := jb;
if code >= 8 then
begin flag := true; i1 := jb - 1; Y[i1] := yr end;
for i := ib to ie do
begin
for j := jb to je do
begin X[j] := ZX[i,j]; Y[j] := ZY[i,j] end;
if flag then X[i1] := X[jb];
CURVE(X, Y, i1, je, width)
end
end
end
end; (* FLADE *)
procedure ENDPL;
begin
writeln(ptfile, 'showpage')
end; (* ENDPL *)
(* syntaks version 1.0 15.10.99 *)
procedure START(ib : integer; txt : tekst; ltx : integer);
var dx, cdx, sdx : real; is : integer;
begin
dx := arctan(1)*4/nc; CKX[0] := 0; CKY[0] := -ht;
cdx := cos(dx); sdx := sin(dx);
for is := 1 to nc do
begin CKX[is] := CKX[is-1]*cdx - CKY[is-1]*sdx;
CKY[is] := CKY[is-1]*cdx + CKX[is-1]*sdx
end;
BEGINPL(ib); AREA(21, 30); x := 20;
KOORD(0, 220, 210, 0, 310, 300); y := 270; TIM(pt);
MESSAGE(txt, ltx, x, y); y := y - 15;
end; (* START *)
procedure LEFT(xp, yp : real);
var ip : integer;
begin
for ip := 0 to nc do
begin CLX[ip] := ht - CKX[ip] + xp;
CLY[ip] := CKY[ip] + yp
end;
CURVE(CLX, CLY, 0, nc, tk)
end; (* LEFT *)
procedure RIGHT(xp, yp : real);
var ip : integer;
begin
for ip := 0 to nc do
begin CLX[ip] := CKX[ip] - ht + xp;
CLY[ip] := CKY[ip] + yp
end;
CURVE(CLX, CLY, 0, nc, tk)
end; (* RIGHT *)
procedure RD(var xx : real; yy, ls : real; txt : tekst; ltx : integer);
var x2 : real;
begin
LEFT(xx, yy); x2 := xx + ls;
RLVEC(xx+ht, yy+ht, x2-ht, yy+ht, tk);
RLVEC(xx+ht, yy-ht, x2-ht, yy-ht, tk);
MESSAGE(txt, ltx, xx + tx, yy - ty); xx := x2;
RIGHT(xx, yy)
end; (* RD *)
procedure RECTANGLE(x1, y1, x2, y2, y3 : real);
var ir : integer;
begin
for ir := 0 to 5 do begin RXA[ir] := x1; RYA[ir] := y1 end;
RXA[2] := x2; RXA[3] := x2;
RYA[1] := y2; RYA[2] := y2;
RYA[3] := y3; RYA[4] := y3;
CURVE(RXA, RYA, 0, 5, tk)
end; (* RECTANGLE *)
procedure SQ(var xx : real; yy, ls : real; txt : tekst; ltx : integer);
begin
RECTANGLE(xx, yy, xx+ls, yy+ht, yy-ht);
MESSAGE(txt, ltx, xx + tx, yy - ty); xx := xx + ls
end; (*SQ *)
procedure AR(var xf, yf : real; xt, yt : real; pil : integer);
var xa, xb, ya, yb : real;
begin
RLVEC(xf, yf, xt, yt, tp);
if pil = 1 then
begin
if xt <> xf then
begin if xt > xf then xa := xt - spx else xa := xt + spx;
ya := yt + spy; yb := yt - spy; xb := xa
end else
begin if yt > yf then ya := yt - spx else ya := yt + spx;
xa := xt + spy; xb := xt - spy; yb := ya
end;
RLVEC(xa, ya, xt, yt, tp);
RLVEC(xb, yb, xt, yt, tp);
end;
xf := xt; yf := yt
end; (* AR *)
procedure ARX;
begin
AR(x, y, x+pl, y, 1)
end; (* ARX *)
