unit Magic1;

{
  Magic : Kwadraten-vierkant ---De asymmetrische versie---

  Auteur       : Matthijs Coster
  Datum        : 28-11-95
  Aanpassingen : 11-11-99

  Er worden n x n vierkanten berekend alwaar horizontaal en vertikaal
  n kwadraten zijn ingevuld. Een voorbeeld van zo'n vierkant is:

  1 6
  6 4

  aantallen vierkanten:

  2 :  4
  3 : 13
  4 : 14
  5 : 76
  6 :
  7 :
  
  Om hiertoe te komen worden eerst in de listbox L_Quad alle kwadraten
  van lengte n geplaatst. Niet al deze kwadraten voldoen om vooraan te
  mogen worden geplaatst (i.v.m. nullen). Daarom wordt een aparte
  listbox L_First gevuld met kwadraten die vooraan mogen voorkomen.
  Evenmin kunnen alle kwadraten op de laatste positie voorkomen. (Hier
  mogen slechts de cijfers [0,1,4,5,6,9] voorkomen, vandaar maken we
  ook gebruik van de listbox L_Last.
  Vervolgens is het een kwestie van matchen.
  Gezien de enorme beperkingen op de laatste digits worden de
  oplossingen van achter naar voren gegenereerd, (op de eerste rij na).

  Belangrijke andere variabelen:

  Ready : geeft aan hoeveel rijen/kolommen er matchen
} 

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, StdCtrls, Spin, Gauges, ExtCtrls, IniFiles;

const maxsol = 1000;

type

  TSolution = array[1..10] of string[10];

  TForm1 = class(TForm)
    L_Quad: TListBox;
    L_First: TListBox;
    L_Last: TListBox;
    B_Exit: TButton;
    B_Step2: TButton;
    B_Pause: TButton;
    B_Stop: TButton;
    B_Clear: TButton;
    B_Step1: TButton;
    B_Prev: TButton;
    B_Next: TButton;
    E_SolTot: TEdit;
    E_Sol: TEdit;
    StringGrid1: TStringGrid;
    Gauge1: TGauge;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel4: TPanel;
    Label1: TLabel;
    SpinEdit1: TSpinEdit;
    Label2: TLabel;
    E_Quad: TEdit;
    E_First: TEdit;
    Label3: TLabel;
    E_Last: TEdit;
    Label5: TLabel;
    B_Save: TButton;
    ListBox1: TListBox;
    SaveDialog1: TSaveDialog;
    L_Rev: TListBox;
    Label4: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    B_Accept: TButton;
    B_Load: TButton;
    B_SaveStep2: TButton;
    OpenDialog1: TOpenDialog;
    L_Pause: TLabel;
    procedure B_ExitClick(Sender: TObject);
    procedure B_Step1Click(Sender: TObject);
    procedure B_AcceptClick(Sender: TObject);
    procedure B_ClearClick(Sender: TObject);
    procedure B_Step2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure B_NextClick(Sender: TObject);
    procedure B_PrevClick(Sender: TObject);
    procedure B_PauseClick(Sender: TObject);
    procedure B_StopClick(Sender: TObject);
    procedure B_SaveClick(Sender: TObject);
    procedure B_LoadClick(Sender: TObject);
    procedure B_SaveStep2Click(Sender: TObject);
  private
    { Private declarations }
    procedure SearchSquare;
    procedure WriteSquare;
    procedure InitStap1;
    procedure InitClear;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  MSize : byte;
  solutionarray : array[1..maxsol] of TSolution;
  solutionH, SolutionV : TSolution;
  solutions,
  loper,
  LCount,
  FCount,
  QCount,
  Ready : integer;
  StopFlag : boolean;
  SquareIndex : array[0..20] of integer;

implementation

{$R *.DFM}

procedure TForm1.InitClear;
var i,j : longint;
begin
  for i := 1 to MSize do
  for j := 1 to MSize do
    StringGrid1.Cells[i-1,j-1] := '';
  L_Quad.Clear;
  L_First.Clear;
  L_Last.Clear;
  L_Rev.Clear;
  E_SolTot.Text := '0';
  E_Sol.Text := '0';
  Solutions := 0;
  loper := 1;
end;

procedure TForm1.InitStap1;
var SRect : TGridRect;
    i,j : longint;
const MASK = 'XXXXXXXXXX';
begin
  for i := 1 to maxsol do
  for j := 1 to 10 do
    solutionarray[i,j] := MASK;
  for j := 1 to 10 do
    SolutionH[j] := MASK;
  for j := 1 to 10 do
    SolutionV[j] := MASK;
  with SRect do
  begin
    Left := 1;
    Top := 1;
    Right := 0;
    Bottom := 0;
  end;
  Solutions := 0;
  loper := 1;
  with StringGrid1 do
  begin
    Selection := SRect;
    ColCount := MSize;
    RowCount := MSize;
    Width := MSize * 25 + 1;
    Height := MSize * 25 + 1;
  end;
  E_SolTot.Text := '0';
  E_Sol.Text := '0';
end;

procedure TForm1.SearchSquare;
var
  n, r, m : integer;
  s, t : string;
  OK, subOK : boolean;
begin
  while (Ready  >= 0) and not StopFlag do
  case Ready of
  0:if SquareIndex[Ready] = LCount then
    begin
      gauge1.Visible := false;
      B_Step2.Cursor := crDefault;
      dec(Ready);
    end
    else
    begin
      s := L_Last.Items.Strings[SquareIndex[Ready]];
      SquareIndex[Ready+1] := SquareIndex[Ready];
      inc(SquareIndex[Ready]);
      gauge1.progress := gauge1.progress + 1;
      SolutionH[1] := s;
      inc(Ready);
    end;
  1:if SquareIndex[Ready] = LCount then dec(Ready)
    else
    begin
      s := L_Last.Items.Strings[SquareIndex[Ready]];
      while (s[1] < SolutionH[1][1]) do
      begin
        inc(SquareIndex[Ready]);
        s := L_Last.Items.Strings[SquareIndex[Ready]];
      end;
      inc(SquareIndex[Ready]);
      if s[1] = SolutionH[1][1] then
      begin
        SquareIndex[Ready+1] := 0;
        SolutionV[1] := s;
        inc(Ready);
      end
      else dec(Ready);
      Application.ProcessMessages;
    end;
  2:if SquareIndex[Ready] = FCount then dec(Ready)
    else
    begin
      s := L_First.Items.Strings[SquareIndex[Ready]];
      inc(SquareIndex[Ready]);
      if s[1] = SolutionV[1][MSize] then
      begin
        SquareIndex[Ready+1] := 0;
        SolutionH[MSize] := s;
        inc(Ready);
      end;
    end;
  3:if SquareIndex[Ready] = FCount then dec(Ready)
    else
    begin
      s := L_First.Items.Strings[SquareIndex[Ready]];
      inc(SquareIndex[Ready]);
      if (s[1] = SolutionH[1][MSize]) and (s[MSize] = SolutionH[MSize][MSize]) then
      begin
        SolutionV[MSize] := s;
        SquareIndex[Ready+1] := 0;
        inc(Ready);
      end;
    end;
  else
    begin
      if Ready = 2*MSize then
      begin
        WriteSquare;
        dec(Ready);
      end
      else if SquareIndex[Ready] = QCount then dec(Ready)
      else if Ready mod 2 = 0 then
      begin {Een rij toevoegen}
        r := Ready div 2;
        s := L_Rev.items.Strings[SquareIndex[Ready]];
        while s[1] < SolutionV[1][r] do
        begin
          inc(SquareIndex[Ready]);
          s := L_Rev.items.Strings[SquareIndex[Ready]];
        end;
        if s[1] > SolutionV[1][r] then dec(Ready)
        else
        begin
          inc(SquareIndex[Ready]);
          OK := (s[MSize] = SolutionV[MSize][r]);
          if OK then
            for n := 2 to r-1 do
              OK := OK and (s[n] = SolutionV[n][r]);
          if OK then
          begin
            if r = 2 then
            begin
              for m := 2 to MSize - 1 do SolutionV[m][1] := SolutionH[1][m];
              for m := 2 to MSize - 1 do SolutionV[m][2] := s[m];
            end;
            if r = 3 then
              for n := 2 to MSize - 1 do
                if OK then
                begin
                  t := Copy(SolutionV[n], 1, 2);
                  m := 0;
                  SubOK := FALSE;
                  while (m < QCount) and NOT subOK do
                  begin
                    subOK := (pos(t, L_Rev.items.Strings[m]) = 1);
                    inc(m);
                  end;
                  OK := OK and subOK;
                end;
            if OK then
            begin
              SolutionH[r] := s;
              inc(Ready);
              SquareIndex[Ready] := 0;
            end
            else dec(Ready);
          end;
        end;
      end
      else
      begin {Een kolom toevoegen}
        r := Ready div 2;
        s := L_Rev.items.Strings[SquareIndex[Ready]];
        while s[1] < SolutionH[1][r] do
        begin
          inc(SquareIndex[Ready]);
          s := L_Rev.items.Strings[SquareIndex[Ready]];
        end;
        if s[1] > SolutionH[1][r] then dec(Ready)
        else
        begin
          inc(SquareIndex[Ready]);
          OK := (s[MSize] = SolutionH[MSize][r]);
          if OK then
            for n := 2 to r do
              OK := OK and (s[n] = SolutionH[n][r]);
          if OK then
          begin
            if r = 2 then
            begin
              for m := 3 to MSize - 1 do SolutionH[m][1] := SolutionV[1][m];
              for m := 3 to MSize - 1 do SolutionH[m][2] := s[m];
              for n := 3 to MSize - 1 do
                if OK then
                begin
                  t := Copy(SolutionH[n],1,2);
                  m := 0;
                  SubOK := FALSE;
                  while (m < QCount) and NOT subOK do
                  begin
                    subOK := (pos(t, L_Rev.items.Strings[m]) = 1);
                    inc(m);
                  end;
                  OK := OK and subOK;
                end;
            end;
            if OK then
            begin
              SolutionV[r] := s;
              inc(Ready);
              SquareIndex[Ready] := 0;
              Application.ProcessMessages;
            end
            else dec(Ready);
          end;
        end;
      end;
    end;
  end;
end;

procedure TForm1.WriteSquare;
var
  u,v : byte;
  s : string;
begin
  inc(solutions);
  if Solutions <= maxsol then
  begin
    for u := MSize downto 1 do
    begin
      s := '';
      for v := MSize downto 1 do s := s + SolutionH[u][v];
      solutionarray[Solutions][MSize - u + 1] := s;
    end;
    if Solutions = 1 then
    begin
      for u := 1 to MSize do
      for v := 1 to MSize do
        StringGrid1.Cells[v-1,u-1] := solutionarray[1][u][v];
      e_Sol.text := IntToStr(solutions);
    end;
  end;
  e_SolTot.text := IntToStr(solutions);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MSize := 3;
  InitStap1;
end;

procedure TForm1.B_AcceptClick(Sender: TObject);
begin
  MSize := SpinEdit1.Value;
  InitStap1;
end;

procedure TForm1.B_ExitClick(Sender: TObject);
begin
  Form1.Close;
end;

procedure TForm1.B_Step1Click(Sender: TObject);
var nummin, nummax : longint;
    i, j : longint;
    s, t : string;
begin
  initclear;
  nummin := 1;
  for i := 1 to MSize div 2 do nummin := 10 * nummin;
  if MSize mod 2 = 0 then
  begin
    nummax := nummin - 1;
    nummin := Trunc(nummin / sqrt(10)) + 1;
  end
  else nummax := Trunc(nummin * sqrt(10));
  for i := nummin to nummax do
  begin
    s := IntToStr(i * i);
    L_Quad.Items.Add(s);
    t := '';
    for j := MSize downto 1 do t := t + s[j];
    L_Rev.Items.Add(t);
    if pos('0',t) = 0 then L_First.Items.Add(t);
    if (pos('2',t) = 0) AND (pos('3',t) = 0) AND (pos('7',t) = 0)
                        AND (pos('8',t) = 0) then L_Last.Items.Add(t);
  end;
  LCount := L_Last.Items.Count;
  FCount := L_First.Items.Count;
  QCount := L_Quad.Items.Count;
  L_Quad.Clear;
  for i := 0 to QCount - 1 do
  begin
    s := L_Rev.Items[i];
    t := '';
    for j := MSize downto 1 do t := t + s[j];
    L_Quad.Items.Add(t);
  end;
  E_Quad.Text := IntToStr(QCount);
  E_First.Text := IntToStr(FCount);
  E_Last.Text := IntToStr(LCount);
end;

procedure TForm1.B_ClearClick(Sender: TObject);
begin
   initclear;
end;

procedure TForm1.B_NextClick(Sender: TObject);
var n,p : longint;
begin
  If (Solutions > Loper) and (maxsol > loper) then
  begin
    inc(loper);
    for n := 1 to MSize do
    for p := 1 to MSize do
      StringGrid1.Cells[p-1,n-1] := solutionarray[loper][n][p];
  end;
  e_Sol.text := IntToStr(loper);
end;

procedure TForm1.B_PrevClick(Sender: TObject);
var n,p : longint;
begin
  If Loper > 1 then
  begin
    dec(loper);
    for n := 1 to MSize do
    for p := 1 to MSize do
      StringGrid1.Cells[p-1,n-1] := solutionarray[loper][n][p];
  end;
  e_Sol.text := IntToStr(loper);
end;

procedure TForm1.B_PauseClick(Sender: TObject);
begin
  if Ready >= 0 then
  begin
    StopFlag := not StopFlag;
    gauge1.Visible := not gauge1.Visible;
    L_Pause.Visible := not L_Pause.Visible;
  end;
  if not StopFlag then SearchSquare;
end;

procedure TForm1.B_StopClick(Sender: TObject);
begin
  Ready := -1;
  StopFlag := False;
  gauge1.Visible := false;
  B_Step2.Cursor := crDefault;
end;

procedure TForm1.B_Step2Click(Sender: TObject);
begin
  B_Step2.Cursor := crHourGlass;
  SquareIndex[0] := 0;
  with gauge1 do
  begin
    maxvalue := LCount;
    progress := 0;
    Visible := true;
  end;
  Ready := 0;
  SearchSquare;
end;

procedure TForm1.B_LoadClick(Sender: TObject);
var i : integer;
begin
  if OpenDialog1.Execute then
  begin
    Listbox1.Visible := True;
    Listbox1.Clear;
    Listbox1.Items.LoadFromFile(OpenDialog1.Filename);
    Listbox1.Visible := True;
    MSize := StrToInt(Listbox1.Items.Strings[1]);
    Ready := StrToInt(Listbox1.Items.Strings[2]);
    for i := 0 to Ready do
      SquareIndex[i] := StrToInt(Listbox1.Items.Strings[i+2]);
  end;
end;

procedure TForm1.B_SaveStep2Click(Sender: TObject);
var i : integer;
begin
  if SaveDialog1.Execute then
  begin
    Listbox1.Visible := True;
    Listbox1.Clear;
    Listbox1.Items.Add(IntToStr(MSize));
    Listbox1.Items.Add(IntToStr(Ready));
    for i := 0 to Ready do
      Listbox1.Items.Add(IntToStr(SquareIndex[i]));
    Listbox1.Items.SaveToFile(SaveDialog1.Filename);
  end;
end;

procedure TForm1.B_SaveClick(Sender: TObject);
var
  i, j, n, r : integer;
  s : string;
begin
  if SaveDialog1.Execute then
  begin
    Listbox1.Visible := True;
    Listbox1.Clear;
    Listbox1.Items.Add('<HTML>');
    Listbox1.Items.Add('<HEAD>');
    Listbox1.Items.Add('<TITLE>');
    Listbox1.Items.Add('Squares filled with squares of size ' + IntToStr(MSize));
    Listbox1.Items.Add('</TITLE>');
    Listbox1.Items.Add('<FONT FACE=Arial>');
    Listbox1.Items.Add('</HEAD>');
    Listbox1.Items.Add('<BODY BGCOLOR="FFDDAA">');
    Listbox1.Items.Add('<TABLE BGCOLOR="AADDFF" CELLPADDING=10 CELLSPACING=0 BORDER=1>');
    for j := 0 to (Solutions-1) div 5 do
    begin
      Listbox1.Items.Add(' <TR>');
      for i := 1 to 5 do
      begin
        n := 5 * j + i;
        if n > Solutions then Listbox1.Items.Add('  <TD BGCOLOR="FFFFFF">&nbsp;</TD>')
        else
        begin
          s := '  <TD BGCOLOR="FFFFFF">';
          for r := 1 to MSize-1 do s := s + SolutionArray[n][r] + '<BR>';
          s := s + SolutionArray[n][MSize];
          s := s + '</TD>';
          Listbox1.Items.Add(s);
        end;
      end;
      Listbox1.Items.Add(' </TR>');
    end;
    Listbox1.Items.Add('</TABLE>');
    Listbox1.Items.Add('</BODY>');
    Listbox1.Items.Add('</HTML>');
    Listbox1.Items.SaveToFile(SaveDialog1.Filename);
  end;
end;

end.