fpc/rtl/go32v2/ppi/fill.ppi

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1993,97 by the Free Pascal development team.

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{$ifopt S+}
{$define StackCkeckOn}
{$endif opt S+}

procedure floodfill(x,y:integer; border:longint);

var bordercol     : longint;
    fillcol,fillbkcol : longint;
    viewport      : viewporttype;
    offset        : longint;
    test_bkfill   : boolean;

{$S+}
{ Fill is very recursive !! }
{ And it fails sometimes !! }

procedure fill(x,y:integer);
var start,ende,xx : integer;
    col           : longint;

begin
{$ifdef GraphDebug}
  if (x>viewport.x2) or (x<viewport.x1) or
     (y>viewport.y2) or (y<viewport.y1) then
    begin
       Writeln(stderr,'Wrong value in Fill(',x,',',y,')');
       exit;
    end;
{$endif def GraphDebug}
  xx:=x; col:=getpixeli(xx,y);
{$ifdef GraphDebug}
     Writeln(stderr,'Fill ',x,' ',y,' ',hexstr(col,8));
{$endif def GraphDebug}
  if (col=bordercol) or (col=fillcol) or
     (test_bkfill and (col=fillbkcol)) then
    exit;
  while (col<>bordercol) and (xx > viewport.x1) and
     (col<>fillcol) and (not test_bkfill or (col<>fillbkcol))
    do begin
      xx:=xx-1; col:=getpixeli(xx,y);
    end;
  if (col<>bordercol) and (col<>fillcol) and
     (not test_bkfill or (col<>fillbkcol)) then
    start:=xx
  else
    start:=xx+1;

  xx:=x;
  col:=getpixeli(xx,y);
  while (col<>bordercol) and (xx < viewport.x2) and (col<>fillcol)
      and (not test_bkfill or (col<>fillbkcol))
    do begin
      xx:=xx+1; col:=getpixeli(xx,y);
    end;
  if (col<>bordercol) and (col<>fillcol) and
     (not test_bkfill or (col<>fillbkcol)) then
    ende:=xx
  else
    ende:=xx-1;

{$ifdef GraphDebug}
     Writeln(stderr,'Pattern ',start,' ',ende,' ',y);
{$endif def GraphDebug}
  patternline(start,ende,y);
{$ifdef GraphDebug}
     Writeln(stderr,'Fill  after Patterline ',x,' ',y,' ',hexstr(getpixel(x,y),8));
{$endif def GraphDebug}
  offset:=(y * _maxy + start) shr 8;

  if (y > viewport.y1)
  then begin
    xx:=start;
    repeat
      col:=getpixeli(xx,y-1);
      if (col<>bordercol) and (col<>fillcol) and
         (not test_bkfill or (col<>fillbkcol))
      then begin
        fill(xx,y-1);
        break;
      end;
      xx:=xx+1;
    until xx > ende;
  end;

  if (y<viewport.y2) then
   begin
    xx:=start;
    repeat
      col:=getpixeli(xx,y+1);
      if (col<>bordercol) and (col<>fillcol) and
         (not test_bkfill or (col<>fillbkcol)) then
        fill(xx,y+1);
      xx:=xx+1;
    until xx > ende;
  end;

end;

begin
{$ifdef GraphDebug}
     Writeln(stderr,'FloodFill start ',x,' ',y);
{$endif def GraphDebug}
  {$ifdef NOFILL}
  exit;
  {$endif NOFILL}
  {fillchar(buffermem^,buffersize,0);
    not used !! }
  if aktviewport.clip then viewport:=aktviewport else viewport:=aktscreen;
  { reject invalid points !! }

  viewport.x2:=viewport.x2-viewport.x1;
  viewport.y2:=viewport.y2-viewport.y1;
  viewport.x1:=0;
  viewport.y1:=0;

  if (x>viewport.x2) or (x<viewport.x1) or
     (y>viewport.y2) or (y<viewport.y1) then
    begin
{$ifdef GraphDebug}
       Writeln(stderr,'Error Wrong values for FloodFill');
       Writeln(stderr,'xmax ',viewport.x2);
       Writeln(stderr,'ymax ',viewport.y2);
{$endif def GraphDebug}
       exit;
    end;
  bordercol:=convert(border) and ColorMask;
  fillcol:=aktfillsettings.color and ColorMask;
  fillbkCol:=aktfillbkcolor and ColorMask;
  if aktfillsettings.pattern=emptyfill then
    begin
       fillcol:=fillbkcol;
       test_bkfill:=false;
    end
  else if aktfillsettings.pattern=solidfill then
     test_bkfill:=false
  else
    test_bkfill:=true;
{$ifdef GraphDebug}
     Writeln(stderr,'FloodFill(',x,',',y,') Fillcol ',hexstr(unconvert(fillcol),8));
     Writeln(stderr,' bordercol ',hexstr(unconvert(bordercol),8),
       ' fillbkcol ',hexstr(unconvert(fillbkcol),8));
{$endif def GraphDebug}
  fill(x,y);
end;

{$ifndef StackCkeckOn}
{$S-} { return to normal state }
{$else }
{$undef StackCheckOn}
{$endif }

procedure GetFillSettings(var Fillinfo:Fillsettingstype);
begin
  _graphresult:=grOk;
  if not isgraphmode then
    begin
      _graphresult:=grnoinitgraph;
      exit;
    end;
  Fillinfo:=aktfillsettings;
  Fillinfo.color:=unconvert(aktfillsettings.color);
end;

procedure GetFillPattern(var FillPattern:FillPatternType);
begin
  _graphresult:=grOk;
  if not isgraphmode then
    begin
      _graphresult:=grnoinitgraph;
      exit;
    end;
  FillPattern:=aktfillpattern;
end;

procedure SetFillPattern(pattern : FillPatternType;color : longint);
begin
  _graphresult:=grOk;
  if not isgraphmode then
    begin
      _graphresult:=grnoinitgraph;
      exit;
    end;
  fillpattern[12]:=pattern;
  SetFillStyle(12,color);
end;

procedure SetFillStyle(pattern : word ;color : longint);
var i,j:Integer;
    mask:Byte;
begin
  _graphresult:=grOk;
  if not isgraphmode then
    begin
      _graphresult:=grnoinitgraph;
      exit;
    end;
    { g<>ltige Paramter ? }
  if (pattern<0) or (pattern>12) then
    begin
      _graphresult:=grError;
      exit;
    end;
    { Muster laden }
  aktfillpattern:=fillpattern[pattern];
  aktfillsettings.pattern:=pattern;
  aktfillsettings.color:=convert(color);
  aktfillbkcolor:=aktbackcolor;
  i:=1; j:=0;
  repeat
    mask:=$80;
      repeat
        if (aktfillpattern[i] and mask) = 0
          then PatternBuffer[j]:=aktbackcolor else PatternBuffer[j]:=aktfillsettings.color;
           mask:=mask shr 1;
           j:=j+1;
      until mask=0;
      i:=i+1;
  until i > 8;
end;

procedure GetLineSettings(var LineInfo : LineSettingsType);
begin
  _graphresult:=grOk;
  if not isgraphmode then
    begin
      _graphresult:=grnoinitgraph;
      exit;
    end;
  lineinfo:=aktlineinfo;
end;

{ this procedure is rather confuse
  but I admit that I wrote it by try-error !! PM }

procedure FillPoly(points : word;var polypoints);
{$R-}
 type PointTypeArray = Array[0..0] of PointType;

      { Used to find the horizontal lines that
        must be filled }
      TLineSegmentInfo = Record
                      {range for check }
                      ymin,ymax,
                      { line equation consts }
                      xcoef,ycoef,_const,
                      lastvalue : longint;
                      use_in_line : boolean;
                    End;
     LineSegmentInfoArray = Array[0..0] of TLineSegmentInfo;

 var
     xmin,xmax,ymin,ymax : longint;
     x1,x2,y1,y2,y,xdeb  : longint;
     i,j,curx,cury       : longint;
     newvalue            : longint;
     LineInfo            : ^LineSegmentInfoArray;
     PreviousInside,inside,side : boolean;
     viewport            : viewporttype;
begin
   GetMem(LineInfo,(points+1)*SizeOf(TlineSegmentInfo));
   xmax:=$80000000;xmin:=$7fffffff;
   ymax:=$80000000;ymin:=$7fffffff;
   for i:=0 to points-1 do
     begin
        if i=points-1 then
          j:=0
        else
          j:=i+1;
        x1:=PointTypeArray(polypoints)[i].x;
        y1:=PointTypeArray(polypoints)[i].y;
        x2:=PointTypeArray(polypoints)[j].x;
        y2:=PointTypeArray(polypoints)[j].y;
        if x1>xmax then
          xmax:=x1;
        if x1<xmin then
          xmin:=x1;
        if y1>ymax then
          ymax:=y1;
        if y1<ymin then
          ymin:=y1;
        if y1<y2 then
          begin
             LineInfo^[i].ymin:=y1;
             LineInfo^[i].ymax:=y2;
          end
        else
          begin
             LineInfo^[i].ymin:=y2;
             LineInfo^[i].ymax:=y1;
          end;
        LineInfo^[i].xcoef:=y2-y1;
        LineInfo^[i].ycoef:=x1-x2;
        LineInfo^[i]._const:=y1*x2-x1*y2;
     end; { setting of LineInfo }

     side:=true;
     for i:=0 to points-1 do
       begin
          cury:=LineInfo^[i].ymin;
          newvalue:=LineInfo^[i].xcoef*(xmin-1)+
               LineInfo^[i].ycoef*cury+LineInfo^[i]._const;
          if (newvalue<0) then
            side:=not side;
       end;
   if aktviewport.clip then viewport:=aktviewport else viewport:=aktscreen;
   { reject invalid points !! }

   viewport.x2:=viewport.x2-viewport.x1;
   viewport.y2:=viewport.y2-viewport.y1;
   viewport.x1:=0;
   viewport.y1:=0;

{$ifdef GraphDebug}
       Writeln(stderr,'Rectangle (',xmin,',',ymin,'),(',xmax,',',ymax,')');
{$endif def GraphDebug}
   if xmin<0 then xmin:=0;
   if ymin<0 then ymin:=0;
   if xmax>viewport.x2 then xmax:=viewport.x2;
   if ymax>viewport.y2 then ymax:=viewport.y2;
{$ifdef GraphDebug}
       Writeln(stderr,'Rectangle (',xmin,',',ymin,'),(',xmax,',',ymax,')');
{$endif def GraphDebug}

   for cury:=ymin to ymax do
     begin
        xdeb:=xmin;
        PreviousInside:=true;
        for i:=0 to points-1 do
          begin
             if cury<LineInfo^[i].ymin then
               y:=LineInfo^[i].ymin
             else if cury>LineInfo^[i].ymax then
               y:=LineInfo^[i].ymax
             else
               y:=cury;
             newvalue:=LineInfo^[i].xcoef*(xmin-1)+
               LineInfo^[i].ycoef*y+LineInfo^[i]._const;
             LineInfo^[i].lastvalue:=newvalue;
             if (newvalue<0) then
               PreviousInside:=not PreviousInside;
             if (cury<LineInfo^[i].ymin) or (cury>=LineInfo^[i].ymax) then
               LineInfo^[i].use_in_line:=false
             else
               LineInfo^[i].use_in_line:=true;
          end;
        PreviousInside:=(side<>PreviousInside);
        inside:=PreviousInside;
        for curx:=xmin to xmax do
           begin
              for i:=0 to points-1 do
                if LineInfo^[i].use_in_line then
                  begin
                     newvalue:=LineInfo^[i].lastvalue+LineInfo^[i].xcoef;
                     if ((LineInfo^[i].lastvalue<0) and (newvalue>=0)) or
                        ((LineInfo^[i].lastvalue>0) and (newvalue<=0)) then
                       begin
                          inside:=not inside;
{$ifdef GraphDebug}
                          Writeln(stderr,'Line ',i,' crossed (',curx,',',cury,')');
                          Writeln(stderr,'Line x*',LineInfo^[i].xcoef,'+y*',
                            LineInfo^[i].ycoef,'+',LineInfo^[i]._const,'=0');
                          Writeln(stderr,'Old ',LineInfo^[i].lastvalue,' new ',newvalue);
{$endif def GraphDebug}
                       end;
                     LineInfo^[i].lastvalue:=newvalue;
                  end;
              if inside<>PreviousInside then
                if inside then
                  xdeb:=curx
                else
                  begin
                     patternline(xdeb,curx,cury);
{$ifdef GraphDebug}
                     Writeln(stderr,'Pattern (',xdeb,',',curx,') at ',cury);
{$endif def GraphDebug}
                  end;
              PreviousInside:=inside;
           end;
        if inside then
          begin
             patternline(xdeb,xmax,cury);
{$ifdef GraphDebug}
             Writeln(stderr,'Pattern (',xdeb,',',xmax,') at ',cury);
{$endif def GraphDebug}
          end;
     end;

   FreeMem(LineInfo,(points+1)*SizeOf(TlineSegmentInfo));
   { simply call drawpoly instead (PM) }
   DrawPoly(points,polypoints);
end;


{
  $Log$
  Revision 1.1  1998-12-21 13:07:03  peter
    * use -FE

  Revision 1.8  1998/11/25 22:59:24  pierre
   * fillpoly works

  Revision 1.7  1998/11/25 13:04:44  pierre
    + added multi page support

  Revision 1.6  1998/11/20 18:42:07  pierre
    * many bugs related to floodfill and ellipse fixed

  Revision 1.5  1998/11/19 15:09:37  pierre
    * several bugfixes for sector/ellipse/floodfill
    + graphic driver mode const in interface G800x600x256...
    + added backput mode as in linux graph.pp
      (clears the background of textoutput)

  Revision 1.4  1998/11/19 09:48:48  pierre
    + added some functions missing like sector ellipse getarccoords
      (the filling of sector and ellipse is still buggy
       I use floodfill but sometimes the starting point
       is outside !!)
    * fixed a bug in floodfill for patterns
      (still has problems !!)

  Revision 1.3  1998/11/18 13:23:34  pierre
    * floodfill got into an infinite loop !!
    + added partial support for fillpoly
      (still wrong if the polygon is not convex)
      Simply make a floodfill from the barycenter !
    * some 24BPP code changed (still does not work for my S3VBE program !)

  Revision 1.2  1998/11/18 09:31:33  pierre
    * changed color scheme
      all colors are in RGB format if more than 256 colors
    + added 24 and 32 bits per pixel mode
      (compile with -dDEBUG)
      24 bit mode with banked still as problems on pixels across
      the bank boundary, but works in LinearFrameBufferMode
      Look at install/demo/nmandel.pp

  Revision 1.1.1.1  1998/03/25 11:18:42  root
  * Restored version

  Revision 1.3  1998/01/26 11:57:57  michael
  + Added log at the end



  Working file: rtl/dos/ppi/fill.ppi
  description:
  ----------------------------
  revision 1.2
  date: 1997/12/01 12:21:29;  author: michael;  state: Exp;  lines: +13 -1
  + added copyright reference in header.
  ----------------------------
  revision 1.1
  date: 1997/11/27 08:33:51;  author: michael;  state: Exp;
  Initial revision
  ----------------------------
  revision 1.1.1.1
  date: 1997/11/27 08:33:51;  author: michael;  state: Exp;  lines: +0 -0
  FPC RTL CVS start
  =============================================================================
}