pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Add Sudoku solver application. Initial import (original code by Matthijs Willemstein).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7217 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
lazarus-bart
2020-01-04 14:39:11 +00:00
parent a00f9d0611
commit e154c5a902
6 changed files with 639 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

122
applications/sudoku/sudoku.lpi Normal file
View File

@ -0,0 +1,122 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<LazDoc Paths=""/>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<UseExcludeFileFilter Value="True"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="6">
<Unit0>
<Filename Value="sudoku.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="sudoku"/>
<CursorPos X="1" Y="26"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="241"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="sudokumain.pas"/>
<ComponentName Value="Form1"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="sudokumain.lrs"/>
<UnitName Value="sudokumain"/>
<CursorPos X="1" Y="23"/>
<TopLine Value="1"/>
<EditorIndex Value="1"/>
<UsageCount Value="241"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="sudokutype.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="sudokutype"/>
<CursorPos X="1" Y="24"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="241"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="origineel/sudokutype.pas"/>
<UnitName Value="sudokutype"/>
<CursorPos X="1" Y="202"/>
<TopLine Value="166"/>
<UsageCount Value="5"/>
</Unit3>
<Unit4>
<Filename Value="home/matthijs/Projecten/Lazarus/suntime/SunTime.pas"/>
<UnitName Value="SunTime"/>
<CursorPos X="30" Y="133"/>
<TopLine Value="121"/>
<UsageCount Value="12"/>
</Unit4>
<Unit5>
<Filename Value="home/matthijs/Projecten/Lazarus/suntime/suntime_com.pas"/>
<UnitName Value="suntime_com"/>
<CursorPos X="9" Y="218"/>
<TopLine Value="197"/>
<UsageCount Value="10"/>
</Unit5>
</Units>
<JumpHistory Count="1" HistoryIndex="0">
<Position1>
<Filename Value="sudokutype.pas"/>
<Caret Line="45" Column="1" TopLine="21"/>
</Position1>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<SearchPaths>
<SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

37
applications/sudoku/sudoku.lpr Normal file
View File

@ -0,0 +1,37 @@
program sudoku;
{$mode objfpc}{$H+}
{
***************************************************************************
* Copyright (C) 2006 Matthijs Willemstein *
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
}
uses
Interfaces, // this includes the LCL widgetset
Forms
{ add your units here }, sudokumain;
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

63
applications/sudoku/sudokumain.lfm Normal file
View File

@ -0,0 +1,63 @@
object Form1: TForm1
Left = 571
Height = 281
Top = 355
Width = 272
HorzScrollBar.Page = 271
VertScrollBar.Page = 280
ActiveControl = ButtonFill
Caption = 'Form1'
ClientHeight = 281
ClientWidth = 272
PixelsPerInch = 75
object Label1: TLabel
Left = 44
Height = 13
Top = 8
Width = 39
Caption = 'Label1'
Color = clNone
ParentColor = False
end
object StringGrid1: TStringGrid
Left = 44
Height = 182
Top = 40
Width = 182
ColCount = 9
DefaultColWidth = 20
FixedColor = clBtnFace
FixedCols = 0
FixedRows = 0
GridLineWidth = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goEditing, goSmoothScroll]
RowCount = 9
ScrollBars = ssAutoBoth
TabOrder = 2
TabStop = True
VisibleColCount = 9
VisibleRowCount = 9
OnDrawCell = StringGrid1DrawCell
OnSetEditText = StringGrid1SetEditText
end
object ButtonFill: TButton
Left = 44
Height = 25
Top = 228
Width = 75
BorderSpacing.InnerBorder = 2
Caption = 'Fill'
OnClick = ButtonFillClick
TabOrder = 0
end
object ButtonSolve: TButton
Left = 151
Height = 25
Top = 228
Width = 75
BorderSpacing.InnerBorder = 2
Caption = 'Solve'
OnClick = ButtonSolveClick
TabOrder = 1
end
end

23
applications/sudoku/sudokumain.lrs Normal file
View File

@ -0,0 +1,23 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TForm1','FORMDATA',[
'TPF0'#6'TForm1'#5'Form1'#4'Left'#3';'#2#6'Height'#3#25#1#3'Top'#3'c'#1#5'Wid'
+'th'#3#16#1#18'HorzScrollBar.Page'#3#15#1#18'VertScrollBar.Page'#3#24#1#13'A'
+'ctiveControl'#7#10'ButtonFill'#7'Caption'#6#5'Form1'#12'ClientHeight'#3#25#1
+#11'ClientWidth'#3#16#1#13'PixelsPerInch'#2'K'#0#6'TLabel'#6'Label1'#4'Left'
+#2','#6'Height'#2#13#3'Top'#2#8#5'Width'#2''''#7'Caption'#6#6'Label1'#5'Colo'
+'r'#7#6'clNone'#11'ParentColor'#8#0#0#11'TStringGrid'#11'StringGrid1'#4'Left'
+#2','#6'Height'#3#182#0#3'Top'#2'('#5'Width'#3#182#0#8'ColCount'#2#9#15'Defa'
+'ultColWidth'#2#20#10'FixedColor'#7#9'clBtnFace'#9'FixedCols'#2#0#9'FixedRow'
+'s'#2#0#13'GridLineWidth'#2#0#7'Options'#11#15'goFixedVertLine'#15'goFixedHo'
+'rzLine'#10'goVertLine'#10'goHorzLine'#13'goRangeSelect'#9'goEditing'#14'goS'
+'moothScroll'#0#8'RowCount'#2#9#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2
+#2#7'TabStop'#9#15'VisibleColCount'#2#9#15'VisibleRowCount'#2#9#10'OnDrawCel'
+'l'#7#19'StringGrid1DrawCell'#13'OnSetEditText'#7#22'StringGrid1SetEditText'
+#0#0#7'TButton'#10'ButtonFill'#4'Left'#2','#6'Height'#2#25#3'Top'#3#228#0#5
+'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#2#7'Caption'#6#4'Fill'#7'OnClic'
+'k'#7#15'ButtonFillClick'#8'TabOrder'#2#0#0#0#7'TButton'#11'ButtonSolve'#4'L'
+'eft'#3#151#0#6'Height'#2#25#3'Top'#3#228#0#5'Width'#2'K'#25'BorderSpacing.I'
+'nnerBorder'#2#2#7'Caption'#6#5'Solve'#7'OnClick'#7#16'ButtonSolveClick'#8'T'
+'abOrder'#2#1#0#0#0
]);

155
applications/sudoku/sudokumain.pas Normal file
View File

@ -0,0 +1,155 @@
unit sudokumain;
{
***************************************************************************
* Copyright (C) 2006 Matthijs Willemstein *
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Grids,
Buttons, StdCtrls, sudokutype;
type
{ TForm1 }
TForm1 = class(TForm)
ButtonSolve: TButton;
ButtonFill: TButton;
Label1: TLabel;
StringGrid1: TStringGrid;
procedure ButtonFillClick(Sender: TObject);
procedure ButtonSolveClick(Sender: TObject);
procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
aRect: TRect; aState: TGridDrawState);
procedure StringGrid1SetEditText(Sender: TObject; ACol, ARow: Integer;
const Value: string);
private
{ private declarations }
theValues: TValues;
procedure SolveSudoku;
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
// Voor delphi is de volgende regel noodzakelijk. Spatie tussen { en $ verwijderen
{ $R *.dfm }
{ TForm1 }
procedure TForm1.ButtonFillClick(Sender: TObject);
var
c, r: Integer;
begin
for c := 0 to pred(StringGrid1.ColCount) do
for r := 0 to pred(StringGrid1.RowCount) do
StringGrid1.Cells[c, r] := '';
Include(StringGrid1.Options, goEditing);
StringGrid1.SetFocus;
end;
procedure TForm1.ButtonSolveClick(Sender: TObject);
var
c, r: Integer;
begin
Exclude(StringGrid1.Options, goEditing);
SolveSudoku;
StringGrid1.Clean;
for c := 1 to 9 do begin
for r := 1 to 9 do begin
StringGrid1.Cells[c - 1, r - 1] := theValues[c, r];
if StringGrid1.Cells[c - 1, r - 1] = '0' then
StringGrid1.Cells[c - 1, r - 1] := ' ';
end;
end;
end;
procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
aRect: TRect; aState: TGridDrawState);
var
Kleur: Boolean;
begin
Kleur := False;
if Col in [0..2, 6..8] then begin
if Row in [0..2, 6..8] then begin
Kleur := True;
end;
end else begin
if Row in [3..5] then begin
Kleur := True;
end;
end;
if Kleur then begin
inc(aRect.Top, 1);
inc(aRect.Left, 1);
dec(aRect.Bottom, 1);
dec(aRect.Right, 1);
StringGrid1.Canvas.Brush.Color := clLtGray;
StringGrid1.Canvas.FillRect(aRect);
// Volgende regel is alleen in Delphi noodzakelijk.
// StringGrid1.Canvas.TextOut(aRect.Left, aRect.Top, StringGrid1.Cells[Col, Row]);
end;
end;
procedure TForm1.StringGrid1SetEditText(Sender: TObject; ACol, ARow: Integer;
const Value: string);
begin
if (Length(Value) >= 1) and (Value[1] in ['1'..'9']) then begin
theValues[ACol + 1, ARow + 1] := Value[1];
end else begin
theValues[ACol + 1, ARow + 1] := ' ';
end;
end;
procedure TForm1.SolveSudoku;
var
aSudoku: TSudoku;
c, r: Integer;
Stappen: Integer;
begin
for c := 0 to 8 do begin
for r := 0 to 8 do begin
if Length(StringGrid1.Cells[c, r]) >= 1 then begin
theValues[c + 1, r + 1] := StringGrid1.Cells[c, r][1];
end else begin
theValues[c + 1, r + 1] := ' ';
end;
end;
end;
aSudoku := TSudoku.Create;
Stappen := aSudoku.GiveSolution(theValues);
aSudoku.Free;
ShowMessage('Sudoku solved in ' + IntToStr(Stappen) + ' steps.');
end;
initialization
// Voor lazarus is deze regel nodig.
{$I sudokumain.lrs}
end.

239
applications/sudoku/sudokutype.pas Normal file
View File

@ -0,0 +1,239 @@
unit sudokutype;
{
***************************************************************************
* Copyright (C) 2006 Matthijs Willemstein *
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, StdCtrls;
type
Digits = set of 1..9;
TSquare = record
Value: Char; // The value of this square.
Locked: Boolean; // Wether or not the value is known.
DigitsPossible: Digits;
end;
TValues = Array[1..9,1..9] of char;
{ TSudoku }
TSudoku = class(TObject)
function GiveSolution(var Values: TValues): Integer;
private
Grid : Array[1..9, 1..9] of TSquare;
Steps: Integer;
procedure CalculateValues;
procedure CheckRow(c, r: Integer);
procedure CheckCol(c, r: Integer);
procedure CheckBlock(c, r: Integer);
procedure CheckDigits(d: Integer);
procedure Fill(Values: TValues);
procedure Solve;
function Solved: Boolean;
end;
implementation
const
cmin : Array[1..9] of Integer = (1, 1, 1, 4, 4, 4, 7, 7, 7);
cmax : Array[1..9] of Integer = (3, 3, 3, 6, 6, 6, 9, 9, 9);
function CountSetMembers(const ASet: Digits; var aValue: Integer): Integer;
var
D: Integer;
begin
Result := 0;
for D := 1 to 9 do begin
if D in ASet then begin
Inc(Result);
aValue := D;
end;
end;
end;
{ TSudoku }
procedure TSudoku.Fill(Values: TValues);
var
c, r: Integer;
begin
for c := 1 to 9 do begin
for r := 1 to 9 do begin
if Values[c, r] in ['1'..'9'] then begin
Grid[c, r].Locked := True;
Grid[c, r].Value := Values[c, r];
Grid[c, r].DigitsPossible := [StrToInt(Values[c, r])];
end else begin
Grid[c, r].Locked := False;
Grid[c, r].Value := '0';
Grid[c, r].DigitsPossible := [1, 2, 3, 4, 5, 6, 7, 8, 9];
end;
end;
end;
end;
procedure TSudoku.Solve;
var
c, r: Integer;
begin
Steps := 0;
repeat
inc(Steps);
for c := 1 to 9 do begin
for r := 1 to 9 do begin
if not Grid[c, r].Locked then begin
CheckRow(c, r);
CheckCol(c, r);
CheckBlock(c, r);
end;
end;
end;
for c := 1 to 9 do CheckDigits(c);
CalculateValues;
until Solved or (Steps > 50);
end;
function TSudoku.GiveSolution(var Values: TValues): Integer;
var
c, r: Integer;
begin
Fill(Values);
Solve;
for c := 1 to 9 do begin
for r := 1 to 9 do begin
Values[c, r] := Grid[c, r].Value;
end;
end;
Result := Steps;
end;
procedure TSudoku.CalculateValues;
var
c, r, d: Integer;
Value: Integer;
begin
for c := 1 to 9 do begin
for r := 1 to 9 do begin
if Grid[c, r].Locked then Continue;
if CountSetMembers(Grid[c, r].DigitsPossible, Value) = 1 then begin
Grid[c, r].Value := IntToStr(Value)[1];
Grid[c, r].Locked := True;
end;
end;
end;
end;
procedure TSudoku.CheckCol(c, r: Integer);
var
i, d: Integer;
begin
for i := 1 to 9 do begin
if i = r then continue;
for d := 1 to 9 do begin
if StrToInt(Grid[c, i].Value) = d then exclude(Grid[c, r].DigitsPossible, d);
end;
end;
end;
procedure TSudoku.CheckRow(c, r: Integer);
var
i, d: Integer;
begin
for i := 1 to 9 do begin
if i = c then continue;
for d := 1 to 9 do begin
if StrToInt(Grid[i, r].Value) = d then exclude(Grid[c, r].DigitsPossible, d);
end;
end;
end;
procedure TSudoku.CheckBlock(c, r: Integer);
var
i, j, d: Integer;
begin
for i := cmin[c] to cmax[c] do begin
for j := cmin[r] to cmax[r] do begin
if not ((i = c) and (j = r)) then begin
for d := 1 to 9 do begin
if StrToInt(Grid[i, j].Value) = d then exclude(Grid[c, r].DigitsPossible, d);
end;
end;
end;
end;
end;
procedure TSudoku.CheckDigits(d: Integer);
var
OtherPossible: Boolean;
c, r: Integer;
i: Integer;
value: Integer;
begin
for c := 1 to 9 do begin
for r := 1 to 9 do begin
if Grid[c, r].Locked
or (CountSetMembers(Grid[c, r].DigitsPossible, Value) = 1) then continue;
if d in Grid[c, r].DigitsPossible then begin
OtherPossible := False;
for i := 1 to 9 do begin
if i <> c then OtherPossible := (d in Grid[i, r].DigitsPossible);
if OtherPossible then Break;
end;
if not OtherPossible then begin
Grid[c, r].DigitsPossible := [d];
end else begin
OtherPossible := False;
for i := 1 to 9 do begin
if i <> r then OtherPossible := (d in Grid[c, i].DigitsPossible);
if OtherPossible then Break;
end;
if not OtherPossible then begin
Grid[c, r].DigitsPossible := [d];
end;
end;
end;
end;
end;
end;
function TSudoku.Solved: Boolean;
var
c, r: Integer;
begin
result := True;
for c := 1 to 9 do begin
for r := 1 to 9 do begin
if not Grid[c, r].Locked then begin
Result := False;
Break;
end;
end;
if not result then Break;
end;
end;
end.