home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
The World of Computer Software.iso
/
8puzzle.zip
/
8PUZZLE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-10-25
|
14KB
|
663 lines
program puzzle8;
{
Copyright Norman Newman, Kibbutz Mishmar David, Israel.
This Turbo Pascal version was successfully ported
from the PDP version on 4 July 1987.
This is a more Turbo-like version, March 1988.
Updated to Turbo-4, October 1988.
Permission is granted to use this program, or portions thereof,
for non-commercial purposes. All other rights are reserved to
the original author.
}
uses dos, crt;
const
version = 9;
zero = 48; { ASCII ord('0') }
goal = '1234 5678';
hash_max = 1008;
hash_max_plus = 1009;
type
square = packed array [1..9] of char;
var
original, onscreen: square;
hash_table: array [0..hash_max] of square;
table: array [1..81] of integer;
preint: array [1..9] of integer;
prech: array ['1'..'8'] of char;
moves: array [1..9,1..5] of integer;
compcount, humcount: integer;
complay, humplay: boolean;
ch: char;
video_mode: byte;
regs: registers;
{****************************************************}
function get_mode: byte;
{ return our current video mode }
begin
regs.ax:= $0F00;
intr ($10, regs);
get_mode:= regs.al
end;
procedure set_mode (mode: byte);
{ set the video mode }
begin
regs.ah:= 0;
regs.al:= mode;
intr ($10, regs);
end;
function inkey: integer;
{ this function returns the code of the key pressed in the low
byte.
If the high byte is 0, an extended code was read;
if the high byte is 1, an ordinary key was read
}
begin
regs.ah:= 7; { read character without echo }
msdos (regs);
if regs.al > 0 { ordinary key }
then regs.ah:= 1
else
begin { get rest of key code }
msdos (regs);
regs.ah:= 0
end;
inkey:= regs.ax
end { inkey };
function evaluate (var p:square): integer;
var
i, tmp: integer;
ch: char;
blank: boolean;
begin
tmp:= 0;
i:= 0;
while i < 9 do
begin
i:= i + 1;
ch:= p[i];
blank:= ch = ' ';
if not blank
then tmp:= tmp + table[(i-1)*9 + ord(ch) - zero]
else tmp:= tmp + table[i*9];
if blank
then if i <> 5 then tmp:= tmp + 2
else
else
case i of
5:;
2,4,6,8:
if p[5] <> ' '
then if (p[preint[i]] <> prech[ch])
and (ch <> prech[p[5]])
then tmp:= tmp + 5
else
else
if p[preint[i]] <> prech[ch]
then tmp:= tmp + 5;
1,3,7,9:
if p[preint[i]] <> prech[ch]
then tmp:= tmp + 3
end
end;
evaluate:= tmp
end { evaluate };
{***********************************************}
procedure print_square (var p: square);
var
i,j: integer;
begin
for i:= 1 to 3 do
begin
if p[i] <> onscreen[i]
then
begin
gotoxy(i+i+17,10);
write (p[i]);
onscreen[i]:= p[i]
end;
j:= i + 3;
if p[j] <> onscreen[j]
then
begin
gotoxy(i+i+17,12);
write (p[j]);
onscreen[j]:= p[j]
end;
j:= j + 3;
if p[j] <> onscreen[j]
then
begin
gotoxy(i+i+17,14);
write (p[j]);
onscreen[j]:= p[j]
end
end;
delay (25);
end { print_square };
{***********************************************}
procedure initialise;
procedure init_eval;
var
a,b,c: packed array [1..27] of char;
i: byte;
begin
a:= '012132342101223321210314322';
b:= '123021231212112120321203211';
c:= '234130122323221011432312102';
for i:= 1 to 27 do
begin
table[i]:= ord(a[i]) - zero;
table[i+27]:= ord(b[i]) - zero;
table[i+54]:= ord(c[i]) - zero
end;
preint[1]:= 4; preint[2]:= 1; preint[3]:= 2;
preint[4]:= 7; preint[5]:= 5; preint[6]:= 3;
preint[7]:= 8; preint[8]:= 9; preint[9]:= 6;
prech['1']:= '4'; prech['2']:= '1'; prech['3']:= '2';
prech['4']:= '6'; prech['5']:= '3'; prech['6']:= '7';
prech['7']:= '8'; prech['8']:= '5';
end { init_eval };
procedure initmov;
var
i,j: byte;
tab: packed array [1..45] of char;
begin
tab:= '224003153022600315704246833590248003759026800';
for i:= 1 to 9 do
for j:= 1 to 5 do
moves[i,j]:= ord(tab[(i-1)*5+j]) - zero
end { initmov };
procedure init_square;
var
i: integer;
ch: char;
procedure random_entry;
var
i,hole, new_hole: integer;
begin
randomize;
original:= goal;
hole:= 5;
for i:= 1 to 500 do
begin
new_hole:= random(moves[hole,1]) + 1;
new_hole:= moves[hole,new_hole + 1];
original[hole]:= original[new_hole];
original[new_hole]:= ' ';
hole:= new_hole
end
end { random entry };
procedure debug_entry;
var
i: byte;
key: integer;
begin
gotoxy(1,14);
for i:= 1 to 9 do
begin
write ('Square #':15, i:1, ' ? ');
repeat
key:= inkey
until (hi(key) = 1) and (lo(key) in [32, 49..56]);
original[i]:= chr(key);
writeln (chr(key))
end;
end { debug_entry };
begin { init_square }
gotoxy (10,13);
write ('<D>ebug or <R>andom ? ');
ch:= readkey;
if (ch = 'd') or (ch = 'D')
then debug_entry
else random_entry;
gotoxy (1,13);
clreol
end { init_square };
procedure init_frame;
var
i,j: byte;
procedure line;
begin
write (chr(186), chr(186):2, chr(186):2, chr(186):2)
end;
procedure join;
begin
write (chr(204), chr(205), chr(206), chr(205),
chr(206), chr(205), chr(185));
end;
begin
fillchar (onscreen, 9, ' ');
highvideo;
gotoxy (18,9);
{ top line }
write (chr(201),chr(205), chr(203), chr(205),
chr(203), chr(205), chr(187));
gotoxy(18,10); line;
gotoxy(18,11); join;
gotoxy(18,12); line;
gotoxy(18,13); join;
gotoxy(18,14); line;
{ bottom line }
gotoxy(18,15);
write (chr(200), chr(205), chr(202), chr(205), chr(202),
chr(205), chr(188));
normvideo;
end { init_frame };
begin { initialise }
init_eval;
initmov;
init_square;
init_frame;
fillchar (hash_table, hash_max_plus*9, 'a')
end;
{***********************************************}
procedure human;
var
sq: square;
your_move, hole, i: integer;
flag: boolean;
function legal : boolean;
begin
case hole of
1: legal:= your_move > 0;
2: legal:= your_move <> -3;
3: legal:= (your_move = -1) or (your_move = 3);
4: legal:= your_move <> -1;
5: legal:= true;
6: legal:= your_move <> 1;
7: legal:= (your_move = -3) or (your_move = 1);
8: legal:= your_move <> 3;
9: legal:= your_move < 0;
else legal:= true
end
end { legal };
begin { human }
sq:= original;
gotoxy(1,19);
writeln ('Use the arrow keys to move the hole');
write ('F10 to quit');
clreol;
gotoxy(1,24);
write('Moves so far - ');
while sq <> goal do
begin
hole:= 1;
while sq[hole] <> ' ' do hole:= hole + 1;
repeat
gotoxy(1,22);
write('Which way do you want to move the hole? ');
case inkey of
72: your_move:= -3;
75: your_move:= -1;
80: your_move:= 3;
77: your_move:= 1;
68: your_move:= 4; { finish }
else your_move:= 5 { illegal }
end
until legal;
if your_move = 5 then { do nothing }
else if your_move = 4
then
begin
humplay:= false;
humcount:= 0;
sq:= goal { force an end }
end
else if legal
then
begin
sq[hole]:= sq[hole + your_move];
sq[hole + your_move]:= ' ';
print_square(sq);
humcount:= humcount + 1;
gotoxy(16,24);
write (humcount)
end
end
end;
{***********************************************}
procedure computer;
label
999;
type
node = ^node_type;
node_type = record
index: 0..hash_max;
score, hole: integer;
parent, next: node
end;
var
head, n, son, free: node;
i, inc: integer;
finished: boolean;
procedure insert (var head: node; son: node);
var
front, rear: node;
count: integer;
duplicate: boolean;
procedure attach (head: node);
begin
if front = nil
then front:= head
else rear^.next:= head;
rear:= head
end { attach };
begin { insert }
duplicate:= false;
if son^.score < head^.score
then
begin
son^.next:= head;
head:= son
end
else
begin
front:= nil;
count:= 0;
while son^.score >= head^.score do
begin
duplicate:= son^.index = head^.index;
attach (head);
head:= head^.next;
count:= count + 1
end;
if not duplicate then duplicate:= count > 20;
if duplicate
then attach (head)
else
begin
son^.next:= head;
attach (son)
end;
head:= front
end
end { insert };
function hash (var sq: square): integer;
{ returns -1 if sq is not a new square,
else returns the hash value, and as a side effect,
the square is entered into the hash table }
var
first, found: boolean;
h, acc, i: integer;
begin
h:= 0;
for i:= 1 to 4 do
begin
acc:= 10 * ord(sq[i]) + ord(sq[i+4]);
h:= (10*h + acc) mod hash_max_plus
end;
h:= (h + ord(sq[9])) mod hash_max_plus;
found:= false;
repeat
if hash_table[h,1] = 'a'
then
begin
found:= true;
first:= true;
hash_table[h]:= sq
end
else if hash_table[h] = sq
then
begin
found:= true;
first:= false
end
else h:= (h + 63) mod hash_max_plus ;
until found;
if first
then hash:= h
else hash:= -1
end { hash };
function makenode (father: node; i: integer): node;
var
switch, space: integer;
h: integer;
sq: square;
n: node;
begin
with father^ do
begin
space:= hole;
sq:= hash_table[index]
end;
switch:= moves[space,i+1];
if i > moves[space,1]
then makenode:= nil
else
begin
sq[space]:= sq[switch];
sq[switch]:= ' ';
h:= hash(sq);
if h >= 0
then
begin
new(n);
with n^ do
begin
index:= h;
hole:= switch;
score:= evaluate(sq) + inc;
parent:= father;
next:= nil
end;
makenode:= n
end
else makenode:= nil;
end
end { makenode };
begin { computer }
gotoxy (1,20);
write ('Give me a moment while I solve ');
gotoxy (1,21);
write ('this puzzle ... ');
clreol;
new (head);
with head^ do
begin
index:= hash(original);
hole:= 1;
while original[hole] <> ' ' do hole:= hole + 1;
score:= evaluate (original);
parent:= nil;
new (next);
with next^ do
begin
score:= maxint;
next:= nil
end
end;
finished:= original = goal;
inc:= 0;
while not finished do
begin
n:= head;
head:= head^.next;
inc:= inc + 1;
i:= 0;
while (i < 4) and not finished do
begin
if inc > 500 then goto 999;
i:= i + 1;
son:= makenode(n,i);
if son <> nil
then
begin
insert (head, son);
finished:= hash_table[son^.index] = goal
end
end;
end;
999:
if not finished
then
begin
gotoxy (1,20);
write ('Sorry to have wasted your time, ');
gotoxy(1,21);
write ('but that puzzle seems unsolvable');
complay:= false
end
else
begin
son^.next:= nil;
head:= son;
while son^.parent <> nil do
begin
son:= son^.parent;
son^.next:= head;
head:= son
end;
compcount:= 0;
print_square (original);
while head <> nil do
with head^ do
begin
head:= next;
print_square(hash_table[index]);
compcount:= compcount + 1;
delay (50);
end;
gotoxy (1,22);
write ('The computer finished in ');
write (compcount:1, ' moves');
clreol;
end
end { computer };
{***********************************************}
begin { main program }
clrscr;
video_mode:= get_mode;
if video_mode <> 7 then set_mode (0);
gotoxy(10,3);
highvideo;
write ('WELCOME TO THE 8 PUZZLE');
normvideo;
gotoxy (18,5);
write ('Version ', version:1);
initialise;
print_square (original);
gotoxy(1,20);
write ('Do you want to try <y/n>? ');
ch:= chr(inkey);
if (ch = 'y') or (ch = 'Y')
then
begin
humplay:= true;
humcount:= 0;
human
end
else humplay:= false;
if humplay
then
begin
gotoxy (1,17);
write ('Your moves - ', humcount)
end;
gotoxy (1,19); clreol;
gotoxy (1,22); clreol;
gotoxy (1,24); clreol;
gotoxy (1,20);
write ('Do you want the computer ');
gotoxy (2,21);
write ('to solve the puzzle <y/n>? ');
ch:= chr(inkey);
if (ch = 'y') or (ch = 'Y')
then
begin
print_square (original);
complay:= true;
computer
end
else complay:= false;
if complay
then
begin
gotoxy (18,17);
write ('My moves - ', compcount)
end;
gotoxy(1,23);
if humplay and complay
then if humcount < compcount
then write ('You beat the computer!')
else if humcount = compcount
then write ('We came out equal that time')
else write ('Better luck next time');
clreol;
gotoxy(1,24);
write ('Press any key to finish ... ');
compcount:= inkey;
if video_mode <> 7 then set_mode (video_mode);
end.