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(''); Listbox1.Items.Add('
'); Listbox1.Items.Add('') else begin s := ' | ';
for r := 1 to MSize-1 do s := s + SolutionArray[n][r] + ' '; s := s + SolutionArray[n][MSize]; s := s + ' | ';
Listbox1.Items.Add(s);
end;
end;
Listbox1.Items.Add('