unit U_TileFit;
    {Copyright 2001, Gary Darby, Intellitech Systems Inc., www.DelphiForFun.org

 This program may be used or modified for any non-commercial purpose
 so long as this original notice remains in place.
 All other rights are reserved
 }

 {Fits a random subset of a given set of tiles to fill a given rectangle}

interface

{You'll see a lot of references to GCD in this program.  GCD stands for
 Greatest Common Denominator, in this case the largest integer that divides
 all tile sizes.  Thus if tiles come in multiples of 3 inches, the GCD
 is 3 and we can internally divide everything by 3 to build array of possible
 tile corners, etc.}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, Menus, ExtCtrls, ComCtrls, NumEdit, Spin;

  Const
  maxNbrTileSizes=16; {max number of tile entries}
  maxTabledim=30; {max table height or width after dividing by GCD}
  maxtilesize=20; {max tilesize after dividing by GCD}
  maxtilesInFig=100; {max total tiles in a figure}

Type
  TTileType =record
     ID:string;
     x,y,nbr:integer;
     color:integer;
   end;
  TTileArray= array[1..maxNbrTileSizes] of TTileType;
  TFigArray=array[1..MaxTableDim,1..MaxTableDim] of integer;
  TTileSizes=array[1..MaxTileSize,1..MaxTileSize] of integer;

  TSavedTile = record
    p1,p2:TPoint;
    Id: string[6];
    color:integer;
  end;

  TSavedfig= class(TObject)
      tile: array[1..MaxTilesInFig] of TSavedTile;
      rectnbr:integer; {Which table is  this}
      figwidth,figheight:integer;  {how big is it}
      Procedure assign(infig:TSavedFig);
    end;

  TScaleInfo=record
        Origin:TPoint;
        scale:TPoint;
     end;

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    OpenTileSet1: TMenuItem;
    Save1: TMenuItem;
    SaveAs1: TMenuItem;
    N1: TMenuItem;
    N2: TMenuItem;
    GroupBox2: TGroupBox;
    Tilegrid: TStringGrid;
    AddBtn: TButton;
    RemoveBtn: TButton;
    ChangeBtn: TButton;
    GetNextBtn: TButton;
    StopBtn: TButton;
    Panel1: TPanel;
    HLabel: TLabel;
    AreaHEdt: TIntEdit;
    AreaWEdt: TIntEdit;
    Label1: TLabel;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    PrintDialog1: TPrintDialog;
    Oprtions1: TMenuItem;
    SetMaxRunTime1: TMenuItem;
    SaveBtn: TButton;
    SaveFigList: TListBox;
    PrintOptions1: TMenuItem;
    PrintPreview1: TMenuItem;
    PrintSavedPages1: TMenuItem;
    AreaWUD: TUpDown;
    AreaHUD: TUpDown;
    SizeBox: TCheckBox;
    TickBox: TCheckBox;
    ColorBox: TCheckBox;
    procedure TilegridSelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure AddBtnClick(Sender: TObject);
    procedure RemoveBtnClick(Sender: TObject);
    procedure ChangeBtnClick(Sender: TObject);
    procedure GetNextBtnClick(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure SaveAs1Click(Sender: TObject);
    procedure SetMaxRunTime1Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure OpenTileSet1Click(Sender: TObject);
    procedure StopBtnClick(Sender: TObject);
    procedure Save1Click(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
    procedure SaveFigListClick(Sender: TObject);
    procedure SaveFigListKeyPress(Sender: TObject; var Key: Char);
    procedure SaveFigListKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure PrintOptions1Click(Sender: TObject);
    procedure PrintPreview1Click(Sender: TObject);
    procedure PrintSavedPages1Click(Sender: TObject);
    procedure Loadtiles(fname:string);
    procedure CheckBoxClick(Sender: TObject);

  public
   Thisfig : Tsavedfig;
   figmap:TFigArray;
   Sizesavail,SpacesAvail:TTileSizes;
   selectfigs:TTileArray;
   maxfigs:word;
   nbrSAVED:word;
   ScreenInfo:TScaleInfo; {origin and scale for displaying tiles}
   Topleft:Tpoint;
   maxx,maxy:integer;
   filename:string;
   maxrunsecs:integer;
   figcount:integer;
   figsPerPage:integer;
   ShowTicmarks:boolean;  {Show unit spaced tick marks around table}
    Procedure drawfig(Tile:TSavedTile;ScaleInfo:TScaleInfo;Can:TCanvas);
    Function figfits(tile:TTiletype):boolean;
    Procedure reset;
    Procedure Loadselectfigs;
    Procedure Savetiles;
    Procedure MakePrintimage(Startat:integer;can:TCanvas);
    Function GetGCD:integer;
  end;

var
  Form1: TForm1;

implementation

uses U_Runtime,U_ChangeTile ,U_PrintLayout ,
         printers, {myutils,} U_PreView;

{$R *.DFM}
  {Local routines}


  function hexstrtoint(s:string):integer;
  {convert hex string to integer}
  var i,n:integer;
  begin
    n:=0;
    s:=uppercase(s);
    for i:=1 to length(s)do
    begin
      n:=n*16;
      if s[i] in ['0'..'9'] then n:=n+ord(s[i])-ord('0')
      else if s[i] in ['A'..'F'] then n:=n+10+ord(s[i])-ord('A');
    end;
    result:=n;
  end;

    function getword(var w:string):string;
    {Destructive getword - removes the first word from an
     input string and returns it in result string}
    var
      i:integer;
    Begin
      i:=1;
      result:='';
      If length(w)=0 then exit;
      if w[length(w)]<>',' then w:=w+','; {make sure we have a "stopper"}
      {skip leading spaces and tabs}
      while (i<=length(w)) and  (w[i] in [' ',#9]) do inc(i);
      If w[i] =',' then result:=''
      else
      Begin
        If i>1 then w:=copy(w,i,length(w)-i+1);
        i:=1;
        while (i<=length(w)) and not (w[i] in [' ',#9,',']) do inc(i);
        result:=copy(w,1,i-1);
      End;
      system.delete(w,1,i);
    End;

    Function gcd2(a,b:integer):integer;
   {return gcd of two integers, a and b}
   {Euclid's method
    - based of fact that GCD of 2 numbers also divides the remainder
      when one is divided by the other}
   var
     g,z:integer;
   Begin
     g:=b;
     If b<>0 then
     while g<>0 do
     Begin
       z:=a mod g;
       a:=g;
       g:=z;
     end;
     result:=a;
   end;

  Function GCD(A:array of integer):integer;
 {Greatest common denominator of an array of integers}
  var
   i:integer;
   g:integer;
 Begin                             g:=a[0];
   if length(a)>=2 then
   Begin
     g:=gcd2(g,a[1]); {get GCD for 1st two numbers}
     if length(a)>2 then {GCD for rest is GCD of prev GCD and next number}
     for i:= 2 to length(a)-1 do g:=gcd2(g,a[i]);
   end;
   result:=g;
 end;

 {******************************************************}
 {**************** TSavedFig Class methods *************}
 {******************************************************}

 {****************** Tsavedfig.Assign *****************}
 Procedure Tsavedfig.assign(infig:TsavedFig);
 {assign one table decription to another }
 var  i:integer;
 begin
   rectnbr:=infig.rectnbr;
   for i := 1 to rectnbr do tile[i]:=infig.tile[i];
   figwidth:=infig.figwidth;
   figheight:=infig.figheight;
 end;

 {***********************************************}
 {***************** TForm Methods ***************}
 {***********************************************}

 {********************** drawfig ***************}
 Procedure TForm1.drawfig(Tile:TSavedTile;ScaleInfo:TScaleInfo;Can:TCanvas);
 {draw a single tile with upper left corner at T}
     Var tx,ty,bx,by,w,h:word;
     begin
       With scaleinfo, tile do
       begin
         tx:=Origin.x+p1.x*scale.x;
         ty:=Origin.y+p1.y*scale.y;
         bx:=Origin.x+(p1.x+p2.x)*scale.x;
         by:=Origin.y+(p1.y+p2.y)*scale.y;
       end;
       if colorbox.checked then can.brush.color:=tile.color
       else can.brush.color:=clwhite;
       Can.Rectangle(Tx,ty,bx,by);
       if sizebox.checked then
       begin
         can.font.name:='Arial';
         can.font.size:= 8;
         w:=can.textwidth(tile.id);
         h:=can.textheight(tile.id);
         can.textout((tx+bx-w) div 2, (ty+by-h) div 2, tile.id);
       end;
     end;


 {***************** figFits *****************}
 Function TForm1.figfits(tile:TTileType):boolean;
 var
   worktile:TTiletype;
   n:integer;
  {test to see if this tile fits the space remaining}
     {************ tryfit *************}
     function tryfit(x,y:integer):boolean;
     var
        i,j:integer;
      begin
      result:=true;
      j:=topleft.y;
      repeat
        inc(j);
        i:=topleft.x;
        repeat
          inc(i);
          if (i>maxx) or (j>maxy) or (figmap[j,i]<>0)
                             then result:=false;
        Until (i>=topleft.x+x) or  not (result);
      until (j>=topleft.y+y) or (not result);
    end;

    {********** loadfig *********}
    procedure loadfig(const Tile:TTileType);
    {add this tile to the tilelist}
    var i,j:integer;
    begin
        for j:=topleft.y+1 to topleft.y + tile.y
        do for i:=topleft.x+1 to topleft.x +tile.x
        do figmap[j,i]:=1;
        inc(thisfig.rectnbr);
        If thisfig.rectnbr<maxtilesinfig then
        With thisfig.tile[thisfig.rectnbr] do
        begin
          p1.x:=topleft.x;
          p1.y:=topleft.y;
          p2.x:=tile.x;
          p2.y:=tile.y;
          Id:=tile.Id;
          color:=tile.color;
        end;
        {else showmessage('More than '+ maxfigs +' found, reduce table size');}

        i:=0; j:=1;
        repeat  {find next location to fill}
          inc(i);
          if i>maxx then
          begin
            i:=1;
            inc(j);
          end
          until (figmap[j,i]=0) or ((i>=maxx) and (j>=maxy));
        topleft.x:=i-1; topleft.y:= j-1;
        {figfits:=true;}
    end;

    begin {figfits}
      result:=false;
      worktile:=tile;

      {need to try both orientations randonly, otherwise
       we'll select too many with same orientation}
      if random(2)=0 then  {rotate tile half the time}
      begin
        worktile.x:=tile.y;
        worktile.y:=tile.x;
      end;
      with worktile do
      begin
        If  tryfit(x,y) then
        begin
          loadfig(worktile);
          result:=true;
        end
        else
        if (x<>y) and tryfit(y,x)
        then
          begin
            n:=worktile.x;
            worktile.x:=worktile.y;
            worktile.y:=n;
            loadfig(worktile);
            result:=true;
          end;
      end;

    end; {figfits}

{**************** reset ************}
Procedure TForm1.reset;
    Var i,j:word;
        GCD:Integer;
    begin
      GCD:=getgcd;
      maxx:=AreaWEdt.value div GCD;
      maxy:=AreaHEdt.value div GCD;
      for i:=1 to maxx do
        for j:=1 to maxy do figmap[j,i]:=0;
      Topleft.x:=0; Topleft.y:=0;
      thisfig.rectnbr:=0;
    end;

{**************** GetGCD ***************}
Function TForm1.GetGCD:integer;
{Get greatest common divisor of tile sizes}
var
  i:integer;
  n:array{[1..2*maxtilesize]} of integer;
begin
  setlength(n,2*tilegrid.rowcount-2);
  with tilegrid do
  for i:=1 to rowcount-1 do
  begin
    n[2*(i-1)]:=strtoint(cells[1,i]);
    n[2*i-1]:=strtoint(cells[2,i]);
  end;
  result:=GCD(n);

  {set dimension edits so that allowable values are
   multiples of GCD for this tileset}
  with AreaHUD do
  begin
    min:=result;
    increment:=result;
  end;
  AreaHEdt.value:=(AreaHedt.value*result) div result;
  with AreaWUD do
  begin
    min:=result;
    increment:=result;
  end;
  AreaWEdt.value:=(AreaWedt.value*result) div result;
end;

{*************** TileGridSelectCell ***********}
procedure TForm1.TilegridSelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
  begin
    RemoveBtn.enabled:=true;
    ChangeBtn.enabled:=true;
  end;

{***************** AddBtnclick *************}
procedure TForm1.AddBtnClick(Sender: TObject);
{add a tile size}
  begin
    if TileForm.showmodal = mrOK then
    with TileForm, tilegrid do
    begin
      rowcount:=rowcount+1;
      row:=rowcount-1;
      cells[0,row]:=IdEdt.text;
      cells[1,row]:=inttostr(heightedt.value);
      cells[2,row]:=inttostr(widthedt.value);
      cells[3,row]:=inttostr(countedt.value);
      cells[4,row]:=inttohex(prototile.brush.color,6);
    end;
  end;

{***************** RemoveBtnLCick *************}
procedure TForm1.RemoveBtnClick(Sender: TObject);
{remove a tile size}
  var
    i,j:integer;
  begin
    if tilegrid.row>0 then
    with tilegrid do
    begin
      for i:= row to rowcount-2 do
      for j:=0 to colcount-1 do cells[j,i]:=cells[j,i+1];
      rowcount:=rowcount-1;
    end;
  end;



{******************** ChangeBtnclick *************}
procedure TForm1.ChangeBtnClick(Sender: TObject);
  begin
    if tilegrid.row=0 then exit;
    with TileForm,tilegrid do
    begin
      IdEdt.text:=cells[0,row];
      heightedt.value:=strtoint(cells[1,row]);
      widthedt.value:=strtoint(cells[2,row]);
      countedt.value:=strtoint(cells[3,row]);
      prototile.brush.color:=hexstrtoint(cells[4,row]);
      if showmodal = mrOK then
      begin
        cells[0,row]:=IdEdt.text;
        cells[1,row]:=inttostr(heightedt.value);
        cells[2,row]:=inttostr(widthedt.value);
        cells[3,row]:=inttostr(countedt.value);
        cells[4,row]:=inttohex(prototile.brush.color,6);
      end;
    end;
  end;


{******************** GetNextBtnClick ****************}
procedure TForm1.GetNextBtnClick(Sender: TObject);
{The central routine of the program
  Search for a set of tiles that ecactly covers the defined table area}
  var
    i,j,k,p, sum, count, mini:integer;
    done, found,f:boolean;
    t:array[1..MaxTableDim] of TTileType;
    StartTime:TDateTime;
    GCD:Integer;
  begin
    panel1.visible:=false;
    Screen.cursor:=crHourGlass;
    ScreenInfo.origin.x:=panel1.left;
    Screeninfo.origin.y:=panel1.top;
    GCD:=getGCD;
    If areaWedt.value>AreaHedt.value
    then p:=AreawEdt.value Div GCD else p:=AreaHEdt.value div GCD;
    screeninfo.scale.x:=panel1.width div (p* GCD) *GCD;
    ScreenInfo.scale.y:=panel1.height div (p * GCD) *GCD;
    LoadSelectFigs;
    Reset;
    done:=false;
    starttime:=Time;
    tag:=0;
    stopbtn.enabled:=true; {let the user stop the search}
    Repeat
      If ((topleft.x<maxx-1) or (topleft.y<maxy-1)) {not full yet}
      then
      begin
        repeat
            {fill in array of available empty spaces accross and down
                 from current location}
            i:=1;
            j:=1;
            mini:=maxx;
            if mini>maxtilesize then mini:=maxtilesize;
            while (figmap[topleft.y+j,topleft.x+i]=0)
                    and (topleft.y+j<=maxy)
            do
            begin
              while   (topleft.x+i<=maxx)
                  and (figmap[topleft.y+j,topleft.x+i]=0) do inc(i);
              if i<mini then mini:=i;

              for k:=1 to mini-1 do spacesavail[j,k]:=1;
              i:=1;
              inc(j);
            end;
            {now count how many available tiles could fit available space}
            count:=0;
            for i:= i to maxtilesize do
            for j:=1 to maxtilesize do
            begin
              if (spacesavail[j,i]>0) and (Sizesavail[j,i]>0) then
              begin
                inc(count);
                t[count].x:=i;
                t[count].y:=j;
              end;
              spacesavail[j,i]:=0; {reset}
            end;
            {If there are any then choose one randomly}
            If count>0 then
            begin
              p:=random(count)+1;
              found:=false;
              i:=1;
              {we know the x and y sizes, but we don't know which tile it is - find it}
              while not found do
              begin
                if not((selectfigs[i].x=t[p].x) and (selectfigs[i].y=t[p].y))
                   and  not ((selectfigs[i].x=t[p].y) and (selectfigs[i].y=t[p].x))
                then inc(i)
                else found:=true;
              end;
              f:=figfits(selectfigs[i]);
              If not f then showmessage('System Error: Selected Tile didn''t fit');
              p:=i;
            end
            else f:=false;
        Until (f) or (count=0) or (tag=1);
        If not f then
        begin
          Application.Processmessages;
          If secsperday*(time-starttime)>maxrunsecs  then
          begin
             showmessage('No complete tilings found in '
                     + #13
                     + 'Retry or increase tile set and then retry');
             done:=true;
          end
          else
          begin  {stuck - start over}
            reset;
            Loadselectfigs;
          end;
        end
        Else   {found a tile that fits}
        with selectfigs[p] do
        begin
          dec(nbr); {it fits so decrement number avail}
          sizesavail[y,x]:=nbr;
          sizesavail[x,y]:=nbr;
        end;
      end
      else {table top is completely tiled!}
      begin
        sum:=0;
        for i:= 1 to maxx do for j:=1 to maxy do sum:=sum+figmap[j,i];
        If sum=maxx*maxy then done:=true
        else begin repaint; reset;  LoadSelectFigs; end;
      end;
    Until done or (tag=1);
    thisfig.figheight:=areahedt.value;
    thisfig.figwidth:=areaWEdt.value;
    Screen.cursor:=crDefault;
    repaint;
    stopbtn.enabled:=false;
    savebtn.enabled:=true;
  end;

{******************** LoadSelectFigs ***************}
Procedure TForm1.loadselectfigs;
{Build an array of available tiles and sizes}
  var
    i,j,GCD :integer;
    {Sizesavail[x,y]=count of unused tiles with dimension X x Y}
    begin
    for i:=1 to maxtileSize do
        for j:=1 to maxTileSize do
        begin
          SizesAvail[j,i]:=0;
          SpacesAvail[j,i]:=0;
        end;
    GCD:=getGCD;
    for i := 1 to tilegrid.rowcount-1 do
    with tilegrid, Selectfigs[i] do
    begin
      Id:=cells[0,i];
      x:=strtoint(cells[1,i]) div GCD;
      y:=strtoint(cells[2,i]) div GCD;
      nbr:=strtoint(cells[3,i]);
      color:=hexstrtoint(cells[4,i]);
      SizesAvail[x,y]:=SizesAvail[x,y]+nbr;
      If x<>y then SizesAvail[y,x]:=SizesAvail[y,x]+nbr;
    end;
    maxfigs:=tilegrid.rowcount-1;
  end;

{************** FormPaint *************}
procedure TForm1.FormPaint(Sender: TObject);
{Draw all tiles on a table}
  var
    i,px,py:integer;
  begin
    if thisfig.rectnbr>0 then
    for i:=1 to thisfig.rectnbr do
          drawfig(thisfig.tile[i],ScreenInfo,canvas);
   if Tickbox.checked then
   with canvas do
   begin
     for i:=0 to areawedt.value do
     with screeninfo do
     begin
        px:=origin.x+ i*scale.x;
        py:=origin.y+areahedt.value*scale.y+5;
        moveto(px,py);
        lineto(px,py+10);
     end;
     for i:= 0 to areahedt.value do
     with screeninfo do
     begin
        py:=origin.y+ i*scale.y;
        px:=origin.x+areawedt.value*scale.x+5;
        moveto(px,py);
        lineto(px+10,py);
     end;
   end;
  end;

{*********************** SetMaxRunTime ***************}
procedure TForm1.SetMaxRunTime1Click(Sender: TObject);
{set maximum time to search for a solution}
begin
  with MaxRunForm do
  begin
    minEdt.Value:= maxrunsecs div 60;
    secEdt.Value:=maxrunsecs mod 60;
    ShowModal;
    maxrunsecs:= minedt.value*60+SecEdt.value;
  end;
end;

{**************** FormActivate **************}
procedure TForm1.FormActivate(Sender: TObject);
var
  f:string;
begin
  {randomize; }
  maxrunsecs:=30;
  with MaxRunForm do
  begin
    secedt.value:=maxrunsecs;
    minedt.value:=0;
  end;
  Thisfig:=TSavedFig.Create;
  with PrintLayoutForm do
  figsperpage:=printacrossedt.value*printdownEdt.value;
  opendialog1.Initialdir:=ExtractFilePath(Application.Exename);
  f:=opendialog1.Initialdir+'\'+'sample.til';
  if fileexists(f) then Loadtiles(f);
  with Tilegrid do
  begin
      cells[0,0]:='Id';
      cells[1,0]:='Height';
      cells[2,0]:='Width';
      cells[3,0]:='Count';
      cells[4,0]:='Color';
  end;
end;


{*************** LoadTiles **************}
procedure TForm1.LoadTiles(fname:string);
{Load a table size and set of tiles from a file}
var
  f:textfile;
  i:integer;
  line:string;
  s:string;
begin
    filename:=FName;
    assignfile(f,filename);
    system.reset(f);
    tilegrid.rowcount:=1;
    while not eof(f) do
    with tilegrid do
    begin
      readln(f,line);
      s:=getword(line);
      if (length(s)=4) and (comparetext(s,'TILE')=0)
      then
      begin
        rowcount:=rowcount+1;
        for i := 0 to 4 do
        begin
          s:=getword(line);
          cells[i,rowcount-1]:=s;
        end;
        if cells[4,rowcount-1]=''
        then cells[4,rowcount-1]:='008080';{default color}
      end
      else If (length(s)=9) and (comparetext(s,'TABLESIZE')=0)
      then
      begin
        s:=getword(line);
        AreaWEdt.value:=strtoint(s);
        s:=getword(line);
        AreaHEdt.Value:=strtoint(s);
      end;
    end;
    closefile(f);
  end;

{*********************** OpenTileSet1Click **************}
procedure TForm1.OpenTileSet1Click(Sender: TObject);
{Load a user specified set of tiles}
begin
  if opendialog1.execute then  Loadtiles(opendialog1.Filename);
end;

{***************** SveTiles *************}
Procedure TForm1.Savetiles;
{Save a tablesize and set of files}
var
  f:textfile;
  i:integer;
begin
  assignfile(f,filename);
  rewrite(f);
  writeln(f,'TABLESIZE '+inttostr(AreaWEdt.value)
          +','+IntToStr(AreaHEdt.value));
  with tilegrid do
  for i:=1 to rowcount-1  do

     writeln(f,'TILE '+cells[0,i]+','+cells[1,i]+','
                      +cells[2,i]+','+cells[3,i]+','
                      +cells[4,i]);

  closefile(f);
end;

{********************* Save1Click **************}
procedure TForm1.Save1Click(Sender: TObject);
{Menu option to save a set of tiles}
begin
  If filename<>'' then savetiles;
end;

{******************* SaveAs1Click **************}
procedure TForm1.SaveAs1Click(Sender: TObject);
{Menu option to save a set of files as specified by user}
begin
  If saveDialog1.execute then
  begin
    filename:=savedialog1.filename;
    SaveTiles;
  end;
end;

{***************** StopBtnClick *************}
procedure TForm1.StopBtnClick(Sender: TObject);
{set flag to stop a search}
begin
  tag:=1;
end;

(*
Function TForm1.pagefull:boolean;

begin
  if SaveFiglist.items.count>=figsperpage then  result:=true
  else result:=false;
end;
*)


{******************* SaveBtnClick ****************}
procedure TForm1.SaveBtnClick(Sender: TObject);
{Save a tiled table figure in a list for later review and printing}
var
  i,r,GCD:integer;
begin
  inc(figcount);
  SaveFigList.items.addobject('#'+inttostr(Figcount),thisfig);
  thisfig:=TSavedFig.create;
  with savefiglist do thisfig.assign(TSavedFig(items.objects[items.count-1]));
  GCD:=getgcd;
  If messagedlg('Reduce tile counts?',mtconfirmation,[mbyes,mbno],0)=mryes
  then
  with thisfig, tilegrid do
  for i:=1 to rectnbr do
  begin
    r:=1;
    while (r<=rowcount-1)  {find matching tile}
         and
         (*
            ((strtoint(cells[1,r])<>(fig[i].p2.x*GCD)) or
              (strtoint(cells[2,r])<>(fig[i].p2.y*GCD)))
          and
           ((strtoint(cells[2,r])<>(fig[i].p2.x*GCD)) or
              (strtoint(cells[1,r])<>(fig[i].p2.y*GCD)))
          *)
          (cells[0,r]<>tile[i].id)
          do inc(r);
     {reduce count}
    if r<=rowcount-1 then cells[3,r]:=inttostr(strtoint(cells[3,r])-1)
    else showmessage('System error: Tile of size '+inttostr(tile[i].p2.x*GCD)
                    +'X'
                    +inttostr(tile[i].p2.y*GCD)
                    +' not found ');
  end;
end;

{********************* SaveFigListClick ****************}
procedure TForm1.SaveFigListClick(Sender: TObject);
{Select a saved tiled table configuration for display}
var
  p:integer;
begin
  with savefiglist do thisfig.assign(TSavedFig(items.objects[itemindex]));
  areahedt.Value:=thisfig.figheight;
  areaWedt.Value:=THISFIG.figwidth;
  If areaWedt.value>AreaHedt.value
    then p:=AreawEdt.value else p:=AreaHEdt.value;
    screeninfo.scale.x:=panel1.width div p;
    ScreenInfo.scale.y:=panel1.height div p;
  repaint;
  end;

{********************** SaveFigListKeyPress ***************}
procedure TForm1.SaveFigListKeyPress(Sender: TObject; var Key: Char);
{Pressing enter on a saved table same as clicking}
Const
  kbEnter=#13;
begin
  If key = kbEnter then SaveFigListClick(Sender);
end;

{*************** SavedFigListKeyDown *****************}
procedure TForm1.SaveFigListKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
{Recognize delete key press and delete a saved table from list}
var
  i:integer;
begin
  If key=vk_delete then
  With SaveFigList do
  If (itemindex<items.count) and (items.count>0) then
  begin
    i:=itemindex;
    items.delete(itemindex);
    If i<=items.count-1 then itemindex:=i
    else itemindex:=items.Count-1;
    Savefiglistclick(sender);
  end;
end;

{***************** PrintOptionsClick *************}
procedure TForm1.PrintOptions1Click(Sender: TObject);
begin
  with PrintLayoutForm do
  begin
    showmodal;
    figsperpage:=printacrossedt.value*printdownEdt.value;
  end;
end;

{******************* PrintPreview1Click ************}
procedure TForm1.PrintPreview1Click(Sender: TObject);
{Preview a page of table configurations before printing}
var
  result:integer;
  StartAt:integer;
begin
  startAt:=0;
  with previewform, previewimage  do
  repeat
    with previewimage.canvas do
    begin
      brush.color:=clwhite;
      fillrect(previewimage.clientrect);
    end;
    if startat>0 then prevpage1.enabled:=true
    else prevpage1.enabled:=false;
    If startat+figsperpage<savefiglist.items.count then nextpage1.enabled:=true
    else nextpage1.enabled:=false;
    previewimage.canvas.pen.width:=2;
    makeprintimage(startat,previewimage.canvas);
    result:=showmodal;
    case result of
      mrPrevPage:
        startat:=startat-figsperpage;
      mrNextPage:
        startat:=startat+figsperpage;
      mrprint:
        begin;
          printsavedpages1Click(sender);
          result:=mrclose;
        end;
      mrlayout:
        begin
           printoptions1click(sender);
           startat:=0;
        end;
    end;
  until result=mrclose;
end;

{******************* MakePrintImage ****************}
Procedure TForm1.MakePrintimage(startat:integer;can:TCanvas);
var
  i,j,k,a, GCD:integer;
  Scaleinfo:TScaleInfo;
  pagewidth,pageheight:integer;
  wfig:TSavedfig;
  offsetx,offsety,panewidth,paneheight:integer;
  begin
    pagewidth:=can.cliprect.right-can.cliprect.left;
    pageheight:=can.cliprect.bottom-can.cliprect.top;
    k:=startat-1;
    panewidth:=pagewidth div printlayoutform.printacrossedt.value;
    paneheight:=pageheight div PrintLayoutform.printdownedt.value;
    {set origin 10% in from top corner of pane}
    {set scale to fill 80% of pane}
    offsetx:= panewidth div 10;
    offsety:= paneheight div 10;
    If areaWedt.value>AreaHedt.value
    then i:=AreawEdt.value else i:=AreaHEdt.value;
    GCD:=getGCD;
    scaleinfo.scale.x:= 8* panewidth div (10*i) * GCD;
    scaleinfo.scale.y:= 8* paneheight div (10*i)* GCD;
    with scaleinfo.scale do if x>y then x:=y  else y:=x;
    for j:= 1 to printLayoutform.printdownedt.value do
    begin
      scaleinfo.Origin.y:=(j-1)*paneheight +offsety;
      for i:= 1 to Printlayoutform.printacrossedt.value  do
      with scaleinfo, printer do
      begin
        inc(k);
        scaleinfo.origin.x:=(i-1)*panewidth +offsetx;
        If k>saveFigList.items.count-1 then break;
        wfig:=TSavedfig(SaveFigList.items.objects[k]);
        for a:=1 to wfig.rectnbr do
          drawfig(wfig.tile[a],ScaleInfo,can);
       end;
     end;
  end;

{******************* PrintSavedPages1Click *************}
procedure TForm1.PrintSavedPages1Click(Sender: TObject);
var
  startat:integer;
begin
  If printdialog1.Execute then
  begin
    startat:=0;
     While startat<Savefiglist.items.count-1 do
     begin
       printer.begindoc;
       printer.Canvas.pen.width:=4;
       Makeprintimage(startat,printer.canvas);
       printer.enddoc;
       inc(startat,figsperpage);
     end;
   end;
end;

procedure TForm1.CheckBoxClick(Sender: TObject);
begin
  repaint;
end;

end.