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 *)