 |
Sudoku solver source code listing |  |
 |
Sudoku helper/solver version 2.1A
David E. Dirkse
Castricum
the Netherlands
unit Unit1;
{SUDOKU version 1.2 july 2005
V2.0 : cut & paste
V2.1 : group vs row, group vs column checks.
added reduce-2
added: autofill numbers different color
added: backspace deletes all autofill numbers
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, ExtCtrls, davArrayBtn, Buttons, clipbrd;
type
TForm1 = class(TForm)
DavArrayBtn1: TDavArrayBtn;
PaintBox1: TPaintBox;
StaticText1: TStaticText;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
DavArrayBtn2: TDavArrayBtn;
Timer1: TTimer;
SpeedButton1: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure DavArrayBtn1BtnPaint(sender: TObject; BtnNr: Byte;
status: TBtnStatus);
procedure DavArrayBtn1BtnChange(sender: TObject; BtnNr: Byte;
status: TBtnStatus; button: TMouseButton);
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure DavArrayBtn2BtnPaint(sender: TObject; BtnNr: Byte;
status: TBtnStatus);
procedure DavArrayBtn2BtnChange(sender: TObject; BtnNr: Byte;
status: TBtnStatus; button: TMouseButton);
procedure FormPaint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
procedure DavArrayBtn1Leave(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type Tbtntype = (btOpen,btSave,btClipboard,btErase,
btplace,btBegin,btSearch,btHelp,btNone);
var
Form1: TForm1;
square : byte = 50;
implementation
uses helpUnit;
{$R *.DFM}
type
TSearchBtnType = (sbShow,sbWarn,sbFill,sbFillAll,
sbReduce,sbBackspace,sbNone);
TentryType = (etOrg,etAuto,etManual);//way number was added
Tnumber = record
nr : byte;
org : boolean;
end;
Tnumber3 = record
nr : byte;
et : TentryType;
end;
Trc = (rcNone,rcRow,rcColumn);
Tgamestatus = (gsInit,gsWait,gsPlace,gsSearch,gsEnd);
TSudoku = array[1..9,1..9] of TNumber; //ioboard
Tsudoku3 = array[1..9,1..9] of Tnumber3;//puzzle board
TMove = record
col : byte;
row : byte;
nr : byte;
end;
Tmsg = (msgInfo,msgError,msgHint,msgOpl,msgHelp,msgSaved);
TTimerControl = (coIdle,coFillSingles,coBackspace,coClearBtn);
THintResult = (hdNone,hdEmptyField,hdOnly,
hd0row,hd0column,hd0group,
hd1row,hd1column,hd1group);
THintData = record
row : byte;
column : byte;
group : byte;
digit : byte;//0nly free digit in row/column/group
status : THintResult;
end;
Tduplicate = (dupOK,dupRow,dupColumn,dupGroup);
const bgColor = $e0c000;
markBGcolor = $00b0ff;
ArrayBtn1colors : TcolorTable =
($d0d0ff,$d0ffd0,$ff0000,$00ff00,$000000);
ArrayBtn2Colors : TColortable =
($d0d0ff,$d0ffd0,$ff0000,$00ff00,$000000);
leader = 'SUDOKU - helper : ';
welcome = 'welcome at the SUDOKU - helper';
var IOboard : TSudoku;
board : TSudoku3;
markI : integer = 0;
markJ : integer = 0;
gameStatus : Tgamestatus;
goodnumber : boolean = false;//true if valid number added to field
Timercontrol : TTimercontrol;
BGmap : Tbitmap; //holds background of board
MarkMap : TBitmap; //holds marker
Unmarkmap : Tbitmap; //holds clear,unmark image
entryType : TentryType; //for color of number
//------comp search data
Xboard : array[1..9,1..9] of word;
RowSums : array[1..9] of word;
ColSums : array[1..9] of word;
groupSums: array[1..9] of word;
hintflag : boolean = false; //show hint on fieldchange
showFlag : boolean = false; //show choices per field
addList : array[1..81] of TMove;//last added numbers
lastEntry : byte = 0; //last added entry in addlist
HintData : THintData;
Totaldigits : byte = 0;
//
Pallow : array[1..9] of word; //for hint reduction
Psum : array[1..9] of word;
Xvalue : array[1..9] of word;
Pmask : array[1..9] of word;
triple : array[1..3,1..9] of word; //for hintreduction2
//--------file
FSodoku : file of Tsudoku;
//-------forward declarations
procedure searchBtnHide; forward;
procedure msg(tt : Tmsg; var s : string); forward;
procedure painthintfield(i,j : byte); forward;
procedure MakeHintfields; forward;
procedure showHintFields; forward;
procedure AnalyzeHints; forward;
procedure reportHintData; forward;
procedure Opengame; forward;
procedure saveGame; forward;
procedure HintReduction; forward;
procedure Hintreduction2; forward;
procedure loadfromP1; forward;
procedure procClipboard; forward;
procedure HintReductionShow; forward;
//---------------general actions (board), conversions
procedure setTotaldigits;
//count nr of digits added in game
//call after initOrg, load from file, pressing search
var i,j : byte;
begin
totaldigits := 0;
for j := 1 to 9 do
for i := 1 to 9 do
if board[i,j].nr <> 0 then inc(totaldigits);
end;
function IJtoGroupNr(i,j : byte) : byte;
//return group Nr of field [i,j]
var x,y : byte;
begin
x := (i-1) div 3;
y := (j-1) div 3;
result := x + 3*y + 1;
end;
function popcount(bb : word) : byte;
//returns number of bits set in kk
var k : byte;
begin
result := 0;
for k := 1 to 9 do
if (1 shl k) and bb <> 0 then inc(result);
end;
function bitNrToDigit(w : word; n : byte) : byte;
//returns number corresponding to n th bit set in hint word w
//example: if n=3, the 3 rd bit set (from right) is located
//and the corresponding digit is returned
//if no bit found, return 0
var i,count : byte;
begin
count := 0;
for i := 1 to 9 do
begin
w := w shr 1;
if (w and 1) <> 0 then
begin
inc(count);
if count = n then
begin
result := i;
exit; //found
end;
end;
end;
result := 0; //not found
end;
function PixelToIJ(x : integer) : byte;
//x,y pixel to field
begin
result := (x div square) + 1;
end;
function getFieldrect(i,j : byte) : Trect;
begin
with result do
begin
left := (i-1)*square + 1;
top := (j-1)*square + 1;
right := i*square;
bottom := j*square;
end;
end;
procedure clearAll;
var i,j : byte;
s : string;
begin
for i := 1 to 9 do
for j := 1 to 9 do board[i,j].nr := 0;
//
with form1 do
begin
paintbox1.invalidate;
caption := leader;
s := 'board erased';
msg(msgInfo,s);
end;
lastEntry := 0;//clear addlist
totaldigits := 0;
end;
function getNumFieldrect(i,j : byte) : Trect;
begin
with result do
begin
left := (i-1)*square + 4;
top := (j-1)*square + 4;
right := i*square - 4;
bottom := j*square - 4;
end;
end;
function CheckDuplicate(ii,jj,nr : byte) : Tduplicate;
//return true if nr already present in row,column,group
var i,j,sum : byte;
x,y : byte;
begin
if nr = 0 then
begin
if board[ii,jj].nr = 0 then result := dupRow //no double entry
else result := dupOk; //always erase digit
exit;
end;
// //nr <> 0
sum := 0;
for i := 1 to 9 do //check row
if (board[i,jj].nr = nr) then inc(sum);
if sum <> 0 then
begin
result := dupRow;
exit;
end;
for i := 1 to 9 do //check column
if (board[ii,i].nr = nr) then inc(sum);
if sum <> 0 then
begin
result := dupColumn;
exit;
end;
x := ((ii-1) div 3)*3 + 1; //check group
y := ((jj-1) div 3)*3 + 1;
for i := 0 to 2 do
for j := 0 to 2 do
if board[x+i,y+j].nr = nr then inc(sum);
if sum <> 0 then
begin
result := dupGroup;
exit;
end;
result := dupOK;
end;
//----low level draw procedures
procedure paintmarker(i,j : byte);
//paint marker at field [i,j]
var r : Trect;
begin
r := getFieldrect(i,j);
form1.paintbox1.canvas.draw(r.Left,r.top,markmap);
end;
procedure EraseField(i,j : byte);
var r : Trect;
begin
getfieldrect(i,j);
with form1.paintbox1.canvas do
begin
copymode := cmSRCcopy;
copyrect(r,BGmap.canvas,r);
end;
end;
procedure paintUnMark(i,j : byte);
var R : Trect;
begin
r := getFieldrect(i,j);
with unmarkmap do with canvas do
begin
copymode := cmSRCCopy;
copyrect(rect(0,0,width,height),BGmap.canvas,r);
brush.Style := bsSolid;
brush.Color := $0;
fillrect(rect(4,4,width-4,height-4));//make transparent
end;
form1.paintbox1.canvas.draw(r.Left,r.top,UnMarkmap);
end;
procedure EraseNumberfield(i,j : byte);
var r1,r2 : Trect;
begin
r1 := getfieldrect(i,j);
r2 := getNumFieldrect(i,j);
with UnMarkmap do with canvas do //prepare unmarkmap
begin
brush.style := bsSolid;
brush.color := 0;
fillrect(rect(0,0,width,height));
copymode := cmSRCCopy;
copyrect(rect(4,4,width-4,height-4),BGmap.canvas,r2);
end;
form1.paintbox1.canvas.draw(r1.left,r1.top,UnMarkmap);
end;
procedure paintNumber(i,j : byte; nr : byte; nt : TentryType);
var r : trect;
x,y : integer;
ch : string[1];
begin
r := getNumfieldRect(i,j);
ch := inttostr(nr);
eraseNumberField(i,j);
with form1.PaintBox1.canvas do
begin
font.height := trunc(square * 0.8);
x := (square-8-textwidth(ch)) div 2;
y := (square-8-textheight(ch)) div 2;
if nr <> 0 then
begin
brush.style := bsClear;
font.color := $ffffff;
textout(r.left+1+x,r.top+1+y,ch);
case nt of
etOrg : font.color := $d0;
etAuto : font.color := $b0b0b0;
etManual : font.color := $0;
end;
textout(r.left-1+x,r.top-1+y,ch);
end;
end;//with
end;
//-----------marker control
procedure SetMarker(i,j : byte);
begin
if markI <> 0 then paintUnMark(markI,markJ);
markI := i; markJ := j;
paintMarker(i,j);
end;
procedure ClearMarker;
begin
if markI <> 0 then
begin
paintUnmark(markI,markJ);
markI := 0;
markJ := 0;
end;
end;
procedure marknextField;
var key1 : word;
begin
key1 := VK_RIGHT;
form1.formkeydown(form1,key1,[]);
end;
procedure writeNumField(i,j : byte);
//write number or hints in field
//called by paintbox1 paint
begin
with board[i,j] do
if (nr = 0) and hintflag then painthintfield(i,j)
else paintNumber(i,j,nr,et);
end;
//-------add original number
procedure AddOrgNumber(nr : byte);
//at marker
label fill;
begin
goodnumber := false;
if nr = 0 then goto fill;
if CheckDuplicate(markI,markJ,nr) <> dupOK then
begin
beep;
exit;
end
else board[markI,markJ].et := etOrg;
//
fill:
goodnumber := true;
board[markI,markJ].nr := nr;
paintnumber(markI,markJ,nr,etOrg);
end;
procedure AddToList(ii,jj,n : byte);
//remove previous [col,row] entry
var i,h : byte;
begin
h := 0;
for i := 1 to lastEntry do
with addlist[i] do
if (col = ii) and (row = jj) then
begin
h :=i;
break;
end;
if h <> 0 then //previous entry found at h
begin
for i := h to lastentry-1 do //move list down
begin
addList[i].col := addlist[i+1].col;
addlist[i].row := addlist[i+1].row;
addlist[i].nr := addlist[i+1].nr;
end;
dec(lastEntry);
end;
if n <> 0 then inc(lastEntry) else exit;
with Addlist[lastEntry] do
begin
col := ii;
row := jj;
nr := n;
end;
end;
//----------add number during search
procedure tryAddNumber(n : byte);
//called on keyboard event
const mmm = ' already present in ';
var s : string;
dupInfo : Tduplicate;
et : TentryType;
begin
goodnumber := false;
if (board[markI,markJ].nr <> 0) and
(board[markI,markJ].et <> etManual) then
begin
beep;
exit;//can only overwrite manual number
end;
dupInfo := CheckDuplicate(markI,markJ,n);
case dupInfo of
dupRow : s := inttostr(n)+mmm+'row '+inttostr(markJ);
dupcolumn : s := inttostr(n)+mmm+'column '+inttostr(markI);
dupGroup : s := inttostr(n)+mmm+' group '+inttostr(IJtoGroupNr(markI,markJ));
end;
if dupInfo <> dupOK then
begin
msg(msgError,s);
beep;
exit; //exit if number allready in row/column/group
end;
form1.statictext1.caption := '';
if timercontrol = coFillsingles then et := etAuto else et := etmanual;
board[markI,markJ].nr := n;
board[markI,markJ].et := et;
paintNumber(markI,markJ,n,et);
goodnumber := true;
AddToList(markI,markJ,n);
settotaldigits; //count digits
if totaldigits = 81 then
begin
s := 'solution found';
msg(msgOpl,s);
gamestatus := gsEnd;
end
else
begin
if showflag then
begin
makehintfields;
showHintFields;
if hintflag then
begin
AnalyzeHints;
reportHintData;
end;
end;//if showflag
end;//else
end;
procedure moveback;
//take last entry in Addlist back
var c,r : byte;
manFlag : boolean;
begin
if lastEntry = 0 then exit; //if no entries
manFlag := false;
repeat
with addList[lastentry] do
if board[col,row].et = etAuto then
begin
board[col,row].nr := 0;
paintnumber(col,row,0,etmanual);//rewrite,erase field
dec(lastEntry);
end
else manFlag := true;
until (lastEntry = 0) or manflag;
if manflag then
begin
with AddList[lastEntry] do
setmarker(col,row); //mark removing field
timercontrol := coBackspace;
form1.timer1.enabled := false;
form1.timer1.enabled := true;
end
else if showflag then //hint processing
begin
makehintfields;
showHintFields;
if hintflag then
begin
AnalyzeHints;
reportHintData;
end;
end;//if showflag
end;
procedure movebackDelayed;
//called by timer after placing marker
begin
with addlist[lastEntry] do
begin
board[col,row].nr := 0;
paintnumber(col,row,0,etmanual);//rewrite,erase field
end;
dec(lastEntry);
//
if showflag then //hint processing
begin
makehintfields;
showHintFields;
if hintflag then
begin
AnalyzeHints;
reportHintData;
end;
end;//if showflag
end;
procedure InitOrg;
//set board to orgBoard
var i,j : byte;
s : string;
begin
for i := 1 to 9 do
for j := 1 to 9 do
if board[i,j].et <> etOrg then board[i,j].nr := 0;
form1.paintbox1.Invalidate;
s := 'restored original puzzle';
msg(msgInfo,s);
end;
//------------messages--------------------------
procedure msg(tt : Tmsg; var s : string);
//put message in statictext1
const msgcolor : array[msgInfo..msgHelp] of longInt =
($000000,$0000ff,$00d000,$ff0000,$b0b0b0);
saveText : string = '';
saveMsg : Tmsg = msgInfo;
begin
case tt of
msgInfo,msgerror,msgHint,msgOpl :
begin
savetext := s;
savemsg := tt;
end;
msgSaved :
begin
tt := saveMsg;
s := savetext;
end;
end;//case
with form1.statictext1 do
begin
font.color := msgColor[tt];
caption := s;
end;
end;
//----search support
procedure paintHintField(i,j : byte);
//shows number choice in a field
//acc to xboard[i,j] bits
var sum : word;
dx,dy : byte;
nr : byte;
r : Trect;
row,col : byte;
begin
r := getNumFieldrect(i,j);
with form1.paintbox1.canvas do
begin
eraseNumberfield(i,j);
brush.style := bsclear;
font.height := trunc(square*0.3);
font.color := $0;
dx := trunc(square*0.2);
dy := textheight('9')-2;
sum := Xboard[i,j];
for nr := 1 to 9 do
begin
row := (nr-1) div 3;
col := (nr-1) mod 3+1;
if ((1 shl nr) and sum) <> 0 then
textout(r.left+col*dx,r.top+row*dy,inttostr(nr));
end;
end;//with
end;
//-------------hint process------------
procedure MakeHintfields;
//make Xboard array 9*9 of word
//each word has bit set for possible digit
//make Row & column sums
var i,j,group,x,y : byte;
begin
for j := 1 to 9 do
for i := 1 to 9 do
if board[i,j].nr = 0 then Xboard[i,j] := 0 //clear Xboard
else Xboard[i,j] := 1 shl board[i,j].nr; //set xboard
//
for i := 1 to 9 do
begin
Rowsums[i] := $3fe; //init RowSums
ColSums[i] := $3fe; //init Column sums
GroupSums[i] := $3fe; //init group sums
end;
//make row sums
for j := 1 to 9 do
for i := 1 to 9 do RowSums[j] := RowSums[j] xor Xboard[i,j];
//make Column sums
for i := 1 to 9 do
for j := 1 to 9 do ColSums[i] := ColSums[i] xor Xboard[i,j];
//make group sums
for group := 1 to 9 do
begin
x := ((group-1) mod 3)*3 + 1;
y := ((group-1) div 3)*3 + 1; //[x,y] is left top of group
for j := 0 to 2 do
for i := 0 to 2 do
GroupSums[group] := Groupsums[group] xor Xboard[x+i,y+j];
end;
//combine column-row-group
for j := 1 to 9 do
for i := 1 to 9 do
if board[i,j].nr = 0 then
Xboard[i,j] := ColSums[i] and Rowsums[j] and GroupSums[IJtoGroupNr(i,j)];
end;
procedure showHintFields;
var i,j : byte;
begin
for j := 1 to 9 do
for i := 1 to 9 do
if board[i,j].nr = 0 then painthintfield(i,j);
end;
procedure ReportHintData;
//called to report hintstatus in statictext1
const ssingle = 'single choice: ';
s0digit = 'missing number ';
var s : string;
m : Tmsg;
function AddS1 : string;
begin
with HintData do
result := 'row '+inttostr(row)+' column '+ inttostr(column);
end;
begin
m := msgInfo;
with HintData do
case status of
hdNone : s := '';
hdEmptyField:
begin
m := msgError;
s := 'empty field: ' + AddS1;
end;
hdOnly :
begin
m := msghint;
s := 'single number: '+ '('+inttostr(digit)+') ' + AddS1;
end;
hd1row :
begin
m := msgHint;
s := ssingle + '('+inttostr(digit)+') in row '+inttostr(row);
end;
hd1column :
begin
m := msghint;
s := ssingle + '('+inttostr(digit)+') in column '+inttostr(column);
end;
hd1group :
begin
m := msghint;
s := ssingle+'('+inttostr(digit)+') in group '+inttostr(group);
end;
hd0row :
begin
m := msgerror;
s := s0digit + inttostr(digit) + ' in row '+ inttostr(row);
end;
hd0column :
begin
m := msgerror;
s := s0digit + inttostr(digit) + ' in column '+ inttostr(column);
end;
hd0group :
begin
m := msgerror;
s := s0digit + inttostr(digit) + ' in group '+ inttostr(group);
end;
end;//case
msg(m,s);
with hintData do
begin
if (status = hdOnly) or (status = hd1row) or
(status = hd1column) or (status = hd1group) then
setmarker(column,row);
end;//with
end;
procedure AnalyzeHints;
//make hintdata, no actions
var i,j,p,m,n,q,x,y : byte;
w : word;
rowdigits,columndigits,groupdigits : array[1..9,1..9] of byte;
begin
HintData.status := hdNone; //reset
//search empty fields
with HintData do
begin
for j := 1 to 9 do
for i := 1 to 9 do
if Xboard[i,j] = 0 then
begin
row := j;
column := i;
status := hdEmptyfield;
exit;
end;//with
//setup digit counters
for i := 1 to 9 do //clear digit counts
for j := 1 to 9 do
begin
rowdigits[i,j] := 0; //[row,digitcount]
columndigits[i,j] := 0; //[column,digitcount]
groupdigits[i,j] := 0; //[group,digitcount]
end;
for j := 1 to 9 do //fill digit counters
for i := 1 to 9 do
for p := 1 to 9 do //p selects the digits
begin
w := 1 shl p; //form mask
if (xboard[i,j] and w) <> 0 then
begin
inc(rowdigits[j,p]);
inc(columndigits[i,p]);
inc(groupdigits[IJtoGroupNr(i,j),p]);
end;
end;//for
//search for missing digits
for j := 1 to 9 do //analyze rows
for p := 1 to 9 do //i = digit
if rowdigits[j,p] = 0 then
begin
status := hd0row;
row := j;
digit := p;
exit;
end;
for i := 1 to 9 do //analyze columns
for p := 1 to 9 do //i = digit
if columndigits[i,p] = 0 then
begin
status := hd0column;
column := i;
digit := p;
exit;
end;
for i := 1 to 9 do //analyze groups
for p := 1 to 9 do //p = digit
if groupdigits[i,p] = 0 then
begin
status := hd0group;
group := i;
digit := p;
exit;
end;
//search single digit fields
for j := 1 to 9 do
for i := 1 to 9 do
begin
p := popcount(Xboard[i,j]);
if (p = 1) and (board[i,j].nr = 0) then
begin
row := j;
column := i;
status := hdOnly;
digit := bitNRtoDigit(Xboard[i,j],1);
exit;
end;//if p
end;//for
//search only digit in row/column/group
for j := 1 to 9 do //analyze rows
for p := 1 to 9 do //i = digit
if rowdigits[j,p] = 1 then
if ((1 shl p) and rowsums[j]) <> 0 then //if not number
begin
status := hd1row;
row := j;
digit := p;
w := 1 shl p;
for q := 1 to 9 do //find column
if (xboard[q,row] and w) <> 0 then
begin
column := q;
break;
end;
exit;
end;
for i := 1 to 9 do //analyze columns
for p := 1 to 9 do //i = digit
if columndigits[i,p] = 1 then
if (1 shl p) and (colsums[i]) <> 0 then //if not number
begin
status := hd1column;
column := i;
digit := p;
w := 1 shl p;
for q := 1 to 9 do //find row
if (xboard[column,q] and w) <> 0 then
begin
row := q;
break;
end;
exit;
end;
for i := 1 to 9 do //analyze groups
for p := 1 to 9 do //p = digit
if groupdigits[i,p] = 1 then
if (1 shl p) and groupsums[i] <> 0 then
begin
status := hd1group;
group := i;
digit := p;
w := 1 shl p;
x := ((group-1) mod 3)*3 + 1;
y := ((group-1) div 3)*3 + 1;
for n := 0 to 2 do
for m := 0 to 2 do
if (xboard[x+m,y+n] and w) <> 0 then
begin
column := x + m;
row := y + n;
exit;
end;
end;
end;//with hintdata
end;
procedure clearhints;
//remove hints from fields
var i,j : byte;
begin
hintflag := false;
hintData.status := hdNone;
for j := 1 to 9 do
for i := 1 to 9 do
if board[i,j].nr = 0 then erasenumberField(i,j);
end;
procedure HintProcs;
//common code
begin
makeHintFields;
showhintfields;
analyzehints;
reportHintData;
end;
procedure AutoFill(m : byte);
//m=0: continue, m=1: 1 digit only
begin
form1.timer1.enabled := false; //stop timer
if GameStatus <> gsSearch then exit;
//
if (hintData.status = hdEmptyfield) or
(hintdata.status = hd0row) or //numbers missing in row,..
(hintdata.status = hd0column) or
(hintdata.status = hd0group) then
begin
timercontrol := coIdle; //stop on error detection
exit;
end;
//
with HintData do
if (status = hdonly) or (status = hd1row) or
(status = hd1column) or (status = hd1group) then
begin
setMarker(column,row);
tryAddnumber(digit);
if gamestatus = gsEnd then
begin
timercontrol := coIdle;
exit; //solution found
end;
if goodnumber then
begin
HintProcs;
if m = 1 then timercontrol := coIdle
else form1.timer1.enabled := true;
end
else
timercontrol := coIdle;//if error & timer running
end
else timercontrol := coIdle;//stop timer, no fills left
end;
//---------board background , make bitmaps
procedure makeBoardBackground;
const bgColors : array[0..1,0..2] of longInt =
(($0d0f0,$0d8f8,$0c8e8), //lite
($0c0e0,$0c8e8,$0b8d8)); //dark, 32bit format
type Ta = array[0..10000] of longInt;
var h,i,b,n : byte;
ch : char;
w,x,y : word;
p : ^Ta;
tempBM : Tbitmap;
begin
tempBm := Tbitmap.create;
with tempBm do
begin
width := 3*square;
height := width;
pixelformat := pf32bit;
end;
randomize;
with tempBm do
with canvas do
for n := 0 to 1 do //lite & dark groups on board
begin
for w := 0 to height-1 do
begin
p := scanline[w];
for x := 0 to width-1 do p^[x] := bgColors[n,random(3)];
end;//for w
for i := 0 to 4 do
begin
w := n + 2*i;
x := (w mod 3)*square*3;
y := (w div 3)*square*3;
BGmap.canvas.draw(x,y,tempBM);
end;//for i
end;//for n
//
tempBm.free;
tempBM := nil;
//
with BGmap do
with canvas do
begin
font.height := square*3;
font.color := $e0c080;
brush.Style := bsClear; //for big group numbers
for i := 1 to 9 do
begin
x := ((i-1) mod 3)*3*square;
y := ((i-1) div 3)*3*square;
ch := chr(i+byte('0'));
h := textheight(ch);
b := textwidth(ch);
x := x + (3*square - b) div 2 + 2;
y := y + (3*square - h) div 2 + 2;
textout(x,y,ch);
end;
pen.color := $d0d0ff;
for i := 1 to 8 do
begin
w := i*square;
moveto(w,0);
lineto(w,height);
moveto(0,w);
lineto(width,w);
end;
pen.color := $0000ff;
for i := 0 to 3 do
begin
w := i*3*square;
moveto(w,0);
lineto(w,height);
moveto(0,w);
lineto(width,w);
end;
end;
end;
procedure makemarkMap;
//marker bitmap
const marklight = $00ffff;
markDark = $00c0ff;
var i : byte;
begin
with markMap do
with canvas do
begin
brush.color := $0;
fillrect(rect(0,0,width,height));
for i := 0 to 3 do
begin
pen.color := markdark;
moveto(width-1-i,i);
lineto(i,i);
lineto(i,height-1-i);
pen.color := marklight;
lineto(width-1-i,height-1-i);
lineto(width-1-i,i);
end;
end;//with
end;
//---------paint events
procedure TForm1.PaintBox1Paint(Sender: TObject);
const lookAtP1 : boolean = true;
var i,j : byte;
begin
if lookatP1 then loadfromP1;//only first paint
lookatP1 := false;
//
with paintbox1 do
with canvas do
begin
copymode := cmSRCcopy;
draw(0,0,BGmap);
end;
//
for i := 1 to 9 do //contents of fields
for j := 1 to 9 do
if board[i,j].nr <> 0 then writeNumfield(i,j);
//
if showflag then ShowHintFields;
//
if (markI <> 0) then setmarker(markI,markJ);
end;
function CalcTextwidth(s : string) : word;
begin
with form1.davarrayBtn1 do result := canvas.textwidth(s);
end;
procedure TForm1.DavArrayBtn1BtnPaint(sender: TObject; BtnNr: Byte;
status: TBtnStatus);
const BtnText : array[btOpen..btHelp] of string =
('open',
'save',
'clipboard',
'erase/board',
'enter/puzzle',
'restore/puzzle',
'search',
'help/info');
var r : Trect;
x1,x2,y1,y2,p : word;
s1,s2 : string;
btn : TbtnType;
begin
with davarrayBtn1 do
with canvas do
begin
btn := TBtnType(btnNr);
p := pos('/',BtnText[btn]);
if p = 0 then
font.height := trunc(btnheight*0.45)
else font.height := trunc(btnHeight*0.35);
r := getBtnRect(BtnNr);
if status = stHI then font.Style := [fsBold] else font.style := [];
if p <> 0 then
begin s1 := copy(BtnText[btn],1,p-1);
s2 := copy(BtnText[btn],p+1,length(btnText[Btn]) - p);
x1 := r.left + ((btnwidth-calctextwidth(s1)) div 2);
x2 := r.left + ((btnwidth-calctextwidth(s2)) div 2);
y1 := r.top+5;
y2 := r.top + btnheight div 2;
textout(x1,y1,s1);
textout(x2,y2,s2);
end
else
begin
x1 := r.left + (btnwidth-calctextwidth(btnText[btn])) div 2;
y1 := r.top+(btnheight - textheight('I')) div 2;
textout(x1,y1,btntext[btn]);
end;
end;//with
//hint messages
if status = stHI then
begin
case btn of
btOpen : s1 := 'open puzzle from disc';
btSave : s1 := 'save puzzle on disc';
btClipBoard : begin
setTotaldigits;
if Totaldigits = 0 then
s1 := 'paste new puzzle from clipboard'
else
s1 := 'copy puzzle to clipboard';
end;
btErase : s1 := 'erase board';
btplace : s1 := 'enter digits for new puzzle';
btBegin : s1 := 'restore to original puzzle';
btSearch : s1 := 'search for solution';
btHelp : s1 := 'show help information';
end;
msg(msgHelp,s1);
end
else begin
s1 := '';
msg(msgsaved,s1);
end;
end;
procedure TForm1.DavArrayBtn2BtnPaint(sender: TObject; BtnNr: Byte;
status: TBtnStatus);
const BtnText : array[sbShow..sbBackspace] of string =
('options',
'hints',
'fill',
'fill all',
'reduce',
'backspace');
var r : Trect;
x,y : word;
bb : TsearchBtnType;
s : string;
begin
with davArrayBtn2 do
with canvas do
begin
bb := TsearchBtntype(btnNr);
s := BtnText[bb];
r := getBtnRect(btnNr);
font.height := trunc(btnheight*0.6);
if status = stHI then font.style := [fsBold]
else font.style := [];
x := r.left+(btnWidth - textwidth(s)) div 2;
y := r.top + (btnheight - textheight('H')) div 2;
textout(x,y,s);
end;
//hint
if status = stHI then
begin
case bb of
sbShow : s := 'show options';
sbWarn : s := 'show hints and warnings';
sbFill : s := 'fill hint-field';
sbFillAll : s := 'fill all hint-fields';
sbReduce : s := 'analyze / reduce options';
sbBackspace : s := 'remove last digit(s) entered';
end;//case
msg(msgHelp,s);
end
else begin
s := '';
msg(msgSaved,s);
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
var i,dx : byte;
x1,y1,x2,y2 : word;
begin
with paintbox1 do
begin
x1 := left-2;
y1 := top-2;
x2 := left+width+1;
y2 := top+height+1;
end;
with canvas do //randje om paintbox1
begin
for i := 0 to 1 do
begin
pen.color := $0;
moveto(x2-i,y1+i);
lineto(x1+i,y1+i);
lineto(x1+i,y2-i);
pen.color := $00ffff;
lineto(x2-i,y2-i);
lineto(x2-i,y1+i);
end;
//
brush.Style := bsclear; //column,row indicators
font.height := trunc(square*0.4);
dx := square div 2;
x1 := paintbox1.left + dx;
y1 := paintbox1.top - dx;
for i := 1 to 9 do
textout(x1 + (i-1)*square,y1,inttostr(i));
x1 := paintbox1.left - dx;
y1 := paintbox1.top + dx;
for i := 1 to 9 do
textout(x1,y1+(i-1)*square,inttostr(i));
end;
end;
//--------search button control
procedure SearchBtnShow;
//shows all search buttons that have no momentary action
var i : TSearchBtnType;
begin
for i := sbShow to sbBackspace do
case i of
sbShow,sbBackspace : form1.davarrayBtn2.BtnShow(byte(i));
end;//case
end;
procedure SearchBtnHide;
//hides all search buttons
var i : TSearchBtnType;
begin
for i := sbShow to sbBackSpace do
form1.DavArrayBtn2.BtnHide(byte(i));
end;
//----------array button changes
procedure TForm1.DavArrayBtn1BtnChange(sender: TObject; BtnNr: Byte;
status: TBtnStatus; button: TMouseButton);
var s : string;
begin
s := '';
msg(msgInfo,s); //clear old messages
case gamestatus of //release actions
gsSearch,
gsEnd : begin
if hintflag then clearHints;
hintflag := false;
showflag := false;
SearchBtnHide;
end;
end;//case
if status = stDown then //activate actions
case TbtnType(BtnNr) of
btOpen : OpenGame;
btsave : SaveGame;
btClipBoard : procClipboard;
btPlace : begin
gamestatus := gsPlace;
setmarker(1,1);
end;
btErase : begin
clearall; //also clears Addlist
gamestatus := gsInit;
end;
btBegin : begin
initOrg;
gamestatus := gsWait;
end;
btSearch : begin
gamestatus := gsSearch;
searchBtnShow;
lastEntry := 0;//clear addlist
setTotaldigits;
setmarker(1,1);
end;
btHelp : InfoForm.show;
end;//case
end;
procedure TForm1.DavArrayBtn2BtnChange(sender: TObject; BtnNr: Byte;
status: TBtnStatus; button: TMouseButton);
begin
with davarrayBtn2 do
begin
if status = stFlat then
case TsearchBtnType(btnNr) of
sbshow : begin //btnshow off
btnHide(byte(sbWarn));
btnHide(byte(sbFill));
btnhide(byte(sbFillall));
btnHide(byte(sbreduce));
showflag := false;
hintflag := false;
clearhints;
end;
sbwarn : begin
btnHide(byte(sbFill));
btnhide(byte(sbFillall));
hintflag := false;
statictext1.caption := '';
end;
end;//case
//
if status = stDown then
case TsearchBtntype(btnNr) of //select actions
sbShow : begin
btnShow(byte(sbWarn));
btnShow(byte(sbreduce));
showflag := true;
hintflag := false;
makehintFields;
showHintFields;
end;
sbWarn : begin
btnShow(byte(sbFill));
btnShow(byte(sbFillall));
hintflag := true;
HintProcs;
end;
sbFillAll : begin
timer1.interval := 500;
timercontrol := coFillSingles;
AutoFill(0);
end;
sbFill : begin
timercontrol := coFillSingles;
AutoFill(1);
end;
sbReduce : begin
HintReduction;
HintReduction2;
HintReductionShow;
end;
sbbackspace : moveback;
end;//case
end;//with
end;
//------------mouse events
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var i,j : byte;
begin
if timercontrol <> coIdle then exit;
i := pixelToIJ(x);
j := pixelToIJ(y);
case gamestatus of
gsPlace,
gssearch : setMarker(i,j);
end;//case
end;
//----------key events
procedure procSpace;
//if ' ' typed
var K : word;
begin
k := VK_RIGHT;
case gamestatus of
gsplace,
gssearch : form1.formkeydown(form1,K,[]);
end;//case
end;
procedure procBackspace;
//if backspace typed
var K : word;
begin
k := VK_LEFT;
case gamestatus of
gsplace : form1.formkeydown(form1,K,[]);
gssearch : moveback;
end;//case
end;
procedure procDelete;
//if del key typed
begin
case gamestatus of
gsplace : addOrgNumber(0);
gssearch : tryAddNumber(0);
end;
end;
procedure proczero;
//if zero typed in
begin
case gamestatus of
gsplace : AddorgNumber(0);
gssearch : tryAddNumber(0);
end;//case
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key = VK_ESCAPE then timercontrol := coIdle;
if timercontrol <> coIdle then exit;
//
if ((gamestatus = gsPlace) or (gamestatus = gsSearch))
and (markI <> 0) and (markJ <> 0) then
begin
case key of
VK_RIGHT,
VK_DOWN,
VK_UP,
VK_LEFT,
VK_DELETE,
VK_BACK : paintUnMark(markI,markJ);
end;//case
case key of
VK_right : begin
inc(markI);
if markI > 9 then
begin
dec(markI,9);
inc(markJ);
if markJ > 9 then dec(markJ,9);
end;
end;
VK_UP : begin
dec(markJ);
if markJ < 1 then inc(markJ,9);
end;
VK_DOWN : begin
inc(markJ);
if markJ > 9 then dec(markJ,9);
end;
VK_LEFT : begin
dec(markI);
if markI < 1 then
begin
inc(markI,9);
dec(markJ);
if markJ < 1 then inc(markJ,9);
end;
end;
VK_DELETE : procDelete;
VK_BACK : procBackspace;
end;//case
setmarker(markI,markJ);
end;//if
key := 0;
end;
function Isdigit(key : char) : boolean;
begin
result := key in ['1','2','3','4','5','6','7','8','9'];
end;
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if timercontrol <> coIdle then exit;
case key of
' ' : procSpace;
'0' : procZero;
end;//case
if Isdigit(key) then
case gamestatus of
gsplace : begin
if markI <> 0 then
begin
AddOrgNumber(strtoint(key));
if GoodNumber then MarkNextfield;
end;
end;//if isdigit
gsSearch : if markI <> 0 then tryAddNumber(strToInt(key));//if marked
end;//case
key := #0;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
case timercontrol of
coIdle : timer1.enabled := false;
coFillSingles : AutoFill(0);
coBackspace : begin
timercontrol := coIdle;
movebackdelayed;
end;
coClearBtn : begin
timer1.enabled := false;
davArrayBtn1.btnRelease(byte(btClipboard));
timercontrol := coIdle;
gamestatus := gsInit;
end;
end;//case
end;
//------------create & destroy
procedure TForm1.FormCreate(Sender: TObject);
var i : TsearchBtnType;
s : string;
begin
if screen.width > 1024 then square := 60
else if screen.Width < 1024 then square := 40;
BGmap := Tbitmap.create;
with BGmap do
begin
width := 9*square+1;
height := width;
pixelformat := pf32bit;
font.name := 'arial';
transparent := false;
end;
makeBoardBackground;
Markmap := TBitmap.create;
with Markmap do
begin
width := square - 1;
height := width;
pixelformat := pf32bit;
transparent := true;
transparentcolor := $0;
end;
makeMarkMap;
unMarkMap := Tbitmap.create; //used to clear portions of field
with unmarkmap do
begin
width := markmap.width;
height := width;
pixelformat := pf32bit;
transparent := true;
transparentcolor := $0;
end;
with davarrayBtn1 do
begin
left := 10;
top := 10;
btnwidth := trunc(1.75*square);
btnheight := square;
Pcolortable := @ArrayBtn1Colors;
setBtnOpmode(byte(btErase),omMom);
setBtnOpmode(byte(btBegin),omMom);
end;
clientwidth := davArrayBtn1.left+davarrayBtn1.width + square div 2;
with paintbox1 do
begin
width := BGmap.width;
height := BGmap.height;
left := davArrayBtn1.getBtnRect(1).left + 2*davarraybtn1.btnspacing;
top := davarraybtn1.top + davarraybtn1.height + 10 + square div 2;
end;
with statictext1 do
begin
top := paintbox1.top+paintbox1.height+10;
height := trunc(0.6*square);
width := form1.clientwidth - 20;
color := $e0ffe0;
font.height := trunc(height*0.8);
end;
clientheight := statictext1.top+statictext1.height + 10;
top := (screen.height - height) div 2;
left := (screen.width - width) div 2;
with davarrayBtn2 do
begin
Rows := byte(sbBackspace)+1;
left := paintbox1.left + paintbox1.width + square div 2;
top := paintbox1.top;
btnheight := trunc(square * 0.7);
btnwidth := trunc(square*3);
Pcolortable := @ArrayBtn2Colors;
for i := sbShow to sbBackspace do
case i of
sbShow : begin
setBtnGroup(byte(sbShow),1);
setBtnOpmode(byte(sbShow),omToggle);
end;
sbWarn : begin
setBtnGroup(byte(sbWarn),2);
setBtnOpmode(byte(sbwarn),omToggle);
end;
sbFill : setBtnOpmode(byte(sbFill),omMom);
sbFillAll : setBtnOpmode(byte(sbFillAll),omMom);
sbReduce : setBtnOpmode(byte(sbReduce),omMom);
sbBackspace : setBtnOpmode(byte(sbBackSpace),omMom);
end;//case
end;
gamestatus := gsInit;
searchbtnhide;
s := welcome;
msg(msgInfo,s);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
BGmap.free;
BGmap := nil;
markmap.free;
markmap := nil;
unMarkmap.free;
unmarkmap := nil;
end;
//------------file operations
procedure saveGame;
var s : string;
i,j : byte;
begin
for j := 1 to 9 do
for i := 1 to 9 do
begin
ioBoard[i,j].nr := board[i,j].nr;
ioboard[i,j].org := (board[i,j].et = etOrg);
end;
//
with form1.Savedialog1 do
begin
title := 'save puzzle';
initialDir := paramstr(0);
defaultext := 'sdk';
filter := 'SUDOKU file (*sdk)|*sdk';
if execute then
begin
assignfile(fsodoku,filename);
rewrite(fsodoku);
write(fsodoku,ioboard);
closefile(fsodoku);
s := extractfilename(form1.savedialog1.filename);
s := 'saved : '+s;
msg(msgInfo,s);
form1.davArraybtn1.Btnrelease(byte(btSave));
end;
end;//with
end;
procedure OpenGame;
var s : string;
i,j : byte;
begin
with form1 do with Opendialog1 do
begin
title := 'Open puzzle';
initialDir := paramstr(0);
filter := 'SUDOKU file (*sdk)|*sdk';
if execute then
begin
assignfile(fsodoku,filename);
reset(fsodoku);
read(fsodoku,ioboard);
closefile(fsodoku);
//
s := extractfilename(form1.opendialog1.filename);
caption := leader + s;
s := 'opened : '+s;
msg(msgInfo,s);
for j := 1 to 9 do
for i := 1 to 9 do
begin
board[i,j].nr := ioboard[i,j].nr;
if ioboard[i,j].org then board[i,j].et := etOrg
else board[i,j].et := etManual;
end;//for i,j
end;//if execute
end;//with
form1.PaintBox1.Invalidate; //paint board
form1.DavArrayBtn1.BtnRelease(byte(btOpen));
end;
//-------------clipboard
procedure clipboardload;
//original numbers in [..]
//x is an empty field
const err : string = 'no Sudoku puzzle/format';
wrong : string = 'wrong numbers';
var s : string;
tempBoard : TSudoku3;
i,j : byte;
ett : TentryType;
nr,n : word;
ch : char;
label error,wrongpuzzle;
begin
ett := etManual;
s := '';
nr := 0;
if clipboard.HasFormat(CF_TEXT) then
s := clipboard.asText;
if length(s) = 0 then
begin
s := 'clipboard contains no text';
msg(msgError,s);
exit;
end;
//
for n := 1 to length(s) do
begin
ch := s[n];
case ch of
'[','(' : ett := etOrg;
']',')' : ett := etManual;
'x','X','.' : begin
inc(nr);
i := (nr-1) mod 9 + 1;
j := (nr-1) div 9 + 1;
tempboard[i,j].nr := 0;
end;
'1'..'9' : begin
inc(nr);
i := (nr-1) mod 9 + 1;
j := (nr-1) div 9 + 1;
tempboard[i,j].et := ett;
tempboard[i,j].nr := ord(s[n]) - ord('0');
end;
end;//case
end;//for
if nr = 81 then
begin
for j := 1 to 9 do
for i := 1 to 9 do
if (checkduplicate(i,j,tempboard[i,j].nr) = dupOK) or
(tempboard[i,j].nr = 0) then
begin
board[i,j].et := tempboard[i,j].et;
board[i,j].nr := tempboard[i,j].nr;
end
else
begin
msg(msgerror,wrong);
exit;
end;
end//if not 81 fields
else
begin
msg(msgerror,err);
exit;
end;
//
s := 'opened puzzle from clipboard';
msg(msgInfo,s);
form1.paintbox1.invalidate;
end;
procedure clipboardsave;
const creol : string[2] = #13+#10;
var s : string;
i,j : byte;
cc : char;
begin
s := 'SUDOKU - puzzle' + creol + creol ;
for j := 1 to 9 do
begin
for i := 1 to 9 do
begin
cc := chr(board[i,j].nr + ord('0'));
if (board[i,j].nr <> 0) and (board[i,j].et = etOrg) then
s := s + '['+ cc + ']'
else
begin
if board[i,j].nr = 0 then cc := 'x';
s := s + ' ' + cc + ' ';
end;
end;
s := s + creol; //add cr eol
end;
s := s + creol;
clipboard.asText := s;
s := 'puzzle placed on clipboard';
msg(msgInfo,s);
end;
procedure procClipboard;
begin
gamestatus := gsWait;
settotaldigits;
if totaldigits = 0 then clipboardLoad
else clipBoardsave;
//
form1.timer1.Enabled := false;
form1.timer1.Enabled := true;
timercontrol := coClearBtn;
end;
procedure HintReductionShow;
var s : string;
begin
s := '';
msg(msgInfo,s);
//
showHintFields;
if hintflag then
begin
AnalyzeHints;
ReportHintData;
end;
end;
//-------hint reduction by row/column
procedure LoadPfromRow(row : byte);
var i : byte;
begin
for i := 1 to 9 do
begin
xvalue[i] := Xboard[i,row];
Psum[i] := 0;
end;
end;
procedure LoadPfromColumn(col : byte);
var j : byte;
begin
for j := 1 to 9 do
begin
xvalue[j] := Xboard[col,j];
Psum[j] := 0;
end;
end;
procedure loadPfromGroup(gr : byte);
var i,j,n,x,y : byte;
begin
x := ((gr-1) mod 3)*3 + 1; //[x,y] is left top of group
y := ((gr-1) div 3)*3 + 1;
for n:= 1 to 9 do
begin
i := x+((n-1) mod 3); //[i,j] is field
j := y+((n-1) div 3);
Xvalue[n] := xboard[i,j];
Psum[n] := 0;
end;
end;
procedure UpdatePsums;
//or masks into Psum
var n : byte;
begin
for n := 1 to 9 do PSum[n] := Psum[n] or Pmask[n];
end;
function PC(action : byte) : boolean;
//action-0 : reset, 1: increment
//on exit :
//true: digit 9 incremented properly
//false: digit 1 overflow
var xxx : word;
digit : byte; //counter digit
label PCreset,PCincr;
begin
if action = 0 then digit := 1 else begin
digit := 9; goto PCincr;
end;
Pallow[1] := $3fe;
PCreset :
Pmask[digit] := 1;
if digit > 1 then Pallow[digit] :=
Pallow[digit-1] and (Pmask[digit-1] xor $3fe);
PCincr :
xxx := Pallow[digit] and xvalue[digit];
repeat
Pmask[digit] := Pmask[digit] shl 1; //find next mask
until (Pmask[digit] = $400) or ((Pmask[digit] and xxx) <> 0);
if Pmask[digit] = $400 then //not found
begin
Pmask[digit] := 0;
if digit = 1 then
begin
result := false; exit; //exit if digit 1
end
else begin
dec(digit); goto PCIncr;//no mask, digit > 1 = inc previous
end;
end //if mask...
else //good mask found
if digit < 9 then
begin
inc(digit); goto PCreset; //new mask found, reset next
end
else result := true;
end;
procedure HintReduction;
//use Xboard values and reduce per row,column
var i,j,n,gf,x,y : byte;
s : string;
begin
s := 'please wait ...';
msg(msgInfo,s);
for n := 1 to 9 do //rows
begin
loadPfromRow(n); //if reset OK
if PC(0) then
begin
UpdatePsums;
while PC(1) do UpdatePsums; //if incr OK
end;
for i := 1 to 9 do xboard[i,n] := Psum[i];//store results
end;//for n
//
for n := 1 to 9 do //columns
begin
loadPfromcolumn(n);
if PC(0) then
begin
UpdatePsums;
while PC(1) do UpdatePsums; //if incr OK
end;
for i := 1 to 9 do xboard[n,i] := Psum[i];//store results
end;//for
for n := 1 to 9 do //groups
begin
loadPfromgroup(n);
if PC(0) then //if reset OK
begin
UpdatePsums;
while PC(1) do UpdatePsums; //if incr OK
end;
x := ((n-1) mod 3)*3 + 1;
y := ((n-1) div 3)*3 + 1; //[I,J] of field
for gf:= 1 to 9 do
begin //for group fields 1..9
i := x+((gf-1) mod 3);
j := y+((gf-1) div 3);
xboard[i,j] := Psum[gf];
end;
end;//for n
//
end;
//------------hint reduction2
procedure loadTriplesHor;
//i:column j:row sum: or of 3 cons. fields in row
var i,j,x,n : byte;
sum : word;
begin
for j := 1 to 9 do //all columns
for i := 1 to 3 do //all 3 triples
begin
x := (i-1)*3 + 1;
sum := 0;
for n := 0 to 2 do sum := sum or Xboard[x+n,j];
triple[i,j] := sum;
end;
end;
procedure loadtriplesvert;
//reflect row/column to use same chech later
var i,j,y,n : byte;
sum : word;
begin
for i := 1 to 9 do
for j := 1 to 3 do
begin
y := (j-1)*3 + 1;
sum := 0;
for n := 0 to 2 do sum := sum or Xboard[i,y+n];
triple[j,i] := sum;
end;
end;
procedure CheckTriples;
var block, i,j,y,n : byte;
a,b,c : word;
begin
for block := 1 to 3 do
begin
y := (block-1)*3 + 1;
for j := 1 to 3 do
for i := 1 to 3 do
begin
a := 0; b := 0;
for n := 1 to 3 do
begin
if n <> i then a := a or triple[n,y+j-1];
if n <> j then b := b or triple[i,y+n-1];
end;
c := a and b;
for n := 1 to 3 do
begin
if n <> i then triple[n,y+j-1] := triple[n,y+j-1] and c;
if n <> j then triple[i,y+n-1] := triple[i,y+n-1] and c;
end;
end;
end;
end;
procedure reduceRowsbyTriples;
var i,j,x : byte;
begin
for j := 1 to 9 do
for i := 1 to 9 do
begin
x := (i-1) div 3 + 1;
Xboard[i,j] := Xboard[i,j] and triple[x,j]
end;
end;
procedure reduceColumnsbyTriples;
var i,j,x : byte;
begin
for j := 1 to 9 do
begin
x := (j-1) div 3 + 1;
for i := 1 to 9 do Xboard[i,j] := Xboard[i,j] and triple[x,i];
end;
end;
procedure Hintreduction2;
//sum options in triples, hor. vert.
//compare groups vs row, column
//select triple in group:
//options not present in row outside group,
//are cancelled in other triples in group
var s : string;
begin
loadTriplesHor;
CheckTriples;
reduceRowsbyTriples;
loadtriplesvert;
CheckTriples;
reduceColumnsbyTriples;
end;
//----check for *.sdk file
procedure LoadFromP1;
var s : string;
i,j : byte;
begin
if paramCount < 1 then exit;
s := paramstr(1);
if s <> '' then
begin
assignfile(fsodoku,s);
reset(fsodoku);
read(fsodoku,ioboard);
closefile(fsodoku);
//
s := extractfilename(s);
form1.caption := leader + s;
s := 'opened : '+s;
msg(msgInfo,s);
for i :=1 to 9 do
for j := 1 to 9 do
begin
board[i,j].nr := ioboard[i,j].nr;
if ioboard[i,j].org then board[i,j].et := etOrg
else board[i,j].et := etManual;
end;//for i,j
end;//if s
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
//plaatje saven van form
var bbb : Tbitmap;
begin
bbb := getformImage;
bbb.SaveToFile('plaatje.bmp');
end;
procedure TForm1.DavArrayBtn1Leave(Sender: TObject);
begin
with statictext1 do
if font.color = $b0b0b0 then caption := '';
end;
end.
