home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / KPGRAF.ZIP / KPGRAF.LIB
Encoding:
Text File  |  1987-11-08  |  4.3 KB  |  155 lines
  1. { ********************************************************************** }
  2. {                                                                        }
  3. {  TURBO Pascal Library of Kaypro Screen Graphics Routines - adapted     }
  4. {  from the SBASIC  originals by : John Lucas   27 Sept. 1984            }
  5. {                                                                        }
  6. { ********************************************************************** }
  7.  
  8. procedure seton (att : integer);
  9. begin
  10.    write(chr(27),'B',chr(att))
  11. end;
  12.  
  13. procedure setoff (att : integer);
  14. begin
  15.    write(chr(27),'C',chr(att))
  16. end;
  17.  
  18. procedure pixon (vert,horz : integer);
  19. begin
  20.    write(chr(27),'*',chr((vert + 31)),chr((horz + 31)))
  21. end;
  22.  
  23. procedure pixoff (vert,horz : integer);
  24. begin
  25.    write(chr(27),' ',chr(vert + 31),chr(horz + 31))
  26. end;
  27.  
  28. procedure lineon (v1,h1,v2,h2 : integer);
  29. begin
  30.    write(chr(27),'L',chr(v1 + 31),chr(h1 + 31),chr(v2 + 31),chr(h2 + 31))
  31. end;
  32.  
  33. procedure lineoff (v1,h1,v2,h2 : integer);
  34. begin
  35.    write(chr(27),'D',chr(v1 + 31),chr(h1 + 31),chr(v2 +31),chr(h2 + 31))
  36. end;
  37.  
  38. function sroot (n : integer): integer;
  39. var
  40.    root1,root2 : integer;
  41. begin
  42.    root1 := n; root2 := 1;
  43.    while (root1 > root2) do
  44.    begin
  45.       root1 := trunc((root1 + root2)/2);
  46.       root2 := trunc(n/root1)
  47.    end;
  48.    sroot := root1
  49. end;
  50.  
  51. procedure circle (horz,vert,radius : integer);
  52. var
  53.    x,y,offset : integer;
  54. begin
  55.    offset := trunc((radius * 100)/141);
  56.    pixon((horz + radius - 1),vert);
  57.    pixon((horz - radius + 1),vert);
  58.  
  59.    for x := 1 to offset do
  60.    begin
  61.       y := sroot(sqr(radius) - sqr(x));
  62.       pixon((horz + y),(vert + x));
  63.       pixon((horz + y),(vert - x));
  64.       pixon((horz - y),(vert + x));
  65.       pixon((horz - y),(vert - x));
  66.    end;
  67.  
  68.    pixon(horz,(vert + radius - 1));
  69.    pixon(horz,(vert - radius + 1));
  70.  
  71.    for y := 1 to offset do
  72.    begin
  73.       x := sroot(sqr(radius) - sqr(y));
  74.       pixon((horz + y),(vert + x));
  75.       pixon((horz + y),(vert - x));
  76.       pixon((horz - y),(vert + x));
  77.       pixon((horz - y),(vert - x));
  78.    end;
  79. end;
  80.  
  81. procedure rectangle (y,x,ht,wd : integer);
  82. begin
  83.    lineon(y,x,(y + ht),x);
  84.    lineon(y,(x + wd),(y + ht),(x + wd));
  85.    lineon(y,x,y,(x + wd));
  86.    lineon((y + ht),x,(y + ht),(x + wd));
  87. end;
  88.  
  89. procedure square (y,x,side : integer);
  90. begin
  91.    rectangle(y,x,side,side)
  92. end;
  93.  
  94. procedure bar (refy,refx,ht,wd,depth,inside,vertp,horzp : integer);
  95. var
  96.    i,temp,empty,full,x,y : integer;
  97.    ref,center,rear       : array[1..2] of integer;
  98. begin
  99.    x := 1; y := 2; full := 1; empty := 0;
  100.    ref[x] := refx; ref[y] := refy;
  101.    center[x] := refx + (wd * horzp);
  102.    center[y] := refy + (ht * vertp);
  103.    rear[x] := center[x] + (depth * horzp);
  104.    rear[y] := center[y] + (depth * vertp);
  105.  
  106.    if (inside = empty) then
  107.    begin
  108.       for i := ref[x] to center[x] do
  109.          if (i mod horzp) = 0 then
  110.             lineoff(ref[y],i,center[y],i);
  111.  
  112.       for i := 0 to (wd * horzp) do
  113.          if (i mod horzp) = 0 then
  114.             lineoff(center[y],(center[x] - i),rear[y],(rear[x] - i));
  115.  
  116.       for i := 0 to (ht * vertp) do
  117.          if (i mod vertp) = 0 then
  118.             lineoff((center[y] - i),center[x],(rear[y] - i),rear[x]);
  119.  
  120.       lineon(ref[y],ref[x],center[y],ref[x]);
  121.       lineon(ref[y],ref[x],ref[y],center[x]);
  122.       lineon(center[y],center[x],center[y],ref[x]);
  123.       lineon(center[y],center[x],ref[y],center[x]);
  124.  
  125.       lineon(center[y],center[x],rear[y],rear[x]);
  126.  
  127.       lineon(ref[y],center[x],(rear[y] - ht * vertp),rear[x]);
  128.       lineon(center[y],ref[x],rear[y],(rear[x] - wd * horzp));
  129.  
  130.       lineon(rear[y],rear[x],(rear[y] - ht * vertp),rear[x]);
  131.       lineon(rear[y],rear[x],rear[y],(rear[x] - wd * horzp))
  132.    end;
  133.  
  134.    if (inside = full) then
  135.    begin
  136.       for i := ref[x] to center[x] do
  137.          if (i mod horzp) = 0 then
  138.             lineon(ref[y],i,center[y],i);
  139.  
  140.       for i := 0 to (wd * horzp) do
  141.          if (i mod horzp) = 0 then
  142.             lineon(center[y],(center[x] - i),rear[y],(rear[x] - i));
  143.  
  144.       for i := 0 to (ht * vertp) do
  145.          if (i mod vertp) = 0 then
  146.             lineon((center[y] - i),center[x],(rear[y] - i),rear[x]);
  147.  
  148.       lineoff(center[y],center[x],center[y],ref[x]);
  149.       lineoff(center[y],center[x],ref[y],center[x]);
  150.  
  151.       lineoff(center[y],center[x],rear[y],rear[x]);
  152.  
  153.    end;
  154. end;
  155.