attachment to bugreport: virker, alfaplot, syntaks - Gpc

4 Nov 1999


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