home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / bix / fillcirc.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-08-04  |  1.9 KB  |  70 lines
  1. {fast fillcircle routine using FastDraw or Turbo's DRAW}
  2. TITLE: Filling Circles
  3.  
  4.  procedure FillCircle(cx,cy,radius,color:integer);
  5.    var x,y,d: integer;
  6.        hold:array[0..199] of record yes,left,right:integer end;
  7.  
  8.     procedure Jot(x,y:integer);
  9.     begin
  10.      if y>=0 then {y axis clipping} if y<200 then
  11.       with hold[y] do
  12.        if yes=0 then begin yes:=1; left:=x;right:=x end
  13.        else if x<left then left:=x
  14.        else if x>right then right:=x;
  15.    end; {Jot}
  16.  
  17.     procedure EightPoints(x,y,ox,oy,c:integer);
  18.      const aspect = 50; {50 for 640x200,  25 for 320x200}
  19.      var  ax,px,py,nx,ny: integer;
  20.      begin
  21.       ax := (aspect*abs(x)+11) div 22;
  22.       px := ox + ax;   py := oy + y;
  23.       nx := ox - ax;   ny := oy - y;
  24.       Jot(px,py);
  25.       Jot(px,ny);
  26.       Jot(nx,py);
  27.       Jot(nx,ny);
  28.       ax := (aspect*abs(y)+11) div 22;
  29.       px := ox + ax;   py := oy + x;
  30.       nx := ox - ax;   ny := oy - x;
  31.       Jot(px,py);
  32.       Jot(px,ny);
  33.       Jot(nx,py);
  34.       Jot(nx,ny);
  35.     end;
  36.  
  37.      procedure fill;
  38.       var i:integer;
  39.        const maxx = 639; {use 639 for HiRes clipping, 319 for GraphMode}
  40.       begin
  41.        for i:=0 to 199 do
  42.        with hold[i] do
  43.        if yes=1 then
  44.         begin {x clipping with 0 to maxx}
  45.          if left<0 then left:=0;
  46.          if right>maxx then right:=maxx;
  47.          if left<=right then FastDraw(left,i,right,i,color);
  48.         end;
  49.       end; {Fill}
  50.  
  51. begin {FillCircle}
  52.    FillChar(Hold,SIZEOF(Hold),0); {set all yes's to zero}
  53.    x:=0;
  54.    y := radius;
  55.    d := 3 - 2*radius;
  56.    while x<y do begin
  57.       EightPoints(x,y,cx,cy,color);
  58.       if d<0 then
  59.          d := d + 4*x + 6
  60.       else begin
  61.          d := d + 4*(x-y) + 10;
  62.          y := y - 1
  63.       end;
  64.       x := x + 1
  65.    end; { while }
  66.    if x = y then
  67.       EightPoints(x,y,cx,cy,color);
  68.       Fill;
  69. end; {FillCircle}
  70.