procedure ExecuteRules();
begin
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
Rule1; (* Is it the last blank cell in the column? *)
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
Rule2; (* Is it the last blank cell in the row? *)
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
Rule3; (* Is it the last blank cell in the block? *)
(* Rule4 is embbedded in rules 1 2 and 3, so don't re-use that number *)
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
Rule5; (* Is one of the cell's Possibilities not possible on any other cell in the column? *)
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
Rule6; (* Is one of the cell's Possibilities not possible on any other cell in the row? *)
if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
Rule7; (* Is one of the cell's Possibilities not possible on any other cell in the block? *)
if (not AutoMovement) or (AutoMovement and (not GridInfo{Currentpos_x}{Currentpos_y}.IsSolved)) then
ExamineCell(Currentpos_x,Currentpos_y,Currentpos_x,Currentpos_y);
end; (* procedure ExecuteRules(); *)
procedure MoveDirection(direction:string);
var
Oldpos_x, Oldpos_y : integer;
begin
(* Moves us around based on direction and global vars Currentpos_x,Currentpos_y *)
Oldpos_x := Currentpos_x;
Oldpos_y := Currentpos_y;
if direction 'Auto' then
begin
case direction of
'Up' :
begin
if Currentpos_y > 1 then
begin
Currentpos_y := Currentpos_y-1;
end;
end;
'Down' :
begin
if Currentpos_y < 9 then
begin
Currentpos_y := Currentpos_y+1;
end;
end;
'Left' :
begin
if Currentpos_x > 1 then
begin
Currentpos_x := Currentpos_x-1;
end;
end; (* Left *)
'Right' :
begin
if Currentpos_x < 9 then
Currentpos_x := Currentpos_x+1;
end; (* Right *)
end; (* case statement *)
end (* if direction 'Auto' *)
else (* else the direction IS 'Auto' *)
begin
if Currentpos_x < 9 then
Currentpos_x := Currentpos_x+1
else (* if .. else Currentpos_x = 9 *)
begin
Currentpos_x := 1;
if Currentpos_y < 9 then
Currentpos_y := Currentpos_y + 1 (* if Currrentpos_y < 9 *)
else (* if .. else Currentpos_y IS 9 *)
begin
Currentpos_y := 1;
PassesSinceLastSolution := PassesSinceLastSolution + 1;
if PassesSinceLastSolution = 5 then
Unsolveable := TRUE;
end;
end; (* if .. else Currentpos_x = 9 *)
end; (* if .. else the direction IS 'Auto' *)
ExecuteRules;
ExamineCell(Oldpos_x,Oldpos_y,Currentpos_x,Currentpos_y);
end; (* procedure MoveDirection *)
procedure drawborders;
begin
clrscr;
drawline_h(1,1,79,'0');
drawline_h(1,23,79,'0');
drawline_v(1,2,22,'0');
drawline_v(79,2,22,'0');
end; (* procedure drawborders; *)
procedure draw_initial_screen;
var
i,j : integer;
ExtraSpace,NumWrites : integer;
gridlinechar_v, gridlinechar_h : char;
begin
drawborders;
gotoxy(18,24);
write(' to Quit. Arrow keys to move.');
gotoxy(23,25);
write('Or Press ''A'' for Auto Mode');
gridlinechar_v:=chr(222);
gridlinechar_h:=chr(220);
ExtraSpace := 0;
NumWrites:=0;
drawline_v(GRID_XBASE+12,GRID_YBASE+3,11,gridlinechar_v);
drawline_v(GRID_XBASE+24,GRID_YBASE+3,11,gridlinechar_v);
drawline_h(GRID_XBASE+2,GRID_YBASE+6,33,gridlinechar_h);
drawline_h(GRID_XBASE+2,GRID_YBASE+10,33,gridlinechar_h);
drawline_v(38,2,14,gridlinechar_v);
drawline_h(3,15,36,gridlinechar_h);
for j := 1 to 9 do
begin
if j=4 then ExtraSpace := 1;
if j=7 then ExtraSpace := 2;
for i := 1 to 9 do
begin
gotoxy(GRID_XBASE+2+((i-1)*4),GRID_YBASE+2+j+ExtraSpace);
write (GridInfo{i}{j}.displayvalue);
gotoxy(40,10);
end; (* for i *)
end; (* for j *)
end; (* procedure draw_initial_screen; *)
begin
cursoroff;
LoadPuzzle('415');
draw_initial_screen;
Currentpos_x:=1; (* Values ranging from 1 to 9 that say which cell we begin *)
Currentpos_y:=1;
AutoMovement := FALSE;
TotalCellsSolved := 0;
PassesSinceLastSolution := 0;
Unsolveable := FALSE;
for i := 1 to 9 do
for j := 1 to 9 do
if GridInfo{i}{j}.IsSolved then
TotalCellsSolved := TotalCellsSolved+1;
(* Start by clearing brackets that aren't present, then drawing brackets *)
(* at the cell we're going to examine. Later, the old position and new *)
(* positions are what we'll pass to ExamineCell. *)
ExecuteRules;
repeat
ExamineCell(Currentpos_x,Currentpos_y,Currentpos_x,Currentpos_y);
ch:=ReadKey;
case ch of
#0 : begin
ch:=ReadKey; {Read ScanCode}
case ch of
#72 : MoveDirection('Up');
#75 : MoveDirection('Left');
#77 : MoveDirection('Right');
#80 : MoveDirection('Down');
else
;
end;
end;
#65,#97 : begin
AutoMovement := TRUE; (* A or a (for auto movement) *)
MoveDirection('Auto');
end;
#27 : ; (* An ESC was pressed, so quit. *)
end;
until (ch=#27) or AutoMovement; (* Esc *);
if AutoMovement then
begin
gotoxy(18,24);
write(' Automatic Mode. Please wait.');
gotoxy(18,25);
write(' ');
repeat
MoveDirection('Auto');
until (TotalCellsSolved = 81) or Unsolveable;
if Unsolveable then
DisplayMessage(18,25,'** Could not solve this puzzle. **');
AutoMovement := FALSE;
gotoxy(18,24);
write(' Press to Quit. ');
gotoxy(18,24);
write(' to Quit. Arrow keys to move.');
repeat
ExamineCell(Currentpos_x,Currentpos_y,Currentpos_x,Currentpos_y);
ch:=ReadKey;
case ch of
#0 : begin
ch:=ReadKey; {Read ScanCode}
case ch of
#72 : MoveDirection('Up');
#75 : MoveDirection('Left');
#77 : MoveDirection('Right');
#80 : MoveDirection('Down');
else
;
end;
end;
#27 : ; (* An ESC was pressed, so quit. *)
end; (* case *)
until (ch=#27); (* Esc *);
end; (* if AutoMovement *)
cursoron;
end.
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 4of 5
By: Decomposed
in
POPE IV
Mon, 20 Nov 17 10:55 PM
|
Msg. 38938 of
47202
|
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 *)
|
|
|
|
|
| 
