home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 13 / CDA13.ISO / cdactual / demobin / share / program / Pascal / BGI256.ZIP / FILLPR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-01-30  |  9.8 KB  |  341 lines
  1. (*
  2. Written by Michael Day as of 30 Jan 1993
  3. Adapted from the following program:
  4.  
  5. /***************************************************************************
  6.  * Pattern sensitivity test program -- Microsoft 'C' Graphics Library
  7.  *
  8.  * PROBLEM: The _floodfill() library code has pattern sensitive problems.
  9.  *
  10.  *   1.  It may appear to pause while performing excessive calculations.
  11.  *   2.  It may not complete the fill pattern over the allowed area.
  12.  *   3.  It may go into an endless loop - requiring system reboot.
  13.  *
  14.  * This program illustrates all three examples on any system with a CGA
  15.  * (Color Graphics Adapter).
  16.  *
  17.  * Submitted by:  Steve Hathaway      (CompuServ ID = 71237,14)
  18.  *                Hathaway Computer Service
  19.  *                PO Box 25
  20.  *                Wilsonville, OR 97070
  21.  */
  22. *)
  23.  
  24. program fillpr;
  25. uses CRT,graph,wrmode;
  26.  
  27. (*
  28. /****************
  29.  * TEST PATTERNS
  30.  */
  31. *)
  32.  
  33. type maskarray = array[0..7] of byte;
  34.      patternmask = array [0..11] of maskarray;
  35.  
  36. const viaFlood : boolean = true;
  37.       DoCircle : boolean = true;
  38.       DoPoly   : boolean = false;
  39.       done : boolean = false;
  40.       backgroundcolor : word = 0;
  41.  
  42. const lstyl : array [0..11] of word = (
  43.          $FFFF, $AAAA, $8888, $CCCC,
  44.          $EEEE, $F6F6, $F249, $FCFC,
  45.          $F39C, $F7BC, $E64C, $FCCC );
  46.  
  47.       fmask : patternmask = (
  48.          ($FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF),
  49.          ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  50.          ($CC, $66, $33, $99, $CC, $66, $33, $99),
  51.          ($AA, $AA, $AA, $AA, $AA, $AA, $AA, $AA),
  52.          ($FF, $00, $FF, $00, $FF, $00, $FF, $00),
  53.          ($C8, $32, $8C, $23, $C8, $32, $8C, $23),
  54.          ($66, $00, $66, $00, $66, $00, $66, $00),
  55.          ($88, $22, $88, $22, $88, $22, $88, $22),
  56.          ($CC, $33, $CC, $33, $CC, $33, $CC, $33),
  57.          ($99, $42, $24, $99, $99, $24, $42, $99),
  58.          ($FE, $7C, $38, $10, $08, $1C, $3E, $7F),
  59.          ($81, $42, $24, $18, $18, $24, $42, $81)
  60.          );
  61.  
  62. const MaxPoly = 50;
  63. var  Pcnt : word;
  64.      Poly : array[1..MaxPoly] of PointType;
  65.  
  66. var mode, ixs, ixm, iwm, t : word;
  67.     s:string;
  68.     key:char;
  69.  
  70. {/***********************************
  71.  * PATTERN SENSITIVITY TEST FUNCTION
  72.  */}
  73.  
  74. function fstr(w:word):string;
  75. var s:string;
  76. begin
  77.   str(w,s);
  78.   fstr := s;
  79. end;
  80.  
  81. const Hex : array[0..15] of char = '0123456789ABCDEF';
  82. function hexw(w:word):string;
  83. begin
  84.   hexw[1] := hex[(w shr 12) and $f];
  85.   hexw[2] := hex[(w shr 8)  and $f];
  86.   hexw[3] := hex[(w shr 4)  and $f];
  87.   hexw[4] := hex[ w and $f];
  88.   hexw[0] := #4;
  89. end;
  90.  
  91. function hexb(b:byte):string;
  92. begin
  93.   hexb[1] := hex[b shr  4];
  94.   hexb[2] := hex[b and $f];
  95.   hexb[0] := #2;
  96. end;
  97.  
  98. procedure InitPoly(which:byte);
  99. var x1,x2,y1,y2,x,y,h,w:integer;
  100. begin
  101.     Pcnt := 5;
  102.     x1 := 100;
  103.     x2 := GetMaxX-100;
  104.     y1 := 20;
  105.     y2 := GetMaxY-20;
  106.     W := (x2-x1) div 9;
  107.     H := (y2-y1) div 8;
  108.     X := x1+((x2-x1) div 2) - round(2.5 * W);
  109.     Y := y1+((y2-y1) div 2) - (3 * H);
  110.  
  111.     { Border around viewport is outer part of polygon }
  112.     Poly[1].X := x1;       Poly[1].Y := y1;
  113.     Poly[2].X := x1+x2-x1; Poly[2].Y := y1;
  114.     Poly[3].X := x1+x2-x1; Poly[3].Y := y1+y2-y1;
  115.     Poly[4].X := x1;       Poly[4].Y := y1+y2-y1;
  116.     Poly[5].X := x1;       Poly[5].Y := y1;
  117.  
  118.     Poly[6].X := X;        Poly[6].Y := Y+H;
  119.     Poly[7].X := X+W;      Poly[7].Y := Y;
  120.     Poly[8].X := X+(5*W);  Poly[8].Y := Y;
  121.  
  122.     Poly[9].X := X+(5*W);  Poly[9].Y := Y+(5*H);
  123.     Poly[10].X := X+(4*W); Poly[10].Y := Y+(6*H);
  124.     Poly[11].X := X;       Poly[11].Y := Y+(6*H);
  125.     Poly[12].X := X;       Poly[12].Y := Y+H;
  126.     Pcnt := 12;
  127.  
  128.     if Which > 0 then
  129.     begin
  130.       Poly[9].X := X+(5*W);  Poly[9].Y := Y;
  131.       Poly[10].X := X+W;     Poly[10].Y := Y+(H*4);
  132.       Poly[11].X := X+W;     Poly[11].Y := Y+(H*5);
  133.       Poly[12].X := X+(4*W); Poly[12].Y := Y+(H*5);
  134.       Poly[13].X := X+(4*W); Poly[13].Y := Y+(H*3);
  135.       Poly[14].X := X+(3*W); Poly[14].Y := Y+(H*4);
  136.       Poly[15].X := X+(2*W); Poly[15].Y := Y+(H*4);
  137.       Poly[16].X := X+(5*W); Poly[16].Y := Y+H;
  138.       Poly[17].X := X+(5*W); Poly[17].Y := Y+(H*5);
  139.       Poly[18].X := X+(4*W); Poly[18].Y := Y+(H*6);
  140.       Poly[19].X := X;       Poly[19].Y := Y+(H*6);
  141.       Poly[20].X := X;       Poly[20].Y := Y+(H*4);
  142.       Poly[21].X := X+(3*W); Poly[21].Y := Y+H;
  143.       Poly[22].X := X+(2*W); Poly[22].Y := Y+H;
  144.       Poly[23].X := X;       Poly[23].Y := Y+(H*3);
  145.       Poly[24].X := X;       Poly[24].Y := Y+(H*2);
  146.       Poly[25].X := X+(W);   Poly[25].Y := Y+(H);
  147.       Poly[26].X := X;       Poly[26].Y := Y+H;
  148.       Pcnt := 26;
  149.     end;
  150.  
  151. end;
  152.  
  153. {------------------------------------------------------------}
  154. procedure testpattern(styl:word; mask:maskarray; color:byte);
  155. var Xa,Ya,R,x,y,i,ii,md,bc,Px,Py,Sy : word;
  156.     buf : array[0..16] of byte;
  157.     uStk,fStk,tStk:word;
  158. begin
  159.     color := succ(color mod GetMaxColor);
  160.     GetAspectRatio(Xa,Ya);
  161.     x := GetMaxX div 2;
  162.     for y := (GetMaxY div 2) to (GetMaxY div 2)+7 do {/** loop through 8 vertical locations **/ }
  163.     begin
  164.        if keypressed then Exit;
  165.        cleardevice;
  166.  
  167.        setcolor(backgroundcolor);
  168.        setwritemode(FillMode+SetBackColor);
  169.        SETWRITEMODE(MiscCommand+GetXYStackPeak);
  170.        uStk := GETMAXMODE;
  171.        SETWRITEMODE(MiscCommand+GetXYStackFree);
  172.        fStk := GETMAXMODE;
  173.        SetWriteMode(MiscCommand+GetBackColor);
  174.        bc := GetMaxMode;
  175.  
  176.        setcolor(white);
  177.        outtextxy(128,0,'BGI ');
  178.        if viaFlood then
  179.          outtextxy(160,0,'Flood ')
  180.        else
  181.          outtextxy(160,0,'Fill  ');
  182.        if DoPoly then
  183.          outtextxy(208,0,'Poly   ');
  184.        if DoCircle then
  185.          outtextxy(208,0,'Circle ');
  186.  
  187.        outtextxy(0,0,'X:'+fstr(GetMaxX+1)+' Y:'+fstr(GetMaxY+1));
  188.        OUTTEXTXY(0,10,'uS:'+fstr(uStk));  {show previous stack usage}
  189.        OUTTEXTXY(0,20,'fS:'+fstr(fStk));  {show previous free stack space}
  190.  
  191.        outtextxy(0,GetMaxY-80,'Bc:'+fstr(bc));
  192.        outtextxy(0,GetMaxY-70,'Fc:'+fstr(color));
  193.        outtextxy(0,GetMaxY-60,'Ps:'+fstr(ixm));
  194.        outtextxy(0,GetMaxY-50,'Ls:'+fstr(ixs));
  195.        outtextxy(0,GetMaxY-40,'Wmode:'+fstr(iwm));
  196.        outtextxy(0,GetMaxY-30,'Y:'+fstr(y)+' ('+fstr(y-(GetMaxY div 2))+')');
  197.        outtextxy(0,GetMaxY-20,'L:'+hexw(styl)+'  ');
  198.        moveto(0,GetMaxY-10);
  199.        outtext('M:');
  200.        for i := 0 to 6 do
  201.          outtext(hexb(mask[i])+',');
  202.        outtext(hexb(mask[7])+' ');
  203.  
  204.        setwritemode(LineMode+ForeMoveWrite);
  205.        setcolor(white);
  206.        setlinestyle(UserBitLn,styl,1);
  207.        moveto(0,y);
  208.        lineto(getMaxX,y);
  209.  
  210.        Px := GetMaxX div 2;
  211.        Py := GetMaxY div 2;
  212.        if DoPoly then
  213.          Sy := 30
  214.        else
  215.          Sy := GetMaxY div 3;
  216.  
  217.      {  putpixel(Px+1,Sy,red); putpixel(Px-1,Sy,red);
  218.        putpixel(Px,Sy+1,red); putpixel(Px,Sy-1,red); }
  219.  
  220.        setfillpattern(fillpatterntype(mask),color);
  221.        setwritemode(LineMode+MoveWrite);
  222.  
  223.        r := GetMaxX div 3;
  224.        if DoCircle then
  225.        begin
  226.          if viaFlood then
  227.            circle(Px,Py,Py)
  228.          else
  229.            fillellipse(Px,Py,R,R*longint(Xa) div Ya);
  230.        end;
  231.  
  232.        if DoPoly then
  233.        begin
  234.          if viaFlood then
  235.          begin
  236.            setlinestyle(SolidLn,0,1);
  237.            DrawPoly(Pcnt,Poly);
  238.          end
  239.          else
  240.          begin
  241.            FillPoly(Pcnt,Poly);
  242.          end;
  243.        end;
  244.  
  245.        if viaFlood then
  246.        begin
  247.          floodfill(Px,Sy,white)
  248.        end;
  249.  
  250.        if GraphResult <> 0 then
  251.        begin
  252.          outtextxy(GetMaxX-60,0,'*Error*');
  253.          delay(500);
  254.        end;
  255.  
  256.   {     delay(200); }
  257.  
  258.     end;
  259. end;
  260.  
  261. {/*****************************************
  262.  * PATTERN SENSITIVITY TEST - MAIN PROGRAM
  263.  */}
  264.  
  265. function autodet:integer; far;
  266. begin
  267.   autodet := mode;
  268. end;
  269.  
  270.  
  271. var gd,gm:integer;
  272. begin
  273.  mode := 128;
  274.  if paramcount > 0 then
  275.  begin
  276.    s := paramstr(1);
  277.    mode := ord(s[1]) and $f;
  278.  end;
  279.  
  280.  SetGraphBufSize(10000);
  281.  gm := 0;
  282.  gd := 0;            {/*** GRAPHICS VIDEO MODE TO TEST ***/}
  283.  InstallUserDriver('BGI256',@autodet);
  284. { gd := cga; }
  285.  InitGraph(gd,gm,'');
  286.  InitPoly(0);
  287.  setcolor(white);
  288.  setWritemode(FloodFillType+BorderFill);    {init for BGI256 if out there}
  289.  setwritemode(FloodFillType+FillCompressOn);
  290. { setWritemode(FloodFillType+ComplexFill); }
  291. { setwritemode(FloodFillType+FillDelayOn);   }
  292. { setwritemode(FloodFillType+FillTracerOn); }
  293.  
  294.   done := false;
  295.   FOR IWM := 0 TO 23 DO
  296.   BEGIN
  297.     SetWriteMode(FillMode+Iwm);   {fill mode for BGI256 if out there}
  298.     for ixm := 0 to 11 do
  299.     begin
  300.       for ixs := 0 to 11 do
  301.       begin
  302.         if not(done) then
  303.           testpattern(lstyl[ixs], fmask[ixm], ixs+1);
  304.         if keypressed then
  305.         begin
  306.           key := readkey;
  307.           if key = #0 then key := char(ord(readkey)+$80);
  308.           if key = #$1b then done := true;
  309.           case upcase(key) of
  310.             'F' : begin
  311.                     viaFlood := not(viaFlood);
  312.                   end;
  313.             'P' : begin
  314.                     DoPoly := true;
  315.                     DoCircle := false;
  316.                   end;
  317.             'C' : begin
  318.                     DoCircle := true;
  319.                     DoPoly := false;
  320.                   end;
  321.             'S' : begin
  322.                     SetWriteMode(FloodFillType+SeedFill)
  323.                   end;
  324.             'B' : begin
  325.                     SetWriteMode(FloodFillType+BorderFill)
  326.                   end;
  327.             'N' : InitPoly(0);
  328.             'M' : InitPoly(1);
  329.             '0'..'9': begin
  330.                         BackGroundcolor := ord(key) and $f;
  331.                       end;
  332.           end; {case}
  333.         end;
  334.       end;
  335.     end;
  336.   END;
  337.  
  338.  closegraph;          { /*** RESTORE VIDEO MODE IF SUCCESS ***/}
  339.  writeln('Done');     { /** otherwise system reboot required */}
  340. end.
  341.