procedure Rule5; (* Is one of the cell's Possibilities not possible on any other cell in the column? *)
var
j : integer;
PossibilityPosition : integer;
FoundCount : integer;
FoundSolution : string;
CheckThisColumn : integer;
PossibilitiesCopy : string;
PossibilityBeingChecked : string;
FoundCharacter : string;
begin
CheckThisColumn := Currentpos_x;
PossibilitiesCopy := GridInfo{Currentpos_x}{Currentpos_y}.Possibilities;
FoundSolution := '';
(* For each possibility *)
(* if zero other cells have the possibility then it is a Solution. *)
for PossibilityPosition := 1 to length(PossibilitiesCopy) do
begin
FoundCount := 0;
PossibilityBeingChecked := PossibilitiesCopy{PossibilityPosition};
(* check every cell in the column's possibilities *)
for j := 1 to 9 do
begin
if (Pos(PossibilityBeingChecked,GridInfo{CheckThisColumn}{j}.Possibilities) 0) then
begin
FoundCount := FoundCount+1;
if FoundCount = 1 then
FoundCharacter := PossibilityBeingChecked;
end; (* if Pos(PossibilityBeingChecked *)
end; (* for j *)
if FoundCount = 1 then (* then FoundCharacter is not possible in any other cell of the current column. *)
FoundSolution := FoundCharacter;
end; (* for PossibilityPosition *)
if length(FoundSolution) = 1 then
begin
ProcessSolution(Currentpos_x,Currentpos_y,FoundSolution,
'No other cell in the column has this numeral as a possibility. (Rule 5)');
end;
end; (* Procedure Rule5 *)
procedure Rule6; (* Is one of the cell's Possibilities not possible on any other cell in the row? *)
var
i : integer;
PossibilityPosition : integer;
FoundCount : integer;
FoundSolution : string;
CheckThisRow : integer;
PossibilitiesCopy : string;
PossibilityBeingChecked : string;
FoundCharacter : string;
begin
CheckThisRow := Currentpos_y;
PossibilitiesCopy := GridInfo{Currentpos_x}{Currentpos_y}.Possibilities;
FoundSolution := '';
(* For each possibility *)
(* if zero other cells have the possibility then it is a Solution. *)
for PossibilityPosition := 1 to length(PossibilitiesCopy) do
begin
FoundCount := 0;
PossibilityBeingChecked := PossibilitiesCopy{PossibilityPosition};
(* check every cell in the row's possibilities *)
for i := 1 to 9 do
begin
if (Pos(PossibilityBeingChecked,GridInfo{i}{CheckThisRow}.Possibilities) 0) then
begin
FoundCount := FoundCount+1;
if FoundCount = 1 then
FoundCharacter := PossibilityBeingChecked;
end; (* if Pos(PossibilityBeingChecked *)
end; (* for i *)
if FoundCount = 1 then (* then FoundCharacter is not possible in any other cell of the current column. *)
FoundSolution := FoundCharacter;
end; (* for PossibilityPosition *)
if length(FoundSolution) = 1 then
begin
ProcessSolution(Currentpos_x,Currentpos_y,FoundSolution,
'No other cell in the row has this numeral as a possibility. (Rule 6)');
end;
end; (* Procedure Rule6 *)
procedure Rule7; (* Is one of the cell's Possibilities not possible on any other cell in the block? *)
var
i,j: integer;
PossibilityPosition : integer;
FoundCount : integer;
FoundSolution : string;
CheckThisBlock : integer;
PossibilitiesCopy : string;
PossibilityBeingChecked : string;
FoundCharacter : string;
begin
CheckThisBlock := GridInfo{Currentpos_x}{Currentpos_y}.BlockNumber;
PossibilitiesCopy := GridInfo{Currentpos_x}{Currentpos_y}.Possibilities;
FoundSolution := '';
(* For each possibility *)
(* if zero other cells have the possibility then it is a Solution. *)
for PossibilityPosition := 1 to length(PossibilitiesCopy) do
begin
FoundCount := 0;
PossibilityBeingChecked := PossibilitiesCopy{PossibilityPosition};
(* check every cell in the row's possibilities *)
for i := 1 to 9 do
begin
for j:= 1 to 9 do
begin
if (Pos(PossibilityBeingChecked,GridInfo{i}{j}.Possibilities) 0) then
begin
FoundCount := FoundCount+1;
if FoundCount = 1 then
FoundCharacter := PossibilityBeingChecked;
end; (* if Pos(PossibilityBeingChecked *)
end; (* for j; *)
end; (* for i *)
if FoundCount = 1 then (* then FoundCharacter is not possible in any other cell of the current block. *)
FoundSolution := FoundCharacter;
end; (* for PossibilityPosition *)
if length(FoundSolution) = 1 then
begin
ProcessSolution(Currentpos_x,Currentpos_y,FoundSolution,
'No other cell in the block has this numeral as a possibility. (Rule 7)');
end;
end; (* Procedure Rule7 *)

Gold is $1,581/oz today. When it hits $2,000, it will be up 26.5%. Let's see how long that takes. - De 3/11/2013 - ANSWER: 7 Years, 5 Months
- - - - -
View Replies (1)
»
» You can also:
- - - - -
The above is a reply to the following message:
Re: Lazarus (Pascal) - Code part 2 of 5
By: Decomposed
in
POPE IV
Mon, 20 Nov 17 10:49 PM
|
Msg. 38937 of
47202
|
procedure ProcessSolution(x,y:integer; Solution:string; SolutionReason:string);
begin
PassesSinceLastSolution := 0;
TotalCellsSolved := TotalCellsSolved + 1;
GridInfo{x}{y}.IsSolved := TRUE;
GridInfo{x}{y}.Possibilities := Solution;
GridInfo{x}{y}.Impossibilities := EliminateCharacter('123456789',Solution{1});
GridInfo{x}{y}.DisplayValue := Solution{1};
GridInfo{x}{y}.NumberOfModifications := GridInfo{x}{y}.NumberOfModifications + 1;
GridInfo{x}{y}.ModificationReasons{GridInfo{x}{y}.NumberOfModifications} := SolutionReason;
end;
procedure LoadPuzzle(PuzzleNum: string);
var
i,j,x : integer;
row : integer;
fp : textfile;
begin
assignfile(fp,'Puzzle325.txt');
(* assignfile(fp,'Test001.txt'); *)
try
reset(fp);
for j:=1 to 9 do
begin
readln(fp,OrigPuzzle{j});
end; (* for j *)
close(fp);
except
writeln('Error. Please check the text file.');
end; (* try - except *)
for j:= 1 to 9 do
begin
for i := 1 to 9 do
begin
GridInfo{i}{j}.xCoord := i;
GridInfo{i}{j}.yCoord := j;
GridInfo{i}{j}.CellNumber := ((j-1) * 9) + i;
GridInfo{i}{j}.BlockColumn := (((GridInfo{i}{j}.CellNumber - ((j-1)*9)) - 1) div 3) + 1;
GridInfo{i}{j}.BlockRow := ((GridInfo{i}{j}.CellNumber - 1) div 27) + 1;
if (GridInfo{i}{j}.BlockRow = 1) then
begin
case GridInfo{i}{j}.BlockColumn of
1 : GridInfo{i}{j}.BlockNumber := 1;
2 : GridInfo{i}{j}.BlockNumber := 2;
3 : GridInfo{i}{j}.BlockNumber := 3;
end; (* case *)
end;
if (GridInfo{i}{j}.BlockRow = 2) then
begin
case GridInfo{i}{j}.BlockColumn of
1 : GridInfo{i}{j}.BlockNumber := 4;
2 : GridInfo{i}{j}.BlockNumber := 5;
3 : GridInfo{i}{j}.BlockNumber := 6;
end; (* case *)
end;
if (GridInfo{i}{j}.BlockRow = 3) then
begin
case GridInfo{i}{j}.BlockColumn of
1 : GridInfo{i}{j}.BlockNumber := 7;
2 : GridInfo{i}{j}.BlockNumber := 8;
3 : GridInfo{i}{j}.BlockNumber := 9;
end; (* case *)
end;
if OrigPuzzle{j}{i} = '0' then
begin
GridInfo{i}{j}.displayvalue := '-';
GridInfo{i}{j}.IsSolved := FALSE;
GridInfo{i}{j}.Possibilities := '123456789';
GridInfo{i}{j}.Impossibilities := '';
GridInfo{i}{j}.NumberOfModifications := 0;
for x:=1 to MAXMODS do
GridInfo{i}{j}.ModificationReasons{x} := '';
end
else
begin
GridInfo{i}{j}.displayvalue := OrigPuzzle{j}{i};
GridInfo{i}{j}.IsSolved := TRUE;
GridInfo{i}{j}.Possibilities := OrigPuzzle{j}{i};
GridInfo{i}{j}.Impossibilities := EliminateCharacter('123456789',OrigPuzzle{j}{i});
GridInfo{i}{j}.NumberOfModifications := 1;
GridInfo{i}{j}.ModificationReasons{1} := 'Given.';
for x:=2 to MAXMODS do
GridInfo{i}{j}.ModificationReasons{x} := '';
end; (* end of the 'if 0 else something else' statement *)
end; (* for i *)
end; (* for j *)
end; (* procedure LoadPuzzle*)
procedure ExamineCell(Old_x, Old_y, Examine_x, Examine_y:integer);
var
k,ExtraSpace : integer;
begin
(* Clear the old cell's brackets *)
ExtraSpace := 0;
if Old_y>=4 then ExtraSpace := 1;
if Old_y>=7 then ExtraSpace := 2;
gotoxy(GRID_XBASE+1+((Old_x-1)*4),GRID_YBASE+2+Old_y+ExtraSpace);
write(' ');
gotoxy(GRID_XBASE+3+((Old_x-1)*4),GRID_YBASE+2+Old_y+ExtraSpace);
write(' ');
(* Draw the new cell's brackets *)
ExtraSpace := 0;
if Examine_y >=4 then ExtraSpace := 1;
if Examine_y >=7 then ExtraSpace := 2;
gotoxy(GRID_XBASE+2+((Examine_x-1)*4),GRID_YBASE+2+Examine_y+ExtraSpace);
write(GridInfo{Examine_x}{Examine_y}.displayvalue );
if (not AutoMovement) or (AutoMovement and (not GridInfo{Currentpos_x}{Currentpos_y}.IsSolved)) then
begin
gotoxy(GRID_XBASE+1+((Examine_x-1)*4),GRID_YBASE+2+Examine_y+ExtraSpace);
write('{');
gotoxy(GRID_XBASE+3+((Examine_x-1)*4),GRID_YBASE+2+Examine_y+ExtraSpace);
write('}');
(* Update the cell's displayed information *)
DisplayCurrentCoordinates;
DisplayMessage(39+GRID_XBASE,5+GRID_YBASE,' ');
DisplayMessage(39+GRID_XBASE,5+GRID_YBASE,GridInfo{Examine_x}{Examine_y}.Possibilities);
DisplayMessage(49+GRID_XBASE,5+GRID_YBASE,GridInfo{Examine_x}{Examine_y}.Impossibilities);
for k := MAXMODS downto 1 do
DisplayMessage(1+GRID_XBASE,15+k+GRID_YBASE,' ');
if (GridInfo{Examine_x}{Examine_y}.NumberOfModifications >= 1) then
begin
for k := 1 to GridInfo{Examine_x}{Examine_y}.NumberOfModifications do
begin
gotoxy(2+GRID_XBASE,15+k+GRID_YBASE);
write(' ');
DisplayMessage(6+GRID_XBASE,15+k+GRID_YBASE,GridInfo{Examine_x}{Examine_y}.ModificationReasons{k});
end;
end;
end;
end; (* Procedure ExamineCell *)
procedure Rule1; (* Is the cell the only blank one in the current column? *)
var
j : integer;
CheckThisColumn : integer;
NumberSolvedInColumn : integer;
StringBeingReduced : string;
ImpossibleCharacters : string;
OnlyRemainingCharacter : char;
begin
NumberSolvedInColumn := 0;
StringBeingReduced := '123456789';
CheckThisColumn := Currentpos_x;
for j := 1 to 9 do
begin
if GridInfo{CheckThisColumn}{j}.IsSolved = TRUE then
begin
NumberSolvedInColumn := NumberSolvedInColumn + 1;
StringBeingReduced := EliminateCharacter(StringBeingReduced,GridInfo{CheckThisColumn}{j}.DisplayValue);
(* Eliminate from the Possibilities any Solution which was found elswhere in the column. *)
GridInfo{Currentpos_x}{Currentpos_y}.Possibilities
:= EliminateCharacter(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
GridInfo{CheckThisColumn}{j}.DisplayValue);
end;
end; (* for j *)
if NumberSolvedInColumn = 8 then (* ... then the cell we're checking is the only blank one in the column *)
ProcessSolution(Currentpos_x,Currentpos_y,StringBeingReduced,'Last blank cell in the column. (Rule 1)');
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
begin
if length(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities) = 1 then
ProcessSolution(Currentpos_x,Currentpos_y,GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
'Column, row and block solutions leave just one possibility. (Rule 4.1)');
end;
end; (* Procedure Rule1 *)
procedure Rule2; (* Is the cell the only blank one in the current row? *)
var
i : integer;
CheckThisRow : integer;
NumberSolvedInRow : integer;
StringBeingReduced : string;
ImpossibleCharacters : string;
OnlyRemainingCharacter : char;
begin
NumberSolvedInRow := 0;
StringBeingReduced := '123456789';
CheckThisRow:= Currentpos_y;
for i := 1 to 9 do
begin
if GridInfo{i}{CheckThisRow}.IsSolved = TRUE then
begin
NumberSolvedInRow := NumberSolvedInRow + 1;
StringBeingReduced := EliminateCharacter(StringBeingReduced,GridInfo{i}{CheckThisRow}.DisplayValue);
(* Eliminate from the Possibilities this Solution which was found elswhere in the row. *)
GridInfo{Currentpos_x}{Currentpos_y}.Possibilities
:= EliminateCharacter(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
GridInfo{i}{CheckThisRow}.DisplayValue);
end;
end; (* for i *)
if NumberSolvedInRow = 8 then (* ... then the cell we're checking is the only blank one in the row *)
ProcessSolution(Currentpos_x,Currentpos_y,StringBeingReduced,'Last blank cell in the row. (Rule 2)');
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
begin
if length(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities) = 1 then
ProcessSolution(Currentpos_x,Currentpos_y,GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
'Column, row and block solutions leave just one possibility. (Rule 4.2)');
end;
end; (* Procedure Rule2 *)
|
|
|
|
|