home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol270 / graphn80.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-05-22  |  1.8 KB  |  91 lines
  1. { [GRAPHN80.PAS of JUGPDS Vol.11] }
  2.  
  3. { Semi-Ggraphic Routines for NEC PC-8001
  4.           by K. Nakazato   Nov. 23, 1984   }
  5.  
  6. procedure cls(g:boolean);
  7. var addr:integer; i,attr:byte;
  8. begin
  9.   clrscr; addr:=$F350;
  10.   if g then attr:=$80 else attr:=0;
  11.   for i:=1 to 24 do begin
  12.     mem[addr]  :=1;  mem[addr+1]:=attr;
  13.     mem[addr+2]:=81; addr:=addr+$78
  14.   end
  15. end;
  16.  
  17. procedure dotset(x,y,color:integer);
  18. var ad:integer; bit:byte;
  19. begin
  20.   x:=x mod 160; y:= y mod 100;
  21.   ad:=$F300+(y and $fc)*30+x shr 1;
  22.   bit:=1 shl ( y and 3+(x and 1) shl 2);
  23.   if color>0 then mem[ad]:=mem[ad] or bit
  24.   else if color=0 then mem[ad]:=mem[ad] and not bit
  25. end;
  26.  
  27. procedure drawline(x1,y1,x2,y2,c:integer);
  28. var dx,dy,accx,accy,x,y:integer; sdx,sdy:boolean;
  29. begin
  30.   dx:=abs(x2-x1); dy:=abs(y2-y1);
  31.   if (dx>0) or (dy>0) then
  32.     while (dx and $4000=0) and (dy and $4000=0) do
  33.       begin dx:=dx shl 1; dy:=dy shl 1 end;
  34.   accx:=$4000; accy:=accx;
  35.   sdx:=x2>x1; sdy:=y2>y1;
  36.   x:=x1; y:=y1; dotset(x,y,c);
  37.   while (x<>x2) or (y<>y2) do
  38.     begin
  39.       accx:=accx+dx;
  40.       if accx<0 then
  41.         begin
  42.           if sdx then x:=x+1 else x:=x-1;
  43.           accx:=accx and $7FFF
  44.         end;
  45.       accy:=accy+dy;
  46.       if accy<0 then
  47.         begin
  48.           if sdy then y:=y+1 else y:=y-1;
  49.           accy:=accy and $7FFF
  50.         end;
  51.       dotset(x,y,c)
  52.     end
  53. end;
  54.  
  55. { turtle }
  56.  
  57. var x,y,angle,color:integer;
  58.  
  59. procedure moveto(x1,y1:integer);
  60. begin
  61.   if color>=0 then drawline(x+80,49-y,x1+80,49-y1,color);
  62.   x:=x1; y:=y1
  63. end;
  64.  
  65. procedure move(dest:integer);
  66. var angle1:real;
  67. begin
  68.   angle1:=angle*pi/180.0;
  69.   moveto(x+round(dest*cos(angle1)),y+round(dest*sin(angle1)))
  70. end;
  71.  
  72. procedure turnto(i:integer);
  73. begin
  74.   angle:=i mod 360
  75. end;
  76.  
  77. procedure turn(i:integer);
  78. begin
  79.   turnto(angle+i)
  80. end;
  81.  
  82. procedure pascolor(i:integer);
  83. begin
  84.   color:=i
  85. end;
  86.  
  87. procedure initturtle;
  88. begin
  89.   cls(true); x:=0; y:=0; angle:=0; color:=-1
  90. end;
  91.