home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / SWAG9605.DDD / 0027_Interesting Circle Graphics.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-05-31  |  3.5 KB  |  187 lines
  1. {$n+,e-,g+,x+,r-,q-,s-,a+}
  2.                           { NOTE See the end of document for more .. }
  3.  
  4. uses crt,gru;
  5.              {NOTE : GRU can be found in GRAPHICS.SWG }
  6.  
  7. var
  8.   x,y,work:word;
  9.   workp:pointer;
  10.   p1,p2:paltype;
  11.  
  12. procedure plot3(x,y:word;c:byte);
  13. begin
  14.   plot2((160+x),(100+y),work,c);
  15. end;
  16.  
  17. function abort:boolean;
  18. begin
  19.   {$b-}
  20.   abort:=false;
  21.   abort:=(keypressed)and(readkey=#27);
  22. end;
  23.  
  24. begin
  25.   getmem(workp,64000); work:=seg(workp^);
  26.   setmode($13);
  27.   for x:=1 to 255 do
  28.     setpal(x,(x shl 2)+25,(x shl 1)-1,x);
  29.   clear386(work,0);
  30.   repeat
  31.     y:=0;
  32.     repeat
  33.       for x:=0 to 360 do
  34.       begin
  35.         plot3(round(cos(x)*y),round(sin(x)*y),round((y shl 1)+(sqrt(x))));
  36.       end;
  37.       line2(0,199,319,199,work,0);
  38.       smooth(work);
  39.       flip386(work,vidseg);
  40.       inc(y);
  41.     until(y>90)or(keypressed);
  42.   until(abort);
  43.   readkey;
  44.   setmode($03);
  45. end.
  46.  
  47. { ----------------------  CIRCLE2 ----------------------- }
  48.  
  49. {$n+,e-,g+,x+,r-,q-,s-,a+}
  50. uses crt,gru;
  51.  
  52. var
  53.   ctab,stab:array[0..360]of real;
  54.   x,y,work:word;
  55.   workp:pointer;
  56.   p1,p2:paltype;
  57.  
  58. procedure plot3(x,y:word;c:byte);
  59. begin
  60.   plot2((160+x),(100+y),work,c);
  61. end;
  62.  
  63. function abort:boolean;
  64. begin
  65.   {$b-}
  66.   abort:=false;
  67.   abort:=(keypressed)and(readkey=#27);
  68. end;
  69.  
  70. begin
  71.   for x:=0 to 360 do
  72.   begin
  73.     stab[x]:=(sin(x)*1);
  74.     ctab[x]:=(cos(x)*1);
  75.   end;
  76.   getmem(workp,64000); work:=seg(workp^);
  77.   setmode($13);
  78.   for x:=1 to 255 do
  79.     setpal(x,(x shl 2)+25,(x shl 1)-1,x);
  80.   clear386(work,0);
  81.   repeat
  82.     y:=0;
  83.     repeat
  84.       for x:=0 to 360 do
  85.       begin
  86.         plot3(round(ctab[x]*y),round(stab[x]*y),round((y shl 1)+(sqrt(x))));
  87.       end;
  88.       line2(0,199,319,199,work,0);
  89.       smooth(work);
  90.       flip386(work,vidseg);
  91.       inc(y);
  92.     until(y>90)or(keypressed);
  93.   until(abort);
  94.   setmode($03);
  95. end.
  96.  
  97. {------------------------------------  CIRCLE3  ------------------- }
  98.  
  99. {$n+,e-,g+,x+,r-,q-,s-,a+}
  100. uses crt,gru;
  101.  
  102. var
  103.   scrofs:array[0..199]of word; { Holding screen offsets. }
  104.   ctab,stab:array[0..360]of real;
  105.   x,y,c,work:word;
  106.   workp:pointer;
  107.   p1,p2:paltype;
  108.  
  109. procedure pload2(const x,y,where:word;const c:byte); assembler;
  110. asm
  111.   cmp clipon,0
  112.   je @@sc
  113.   mov ax,[x]
  114.   cmp ax,cx1
  115.   jb @@exit
  116.   cmp ax,cx2
  117.   ja @@exit
  118.   mov ax,[y]
  119.   cmp ax,cy1
  120.   jb @@exit
  121.   cmp ax,cy2
  122.   ja @@exit
  123.   @@sc: { SkipCheck :-) }
  124.   mov ax,where
  125.   mov es,ax
  126.   mov bx,[y]
  127.   shl bx,1
  128.   mov di,word ptr[scrofs+bx]
  129.   add di,[x]
  130.   mov al,[c]
  131.   add es:[di],al
  132. @@exit:
  133. end;
  134.  
  135. procedure plot3(x,y:word;c:byte);
  136. var
  137.   c1,c2:byte;
  138. begin
  139.   for c1:=0 to 3 do
  140.     for c2:=0 to 3 do
  141.     begin
  142. {      plot2((160+x)+c1,(100+y)+c2,work,c);}
  143.       pload2((160+x),(100+y),work,c);
  144.     end;
  145. end;
  146.  
  147. function abort:boolean;
  148. begin
  149.   {$b-}
  150.   abort:=false;
  151.   abort:=(keypressed)and(readkey=#27);
  152. end;
  153.  
  154. begin
  155.   randomize;
  156.   for x:=0 to 360 do
  157.   begin
  158.     stab[x]:=(sin(x)*1);
  159.     ctab[x]:=(cos(x)*1);
  160.   end;
  161.   for x:=0 to 199 do scrofs[x]:=x*320;
  162.   getmem(workp,64000); work:=seg(workp^);
  163.   setmode($13);
  164.   for x:=1 to 255 do
  165.     setpal(x,(x shl 2)+25,(x shl 1)-1,x);
  166.   clear386(work,0);
  167.   c:=0;
  168.   repeat
  169.     y:=0;
  170.     repeat
  171.       for x:=0 to 360 do
  172.       begin
  173.         plot3(round(ctab[x]*y),round(stab[x]*y),round((y shl 1)+(sqrt(x))));
  174.       end;
  175.       line2(0,199,319,199,work,0);
  176.       inc(c);
  177.       if(c>4)then
  178.       begin
  179.         c:=0;
  180.         smooth(work);
  181.       end;
  182.       flip386(work,vidseg);
  183.       inc(y);
  184.     until(y>90)or(keypressed);
  185.   until(abort);
  186.   setmode($03);
  187. end.