home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / BEEHIVE / UTILITYS / PUDD.ARC / PUDD-05.PAS < prev    next >
Pascal/Delphi Source File  |  1991-08-11  |  11KB  |  302 lines
  1.  
  2. {****************************************************************************}
  3. {*  Rightside will find the first high point to the right of the point      *}
  4. {* given by centerbyte and centerbit in the array bytelist.                 *}
  5. {****************************************************************************}
  6. function RightSide (centerbyte   :integer;
  7.                     centerbit    :integer;
  8.                     bytelist     :scanline): integer;
  9. var  i,j,k     :integer;
  10.      l         :byte;
  11.      bitlist :Blist;
  12.      linelocal :scanline;
  13.      last       :boolean;   {.....signals last byte in array }
  14. begin
  15.  last := false;
  16.  i := centerbyte +1;
  17.  j := 1;
  18.  linelocal := bytelist;
  19.  if linelocal[i] <> 0 then  {....clear bits to the left of centerbit }
  20.   begin
  21.    k := 0;
  22.    repeat
  23.     clrbitB(7-k,linelocal[centerbyte+1]);
  24.     if k < centerbit then
  25.      k := k + 1;
  26.    until (k = centerbit);
  27.   end;
  28.   i := i-1;
  29. repeat     {.........start looking for a bit to the right }
  30.  if i = 80 then
  31.   last := true
  32.  else
  33.  i := i + 1;
  34. until (last) or (linelocal[i] <> 0); {...until finding a bit with a high bit }
  35. ReadByte(linelocal[i],bitlist);
  36. FlipList(bitlist);
  37. while copy(bitlist,j,1) <> '1' do
  38.  begin
  39.   j := j + 1;
  40.   if j = 9 then           {...force out of loop }
  41.    begin                  {...by providing answer to while }
  42.     j := 8;
  43.     bitlist := '11111111';
  44.    end;
  45.  end;
  46.  if (Centerbit = 0) and (Centerbyte = 0) then
  47.   RightSide := 0
  48.  else
  49.   RightSide := ((i-1) * 8) + (j-1);
  50. end;
  51.  
  52.  
  53.  
  54. {****************************************************************************}
  55. {*  LeftSide will find the first high point to the left of the point        *}
  56. {* given by centerbyte and centerbit in the array bytelist.                 *}
  57. {****************************************************************************}
  58. function LeftSide (centerbyte   :integer;
  59.                     centerbit    :integer;
  60.                     bytelist     :scanline): integer;
  61. var  i,j,k     :integer;
  62.      bitlist :Blist;
  63.      linelocal :scanline;
  64.      first       :boolean;   {.....signals first byte in array }
  65. begin
  66.  first := false;
  67.  i := centerbyte+1;
  68.  j := 7;
  69.  linelocal := bytelist;
  70.  if linelocal[i] <> 0 then  {....clear bits to the left of centerbit }
  71.   begin
  72.    k := 7;
  73.    repeat
  74.     clrbitB(7-k,linelocal[centerbyte+1]);
  75.     if k > centerbit then
  76.      k := k - 1;
  77.    until (k = centerbit);
  78.   end;
  79. repeat     {.........start looking for a bit to the left }
  80.  if i = 0 then {.....by finding the byte                 }
  81.   first := true
  82.  else
  83.  i := i - 1;
  84. until (first) or (linelocal[i+1] <> 0); {...until finding a bit with a high bit }
  85. ReadByte(linelocal[i+1],bitlist);
  86. FlipList(bitlist);
  87. while copy(bitlist,j+1,1) <> '1' do
  88.  begin
  89.   j := j - 1;
  90.   if j = 0 then           {...force out of loop }
  91.    begin                  {...by providing answer to while }
  92.     bitlist := '11111111';
  93.    end;
  94. end;
  95.   LeftSide := ((i) * 8) + (j);
  96. end;
  97.  
  98.  
  99. {****************************************************************************}
  100. {*  Fillone will fill the horz line specified by Y with the current fill    *}
  101. {* style etc.  The fill is done from the LeftMost bit to the RightMost bit, *}
  102. {* unless the point specified by CenterX is already lit then Continue is    *}
  103. {* set to false and no other action is pursued.                             *}
  104. {****************************************************************************}
  105. procedure FillOne(var CenterX  :integer;
  106.                   var Continue :boolean;
  107.                       Y        :integer);
  108. var chunk     :byte;      {......a chunk of 8 bits}
  109.     bit       :byte;      {......the n'th bit}
  110.     LeftMost  :integer;
  111.     RightMost :integer;
  112.     ThisLine  :scanline;
  113. begin
  114.  chunk := CenterX div 8;
  115.  bit   := CenterX mod 8;
  116.  GetLine(Y,ThisLine);
  117.  RightMost := RightSide(chunk,bit,ThisLine);
  118.  LeftMost := LeftSide(chunk,bit,Thisline);
  119.  if (Rightmost = CenterX) or (LeftMost = CenterX) then {...nothing to fill}
  120.   begin
  121.    Continue := false;
  122.   end
  123.  else
  124.   begin
  125.    Fillhorz(Y,LeftMost,RightMost);
  126.    CenterX := LeftMost + ( (RightMost-LeftMost) div 2);
  127.   end;
  128. end;         {................fillone }
  129.  
  130. {****************************************************************************
  131. * fillArea will use fillone with LeftMost and RightMost in order to fill    *
  132. * an area. The area must be defined by either the edges of the screen       *
  133. * or by a solid line.  If there are any holes in the line that defines the  *
  134. * shape, the filling will proceed beyond the indended area                  *
  135. *   The idea....                                                            *
  136. *    is simple and will fail to fill certain types of areas.  The line      *
  137. *    that the crosshair is on is filled and the center of the line is       *
  138. *    found from the left and right limits. Next we look up one line and     *
  139. *    fill that line.  The center of the line is again calculated from the   *
  140. *    limits.  This continues until we run off the screen or else find a     *
  141. *    lit pixel on the line above the center point.  The procedure then      *
  142. *    starts working its way down with the same idea.                        *
  143. ****************************************************************************}
  144. procedure fillArea;
  145. var continue     :boolean;
  146.     centerX,Y    :integer;
  147.     tempMode     :DefTypes;
  148. begin
  149.  centerX := xPoz;
  150.  Y := yPoz;
  151.  continue := true;
  152.  offXhair(size,xPoz,yPoz); {....the crosshair should not be in the picture }
  153.  TempMode := vWriteMode;                     {...save the writemode        }
  154.  vWriteMode := 'Fill';                       {...fill is logical 'or'      }
  155.  SetTypes;                                   {...set the mode              }
  156.  while continue do          {....now fill from yPoz up                     }
  157.   begin
  158.    fillone(centerX,continue,Y);
  159.    if (continue) and (Y < 239) then
  160.     begin
  161.      Y := Y + 1;
  162.     end
  163.    else
  164.     continue := false
  165.   end;
  166.  centerX := xPoz;
  167.  Y := yPoz-1;
  168.  if Y <> -1 then      {....if we're on the screen     }
  169.    continue := true;  {......then reset continue      }
  170.  while continue do    {.......and fill from yPoz down }
  171.   begin
  172.    fillone(centerX,continue,Y);
  173.    if (continue) and (Y > 0) then
  174.     begin
  175.      Y := Y - 1;
  176.     end
  177.    else
  178.     continue := false
  179.   end;
  180.  vWriteMode := TempMode;          {.....putting this stuff back }
  181.  SetTypes;
  182.  initXhair(size,xPoz,yPoz);
  183. end; {............................fillArea}
  184.  
  185.  
  186.  
  187. {*****************************************************************************
  188. * BoxMove uses polyline to create a box with the given corners.  It is call  *
  189. * by the Block procedure                                                     *
  190. *****************************************************************************}
  191. procedure BoxMove(x1,y1,x2,y2:integer);
  192. var  listarray  :pointlist;
  193. begin
  194.     listarray[1] := x1;
  195.     listarray[2] := y1;
  196.     listarray[3] := x1;
  197.     listarray[4] := y2;
  198.     listarray[5] := x2;
  199.     listarray[6] := y2;
  200.     listarray[7] := x2;
  201.     listarray[8] := y1;
  202.     listarray[9] := x1;
  203.     listarray[10] := y1;
  204.     polyline(5,listarray);
  205. end;  {.........BoxMove }
  206.  
  207.  
  208. {*****************************************************************************
  209. * Block will either create and fill a rectangle or else erase the area       *
  210. * defined by a rectangle, depending on the logic of the parameter.  Since    *
  211. * most of the work is the defining of the rectangle, both these functions    *
  212. * have been combined.  The actual erasing or filling is done by the graphic  *
  213. * primitive FillBar.                                                         *
  214. *****************************************************************************}
  215. procedure Block(erase:boolean);
  216. var     Xlowleft,Ylowleft     :integer; {...these are for moving around /}
  217.         Xupright,Yupright     :integer; {                              / }
  218.         Xtemp,Ytemp           :integer; {                             /  }
  219.         Xcorner,Ycorner       :integer; {____________________________/   }
  220.         TempMode              :defTypes;{...these save the originals    /}
  221.         TempStyle             :defTypes;{                              / }
  222.         TempLine              :defTypes;{                             /  }
  223.         TempColor             :defTypes;{____________________________/   }
  224.  
  225. begin
  226.   TempColor := vLineColor;
  227.   TempLine := vLineStyle;
  228.   vLineStyle := 'Solid';
  229.   vLineColor := 'White';
  230.   TempMode := vWriteMode;
  231.   vWriteMode := 'OverWrite';
  232.   SetTypes;
  233.   Xcorner := xPoz;
  234.   Ycorner := yPoz;
  235.   BoxMove(Xcorner,Ycorner,xPoz,yPoz);
  236.   repeat
  237.     Xtemp := xPoz;
  238.     Ytemp := yPoz;
  239.     read(kbd,response);
  240.     response := UpCase(response);
  241.     case response of
  242.      'S':SetSpeed(speed);
  243.      '5':SetSpeed(speed);
  244.      '1'..'9':begin
  245.                reInitXhair(size,xpoz,ypoz);
  246.                MoveCross(size,speed,response,xPoz,yPoz);
  247.               end;
  248.     end;     {.....case }
  249.     BoxMove(Xcorner,Ycorner,Xtemp,Ytemp);
  250.     BoxMove(Xcorner,Ycorner,xPoz,yPoz);
  251.   until (response = 'B') or (response = 'E');  {..until the area is defined }
  252.   BoxMove(Xcorner,Ycorner,xPoz,yPoz);
  253.   if Xcorner < xPoz then        {......now let's get the corners straight   }
  254.    begin
  255.     Xlowleft := Xcorner;
  256.     Xupright := xPoz;
  257.    end
  258.   else
  259.    begin
  260.     Xlowleft := xPoz;
  261.     Xupright := Xcorner;
  262.    end;
  263.   if Ycorner < yPoz then
  264.    begin
  265.     Ylowleft := Ycorner;
  266.     Yupright := yPoz;
  267.    end
  268.   else
  269.    begin
  270.     Ylowleft := yPoz;
  271.     Yupright := Ycorner;
  272.    end;
  273.   vLineColor := TempColor;
  274.   vLineStyle := TempLine;
  275.   vWriteMode := TempMode;
  276.   SetTypes;
  277.   if erase then                {......the erase must form an open area }
  278.    begin
  279.     TempStyle := vFillStyle;
  280.     vFillStyle := 'Hollow';
  281.    end;
  282.   SetTypes;
  283.   offXhair(size,xPoz,yPoz);  {....take this out of the picture }
  284.   fillbar(Xlowleft,Ylowleft,Xupright,Yupright);
  285.   if erase then  {.......then we must get rid of the border left by FillBar }
  286.    begin
  287.       vWriteMode := 'Replace';
  288.       TempLine := vLineStyle;
  289.       vLineStyle := 'Solid';
  290.       TempColor := vLineColor;
  291.       vLineColor := 'Black';
  292.       SetTypes;
  293.       BoxMove(Xcorner,Ycorner,xPoz,yPoz);
  294.       vLineStyle := TempLine;
  295.       vLineColor := TempColor;
  296.       vFillStyle := TempStyle;
  297.       vWriteMode := TempMode;
  298.       SetTypes;
  299.    end;
  300.   initXhair(size,xPoz,yPoz);  {....putting it back in place }
  301. end;
  302.