home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / PASCAL-P / PLOTTER.LBR / PLOTTER.IZC / PLOTTER.INC
Text File  |  2000-06-30  |  15KB  |  381 lines
  1. (*             PLOTTER module   (Epson printer)              *)
  2. (* This module implements a virtual memory system for the    *)
  3. (* generated dot map.  A 71k temporary file is created.  The *)
  4. (* output file, if stored on disk, will be of similar size.  *)
  5. (*                                                           *)
  6. (* Entries are:                                              *)
  7. (*    plotopen;                  to initialize               *)
  8. (*    plotdot(x, y : integer);   Sets one dot at x,y         *)
  9. (*    plotline(ink : boolean; x, y : integer);               *)
  10. (*                               line from current to x,y    *)
  11. (*                               ink false to just move.     *)
  12. (*    loadfont(VAR f : text);    Install a Hershey font      *)
  13. (*    plotchar(ch : char, x, y : integer;                    *)
  14. (*             height, compress, angle : real)               *)
  15. (*                               puts one char at x,y, moves *)
  16. (*    plotclose(VAR f : text);   End and write results       *)
  17. (*   vdpi, hdpi, hdots        constants, dots/inch, hor size *)
  18. (*   vdots : integer          pagesize in dots.              *)
  19. (* NOTE: plotchar compensates for hdpi <> vdpi.              *)
  20. (*       angle is in radians, height & compress usually in   *)
  21. (*       the range 0.5 to 2.0. Compress 0.5 makes characters *)
  22. (*       narrower without affecting height, etc.             *)
  23. (* NOTE: (x,y) = (0,0) is bottom left dot position.  Plots   *)
  24. (*       may go off page, the output will be blanked.        *)
  25. (*                                                           *)
  26. (*$x+,h+ Allow declaration of "local" global data/procedures *)
  27. (* which are only visible to code which follows this area    *)
  28. (* The "allocate", "update", "reposition" procedures and the *)
  29. (* "(:nn:)" char definitions are PascalP specific.           *)
  30.  
  31.   CONST
  32.     (* Alter the following group to suit your needs.              *)
  33.     (* printer characteristics, dots per inch vertical/horizontal *)
  34.     vdpi          = 72;
  35.     hdpi          = 120;            (* only ratio used in this module *)
  36.     maxstrip      = 80;      {10  for debug}
  37.     hdots         = 900;     {127 for debug}
  38.     stripdeep     = 8;                           (* For Epson printer *)
  39.     maxfont       = 2905;        (* max. storage available for a font *)
  40.  
  41.     maxloaded     = maxstrip;   (* smaller can prevent excess loading *)
  42.     filling       = false;            (* fill in dots on line drawing *)
  43. {}  nul           = (:0:);
  44. {}  dc1           = (:17:);                   (* Ascii control chars. *)
  45. {}  esc           = (:27:);
  46. (*$s+ back to standard usage *)
  47.     debuga        = false;                   (* virtual memory scheme *)
  48.  
  49.   TYPE
  50.     afont         = ARRAY[1..maxfont] OF integer;
  51.  
  52.     striptr       = ^strip;
  53.     strip         = RECORD
  54.       empty         : boolean;
  55.       data          : ARRAY[1..hdots] OF char;
  56.       END; (* strip *)
  57.  
  58.   VAR
  59.     vdots,                            (* total vertical dot positions *)
  60.     peakloaded,                                 (* total memory usage *)
  61.     stripsloaded  : integer;             (* count of strips in memory *)
  62.     laststrip     : 1..maxstrip;         (* for virtual memory system *)
  63.     stripctl      : ARRAY[1..maxstrip] OF striptr;  (* NIL if in file *)
  64.     stripfile     : FILE OF strip;       (* virtual memory for strips *)
  65.     bit           : ARRAY[1..stripdeep] OF integer;    (* translation *)
  66.     xnow, ynow    : integer;                (* present "pen" position *)
  67.     doubledots,                             (* count dots overwritten *)
  68.     dotcount      : integer;                     (* count dots placed *)
  69.     aspect        : real;            (* vertical/horizontal dots/unit *)
  70.     font          : afont;       (* internal storage for Hershey font *)
  71.  
  72.   (* 1---------------1 *)
  73.  
  74.   PROCEDURE loadfont(VAR f : text);
  75.  
  76.     VAR
  77.       i, chstart,
  78.       hersheynum   : integer;
  79.       ch           : char;
  80.  
  81.     BEGIN (* loadfont *)
  82.     font[1] := 0; font[2] := 0;  (* default empty *)
  83.     IF exists(f) THEN BEGIN
  84.       writeln('Loading font');
  85.       ch := 'A'; i := 0; chstart := 1;
  86.       WHILE NOT ( eof(f) OR (ch = ' ') ) DO BEGIN
  87.         chstart := succ(i);
  88.         read(f, ch, ch, hersheynum, font[chstart+2], font[chstart+3]);
  89.         font[succ(chstart)] := ord(ch); i := chstart+3;
  90.         REPEAT
  91.           IF (i - (chstart+3)) MOD 10 = 0 THEN readln(f);
  92.           i := succ(i); read(f, font[i]);
  93.         UNTIL abs(font[i]) >= 10000;
  94.         readln(f); font[chstart] := succ(i); END;
  95.       font[chstart] := 0; write(i : 1, ' integers in font'); END
  96.     ELSE write('No font');
  97.     writeln;
  98.     END; (* loadfont *)
  99.  
  100.   (* 1---------------1 *)
  101.  
  102.   PROCEDURE keepstrip(n : integer);
  103.  
  104.     BEGIN (* keepstrip *)
  105. {}  reposition(stripfile, pred(n));
  106.     stripfile^ := stripctl[n]^; put(stripfile);
  107.     stripctl[n] := NIL;    (* mark not in memory *)
  108.     stripsloaded := pred(stripsloaded);
  109.     END; (* keepstrip *)
  110.  
  111.   (* 1---------------1 *)
  112.  
  113.   PROCEDURE getstrip(n : integer);
  114.  
  115.     VAR
  116.       i      : integer;
  117.       margin : ARRAY[1..128] OF integer;
  118.       (* a dummy, to ensure stack space remains after allocate *)
  119.       (* This is over and above the systems built in margin.   *)
  120.  
  121.     BEGIN (* getstrip *)
  122.     IF stripctl[n] = NIL THEN BEGIN  (* otherwise in memory *)
  123. {}    IF stripsloaded < maxloaded THEN allocate(stripctl[n]);
  124.       IF stripctl[n] = NIL THEN BEGIN (* no more memory available *)
  125.         IF n > laststrip THEN BEGIN (* find space *)
  126.           i := 1;
  127.           WHILE stripctl[i] = NIL DO i := succ(i); END
  128.         ELSE BEGIN
  129.           i := maxstrip;
  130.           WHILE stripctl[i] = NIL DO i := pred(i); END;
  131.         IF debuga THEN writeln('Flushing ', i : 1, ' for ', n : 1);
  132.         stripctl[n] := stripctl[i]; keepstrip(i); END;
  133. {}    reposition(stripfile, pred(n));
  134.       get(stripfile); stripctl[n]^ := stripfile^;
  135.       stripsloaded := succ(stripsloaded);
  136.       IF stripsloaded > peakloaded THEN peakloaded := stripsloaded; END;
  137.     laststrip := n;
  138.     END; (* getstrip *)
  139.  
  140.   (* 1---------------1 *)
  141.  
  142.   PROCEDURE plotopen;
  143.  
  144.     VAR
  145.       i, j       : integer;
  146.  
  147.     BEGIN (* plotopen *)
  148.     j := 1; vdots := maxstrip * stripdeep;
  149.     FOR i := 1 TO 8 DO BEGIN  (* init printer dots translation *)
  150.       bit[i] := j; j := j+j; END;
  151.  
  152.     (* init strip control array *)
  153.     FOR i := 1 TO maxstrip DO stripctl[i] := NIL;
  154.     new(stripctl[1]);
  155.     stripsloaded := 1; peakloaded := 1; laststrip := 1;
  156.  
  157.     (* init stripfile to empty & prepare for random access *)
  158.     (* uses PascalP random access procedures *)
  159.     WITH stripctl[1]^ DO BEGIN
  160.       empty := true;
  161.       FOR i := 1 TO hdots DO data[i] := nul; END;
  162.     rewrite(stripfile);
  163.     FOR i := 1 TO maxstrip DO BEGIN
  164.       stripfile^ := stripctl[1]^; put(stripfile); END;
  165. {}  update(stripfile);           (* now initialized and random access *)
  166.  
  167.     xnow := 0; ynow := 0;                  (* position at bottom left *)
  168.     dotcount := 0; doubledots := 0;
  169.     aspect := vdpi / hdpi;                   (* correct hor/vert skew *)
  170.     END; (* plotopen *)
  171.  
  172.   (* 1---------------1 *)
  173.  
  174.   FUNCTION onpage(x, y : integer) : boolean;
  175.  
  176.     BEGIN (* onpage *)
  177.     onpage := (x >= 0) AND (x < hdots) AND
  178.               (y >= 0) AND (y < vdots);
  179.     END; (* onpage *)
  180.  
  181.   (* 1---------------1 *)
  182.  
  183.   PROCEDURE plotdot(x, y : integer);     (* plot 1 dot at x, y *)
  184.   (* bottom left is (x, y) = (0,0).                            *)
  185.   (* Past top right (x, y) = (hdots, maxstrip * stripdeep) *)
  186.  
  187.     VAR
  188.       stripnum,
  189.       deltay, n     : integer;
  190.  
  191.     BEGIN (* plotdot *)
  192.     IF onpage(x, y) THEN BEGIN
  193.       stripnum := maxstrip - (y DIV stripdeep);
  194.       deltay := y MOD stripdeep; x := succ(x);        (* 1..hdots *)
  195.       n := bit[succ(y MOD stripdeep)];
  196.       getstrip(stripnum);
  197.       WITH stripctl[stripnum]^ DO BEGIN        (* Now set the bit *)
  198.  
  199. (* Standard Pascal code *)
  200. {       IF odd(ord(data[x]) DIV n) THEN      }
  201. (* PascalP specific code *)
  202.         IF odd(lsr(ord(data[x]), deltay)) THEN
  203.  
  204.           doubledots := succ(doubledots)
  205.         ELSE data[x] := chr(ord(data[x]) + n);
  206.         empty := false; END;
  207.       dotcount := succ(dotcount); END;
  208.     END; (* plotdot *)
  209.  
  210.   (* 1---------------1 *)
  211.  
  212.   PROCEDURE plotline(ink : boolean; x, y : integer);
  213.   (* drawline from present location to (x, y) using ink *)
  214.  
  215.     VAR
  216.       err,
  217.       deltax, deltay,
  218.       ix, iy,
  219.       xend, yend      : integer;
  220.  
  221.     BEGIN (* plotline *)
  222.     IF ink THEN (* check not totally off page *)
  223.       IF NOT (((y < 0)      AND (ynow < 0)     ) OR
  224.               ((y >= vdots) AND (ynow >= vdots)) OR
  225.               ((x < 0)      AND (xnow < 0)     ) OR
  226.               ((x >= hdots) AND (xnow >= hdots))) THEN BEGIN
  227.         deltax := x - xnow; deltay := y - ynow;
  228.         ix := xnow; iy := ynow; xend := x; yend := y;
  229.         IF deltax < 0 THEN BEGIN (* so x always increasing *)
  230.           ix := x; x := xnow; deltax := -deltax;
  231.           iy := y; y := ynow; deltay := -deltay; END;
  232.         IF deltay >= 0 THEN
  233.           IF deltax >= deltay THEN BEGIN
  234. {0..45}     err := -deltax DIV 2;
  235.             FOR ix := ix TO x DO BEGIN
  236.               plotdot(ix, iy); err := err + deltay;
  237.               IF err > 0 THEN BEGIN
  238.                 iy := succ(iy); err := err - deltax;
  239.                 IF filling THEN plotdot(ix, iy); END;
  240.               END;
  241.             END
  242.           ELSE BEGIN
  243. {45..90}    err := -deltay DIV 2;
  244.             FOR iy := iy TO y DO BEGIN
  245.               plotdot(ix, iy); err := err + deltax;
  246.               IF err > 0 THEN BEGIN
  247.                 ix := succ(ix); err := err - deltay;
  248.                 IF filling THEN plotdot(ix, iy); END;
  249.               END;
  250.             END
  251.         ELSE BEGIN
  252.           IF deltax >= -deltay THEN BEGIN
  253. {-45..0}    err := -deltax DIV 2;
  254.             FOR ix := ix TO x DO BEGIN
  255.               plotdot(ix, iy); err := err - deltay;
  256.               IF err > 0 THEN BEGIN
  257.                 iy := pred(iy); err := err - deltax;
  258.                 IF filling THEN plotdot(ix, iy); END;
  259.               END;
  260.             END
  261.           ELSE BEGIN
  262. {-90..-45}  err := deltay DIV 2;
  263.             FOR iy := iy DOWNTO y DO BEGIN
  264.               plotdot(ix, iy); err := err + deltax;
  265.               IF err > 0 THEN BEGIN
  266.                 ix := succ(ix); err := err + deltay;
  267.                 IF filling THEN plotdot(ix, iy); END;
  268.               END;
  269.             END;
  270.           END;
  271.         x := xend; y := yend; END;
  272.     xnow := x; ynow := y;
  273.     END; (* plotline *)
  274.  
  275.   (* 1---------------1 *)
  276.  
  277.   PROCEDURE plotchar(ch : char; x, y : integer; (* start point for ch *)
  278.                      compress,         (* < 1.0 squashes horizontally *)
  279.                      height,    (* < 1.0 reduces char. size from font *)
  280.                      angle : real); (* ccw radians, at which to write *)
  281.                                     (* 0 is horizontal (normal),      *)
  282.                                     (* pi is upside down r to left.   *)
  283.   (* leaves "pen" positioned ready for next character.                *)
  284.  
  285.     CONST
  286.       xstart       = 10;       (* the font letter base point *)
  287.       ystart       = 35;
  288.  
  289.     VAR
  290.       j     : integer;
  291.  
  292.     (* 2---------------2 *)
  293.  
  294.     PROCEDURE dostroke(coord : integer);
  295.     (* interprets, handling size, compression, angle *)
  296.  
  297.       VAR
  298.         ink          : boolean;
  299.         xfont, yfont : real;
  300.  
  301.       BEGIN (* dostroke *)
  302.       ink := coord >= 0; coord := abs(coord) MOD 10000;
  303.       xfont := (coord DIV 100 - xstart) * height * compress;
  304.       yfont := (coord MOD 100 - ystart) * height;
  305.       plotline(ink, x + round(xfont * cos(angle)
  306.                             - yfont * sin(angle)),
  307.                     y + round(aspect * (yfont * cos(angle)
  308.                                       + xfont * sin(angle))));
  309.       END; (* dostroke *)
  310.  
  311.     (* 2---------------2 *)
  312.  
  313.     PROCEDURE drawchar(place : integer);
  314.     (* scans the font specifications *)
  315.  
  316.       VAR
  317.         coord,
  318.         fontwidth,
  319.         fontheight   : integer;
  320.  
  321.       BEGIN (* drawchar *)
  322.       (* 0 is link, 1 is char *)
  323.       fontheight := font[place+2]; fontwidth := font[place+3];
  324.       place := place + 3;  (* 4 up are strokes *)
  325.       REPEAT
  326.         place := succ(place); coord := font[place]; dostroke(coord);
  327.       UNTIL abs(coord) >= 10000;
  328.       END; (* drawchar *)
  329.  
  330.     (* 2---------------2 *)
  331.  
  332.     BEGIN (* plotchar *)
  333.     IF (ch = ' ') AND (font[2] <> 0) THEN     (* fake it *)
  334.       dostroke(-100 * (font[3] + xstart) - ystart)
  335.     ELSE BEGIN
  336.       j := 1;
  337.       WHILE (font[succ(j)] <> ord(ch)) AND (font[j] <> 0) DO
  338.         j := font[j];
  339.       IF font[succ(j)] = ord(ch) THEN drawchar(j) (* found descriptor *)
  340.       ELSE BEGIN
  341.         IF ch IN [' '..'~'] THEN write('''', ch, '''')
  342.         ELSE write('<', ord(ch) : 1, '>');
  343.         writeln('  not in font'); END;
  344.       END;
  345.     END; (* plotchar *)
  346.  
  347.   (* 1---------------1 *)
  348.  
  349.   PROCEDURE plotclose(VAR f : text);             (* write result to f *)
  350.  
  351.     CONST
  352.       smax      = 250;       (* max allowable string length for write *)
  353.  
  354.     VAR
  355.       i, j, k   : integer;
  356.  
  357.     BEGIN (* plotclose *)
  358.     FOR i := 1 TO maxstrip DO
  359.       IF stripctl[i] <> NIL THEN keepstrip(i);
  360.     close(stripfile);           (* overkill, ensure random write done *)
  361.     reset(stripfile);
  362.   { write(f, dc1, dc1, esc, '@'); }            (* reset Epson printer *)
  363. {}{ delay(1);                     }          (* let reset take effect *)
  364.     write(f, esc, 'A', chr(8), chr(13));        (* 8 dot line spacing *)
  365.     FOR i := 1 TO maxstrip DO BEGIN
  366.       IF NOT stripfile^.empty THEN BEGIN
  367.         write(f, esc, 'L', chr(hdots MOD 256), chr(hdots DIV 256));
  368.  
  369.         (* PascalP specific coding, strings cannot exceed 255 chars *)
  370.         (* String writes are much faster than char by char writes.  *)
  371.         FOR j := 0 TO pred(hdots DIV smax) DO
  372. (*$s-,d- non-std, avoid range errors in last, field spec guards it *)
  373. {}        write(f, stripfile^.data[succ(smax * j) FOR smax]);
  374.         write(f,
  375. {}           stripfile^.data[succ((hdots DIV smax) * smax) FOR smax]
  376. (*$s+,d+*)         : hdots MOD smax); END;
  377.       writeln(f);
  378.       IF i < maxstrip THEN get(stripfile); END;
  379.     END; (* plotclose *)
  380. (*$x- restore input options, END of plotter module *)
  381. Ä