home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol270 / graphn88.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-05-22  |  2.6 KB  |  115 lines
  1. { [GRAPHN88.PAS of JUGPDS Vol.11] }
  2.  
  3. { Graphic Routines for NEC PC-8801
  4.     by K. Nakazato   Nov. 23, 1984   }
  5.  
  6. procedure gon;
  7. begin
  8.   port[$31]:=$3B
  9. end;
  10.  
  11. procedure goff;
  12. begin
  13.   port[$31]:=$37
  14. end;
  15.  
  16. procedure gcls;
  17. var wsp:integer;
  18. begin
  19.   inline( $F3/ $ED/ $73/ wsp/ $3E/ $5C/ $21/ $00/ $00/
  20.           $31/ $80/ $FE/ $06/ $FA/ $4F/ $ED/ $79/ $E5/
  21.           $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/
  22.           $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/
  23.           $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/ $E5/
  24.           $E5/ $E5/ $E5/ $E5/ $10/ $DE/ $3C/ $FE/ $5F/
  25.           $20/ $D1/ $D3/ $5F/ $ED/ $7B/ wsp/ $FB)
  26. end;
  27.  
  28.  
  29. procedure dotset(x,y,c:integer);
  30. begin
  31.   inline( $2A/   y/ $01/ $C8/ $00/ $54/ $5D/ $B7/ $ED/
  32.           $42/ $30/ $F9/ $EB/ $29/ $29/ $29/ $29/ $54/
  33.           $5D/ $29/ $29/ $19/ $11/ $00/ $C0/ $19/ $E5/
  34.           $2A/   x/ $01/ $80/ $02/ $54/ $5D/ $B7/ $ED/
  35.           $42/ $30/ $F9/ $EB/ $7D/ $E6/ $07/ $06/ $80/
  36.           $B7/ $28/ $05/ $CB/ $08/ $3D/ $20/ $FB/ $CB/
  37.           $3C/ $CB/ $1D/ $CB/ $3C/ $CB/ $1D/ $CB/ $3C/
  38.           $CB/ $1D/ $D1/ $19/ $3A/   c/ $57/ $0E/ $5C/
  39.           $F3/ $78/ $ED/ $79/ $CB/ $3A/ $38/ $04/ $2F/
  40.           $A6/ $18/ $01/ $B6/ $77/ $0C/ $79/ $FE/ $5F/
  41.           $20/ $ED/ $ED/ $79/ $FB)
  42. end;
  43.  
  44. procedure drawline(x1,y1,x2,y2,c:integer);
  45. var dx,dy,accx,accy,x,y:integer; sdx,sdy:boolean;
  46. begin
  47.   dx:=abs(x2-x1); dy:=abs(y2-y1);
  48.   if (dx>0) or (dy>0) then
  49.     while ((dx and $4000)=0) and ((dy and $4000)=0) do
  50.       begin dx:=dx shl 1; dy:=dy shl 1 end;
  51.   accx:=$4000; accy:=accx;
  52.   sdx:=x2>x1; sdy:=y2>y1;
  53.   x:=x1; y:=y1; dotset(x,y,c);
  54.   while (x<>x2) or (y<>y2) do
  55.     begin
  56.       accx:=accx+dx;
  57.       if accx<0 then
  58.         begin
  59.           if sdx then x:=x+1 else x:=x-1;
  60.           accx:=accx and $7FFF
  61.         end;
  62.       accy:=accy+dy;
  63.       if accy<0 then
  64.         begin
  65.           if sdy then y:=y+1 else y:=y-1;
  66.           accy:=accy and $7FFF
  67.         end;
  68.       dotset(x,y,c)
  69.     end
  70. end;
  71.  
  72. { turtle }
  73.  
  74. var x,y,angle,color:integer;
  75.  
  76. procedure moveto(x1,y1:integer);
  77. begin
  78.   if color>=0 then drawline(x+320,100-y,x1+320,100-y1,color);
  79.   x:=x1; y:=y1
  80. end;
  81.  
  82. procedure move(dest:integer);
  83. var angle1:real;
  84. begin
  85.   angle1:=angle*pi/180.0;
  86.   moveto(x+round(dest*cos(angle1)),y+round(dest*sin(angle1)))
  87. end;
  88.  
  89. procedure turnto(i:integer);
  90. begin
  91.   angle:=i mod 360
  92. end;
  93.  
  94. procedure turn(i:integer);
  95. begin
  96.   turnto(angle+i)
  97. end;
  98.  
  99. procedure pascolor(i:integer);
  100. begin
  101.   color:=i
  102. end;
  103.  
  104. procedure cls(g:boolean);
  105. var addr:integer; i,attr:byte;
  106. begin
  107.   if g then begin goff; gcls; gon end else clrscr
  108. end;
  109.  
  110. procedure initturtle;
  111. begin
  112.   cls(false); cls(true);
  113.   x:=0; y:=0; angle:=0; color:=-1
  114. end;
  115.