Программма - решатель пятнашек. Реализация на pascal-е. Проверенно в PascalABC.NET.
Работает дико медленно :) Но работает.
Имеем на воходе разложение пятнашек в виде массива 4x4, с цифрами от 0 до 15. Где "0" пустая клетка. Разложение может быть случайным. Решением является перестановка фишек в строй по порядку от 1 до 15.
| 1 | 2 | 3 | 4 |
| 5 | 6 | 7 | 8 |
| 9 | 10 | 11 | 12 |
| 13 | 14 | 15 | 0 |
Ровно в половине случаев задачу невозможно разрешить. Решение необходимо выполнить за минимально возможное количество ходов.
Для решения задачи используется алгоритм A star(A*). Он заключается в обходе графа всех возможных состояний поля с учетом предыдущих.
В качестве эвристической функции используется манхеттеновское расстояние. Причем если убрать из программы учет номера шага, то решение будет находиться очень быстро, но это будет не оптимальное решение. В данном примере решение находится за 90 ходов, а оптимальное 44.
program fifth;
{// A* algorithm}
const
move_desc: array of char = ('D', 'L', 'U', 'R');// Возможные ходы
opposite_move: array of integer = (2, 3, 0, 1);// Противоположные ходы (2, 3, 0, 1)
type
pA = ^tA;
tA = Array[0..3, 0..3] of integer;
var
board: tA;
id: double;
x0, y0: integer;
var
boardGoal: tA;// доска целевого состояния
var
resultString: string;//результат
var
ols, cls: integer;
type
pState = ^TState;
TState = record
// board: pA; // доска
x, y: smallint;
id: int64;
end;
type
pNode = ^tNode;
tNode = record
state: pState;
f, g, h: smallint;
move: char;
parent: pNode;
end;
type
pList = ^tList;
tList = record
val: pNode;
next, prev: pList;
end;
var
openList, closedList: pList;
initNode: pNode;
minNode:pNode;
procedure writelist(s: string; list: pList);
var
l: pList;
begin
l := list;
writeln(s);
while l <> nil do
begin
if l^.val <> nil then writeln(integer(l^.val));
l := l^.next;
end;
end;
procedure AddE(var list: pList; node: pNode);
var
l: pList;
begin
if list = nil then
begin
new(list);
l := list;
end
else begin
l := list;
new(list);
list^.next := l;
end;
list^.val := node;
end;
procedure DelE(var list: pList; var node: pNode);
var
l, t: pList;
begin
if list = nil then exit;
l := list;
if l^.val = node then begin
list := list^.next;
dispose(l);
exit;
end;
while l^.next <> nil do
begin
if l^.next^.val = node then begin
t := l^.next;
l^.next := t^.next;
dispose(t);
exit;
end;
l := l^.next;
end;
end;
procedure DelEL(var list,prev: pList);
var
l, t: pList;
begin
if list = nil then exit;
if prev <> nil then begin
prev^.next:=list^.next;
end;
dispose(list);
list:=nil;
end;
procedure DelI(var list: pList; var item: pList);
var
l: pList;
begin
if list = nil then exit;
l := list;
if l = item then begin
list := list^.next;
dispose(l);
exit;
end;
while l^.next <> nil do
begin
if l^.next = item then begin
l^.next := item^.next;
dispose(l);
exit;
end;
l := l^.next;
end;
end;
procedure DelA(var list: pList);
var
l, t: pList;
begin
l := list;
while list <> nil do
begin
t := list;
list := list^.next;
if t^.val <> nil then begin
if t^.val^.state <> nil then dispose(t^.val^.state);
dispose(t^.val);
t^.val := nil;
end;
dispose(t);
t := nil;
end;
end;
procedure wl(s: string; list: pList);
var
l: pList;
begin
l := list;
writeln(s);
while l <> nil do
begin
wp('', l^.val);
l := l^.next;
end;
end;
//--------------------------------
//инициализирует целевое состояние
procedure initGoalArrays;
begin
var i: integer;
for i := 0 to 14 do
begin
goalX[i + 1] := i mod 4;
goalY[i + 1] := i div 4;
end;
goalX[0] := 3;
goalY[0] := 3;
end;
//определяет "решаемость" пятнашек
function isSolvable: Boolean;
begin
var count, transpos, value, i, j: integer;
count := 0;
transpos := 0;
value := 0;
var a: Array[0..16] of integer;
for i := 0 to 3 do
begin
if (i mod 2 = 0) then begin
for j := 0 to 3 do
begin
value := board[i][j];
if (value > 0) then begin
a[count] := value;
inc(count);
end;
end;
end
else
begin
for j := 3 downto 0 do
begin
value := board[i][j];
if (value > 0) then begin
a[count] := value;
inc(count);
end;
end;
end;
end;
for i := 0 to count - 2 do
begin
for j := i + 1 to count - 1 do
begin
if (a[i] > a[j]) then begin
inc(transpos);
end;
end;
end;
isSolvable := ((transpos mod 2) = 1);
end;
//эвристическая оценочная функция Манхеттеновское расстояние
function estimate(board: pA): integer;
begin
var manhattan, i, j, value, m: integer;
manhattan := 0;
for i := 0 to 3 do
for j := 0 to 3 do
begin
value := board^[i][j];
if (value > 0) then begin
m := abs(i - goalY[value]) + abs(j - goalX[value]);
manhattan := manhattan + m;
end;
end;
estimate := manhattan;
end;
//
procedure writed(h, n: integer);
begin
var i, j: integer;
for i := 0 to 3 do
begin
for j := 0 to 3 do
write(board[i][j] + ' ');
writeln;
end;
write(h);
writeln(' ' + move_desc[n]);
writeln;
end;
procedure find0cell;
begin
var i, j: integer;
// поиск пустой клетки
for i := 0 to 3 do
for j := 0 to 3 do
begin
if (board[i][j] = 0) then begin
x0 := j;
y0 := i;
end;
end;
end;
//строит уникальный идентификатор по доске
function getUniqueID(p: pA): int64;
var
d, t, k: int64;
i, r, j: integer;
begin
d := 0;
r := 0;
for j := 0 to 3 do
for i := 0 to 3 do
begin
k := p^[j][i];
t := k shl r;
d := d or t;
r := r + 4;
end;
getUniqueID := d;
end;
procedure unpackID(p: pA; id: int64);
var
i, j: integer;
d, t, n: int64;
begin
t := 0;
n := 15;
for j := 0 to 3 do
for i := 0 to 3 do
begin
d := n shl t;
d := (id and d);
d := (d shr t) and n;
p^[j][i] := d;
t := t + 4;
end;
end;
procedure writen(n: pNode);
var
i, j: integer;
b: tA;
begin
unpackID(@b, n^.state^.id);
for i := 0 to 3 do
begin
for j := 0 to 3 do
write(b[i][j] + ' ');
writeln;
end;
writeln;
end;
procedure SetState(id: int64; s: pState; xo, yo: integer);
begin
var i, j: integer;
s^.x := xo;
s^.y := yo;
s^.id := id;
end;
function isInList(list: pList; n: pNode): boolean;
var
l: pList;
begin
l := list;
while l <> nil do
begin
if l^.val <> nil then begin
if n^.state^.id = l^.val^.state^.id then
begin
isInList := true;
exit;
end;
end;
l := l^.next;
end;
isInList := false;
end;
function isInListID(list: pList; id: int64; var tl: pList): boolean;
var
l: pList;
i: integer;
begin
l := list;
while l <> nil do
begin
if l^.val <> nil then begin
if id = l^.val^.state^.id then
begin
isInListID := true;
tl := l;
exit;
end;
end;
l := l^.next;
end;
tl := nil;
isInListID := false;
end;
//строит всех наследников этого состояния: то есть
//список всех состояний, в которые можно перейти из текущего
procedure successors(n: pNode);
var
i, j, newx, newy, t: integer;
ns, s: pState;
list: pList;
node: pNode;
previousMove: char;
id, uid: int64;
iO, iC: boolean;
cost: integer;
ol, cl: pList;
begin
s := n^.state;
previousMove := n^.move;
unpackID(@board, s^.id);
for i := 0 to 3 do
begin//перебираем всевозможные ходы пустой клетки
if previousMove <> move_desc[opposite_move[i]] then
begin
newx := s^.x + dx[i];
newy := s^.y + dy[i]; //новые координаты пустой клетки
if ((newy >= 0) and (newy <= 3) and (newx >= 0) and (newx <= 3)) then begin
t := board[newy][newx]; //двигаем пустую клетку на новое место
board[newy][newx] := 0;
board[s^.y][s^.x] := t;
id := getUniqueID(@board);
iO := isInListID(openList, id, ol);
iC := isInListID(closedList, id, cl);
new(ns);
SetState(id, ns, newx, newy);
//добавляем новоиспеченный узел в список
new(node);
node^.state := ns;
node^.g := n^.g + 1; // 1 - is cost
node^.h := estimate(@board);
node^.f := node^.g + node^.h;
node^.move := move_desc[i];//запоминаем ход, с помощью которого получили этого наследника
node^.parent := n;
if(not iO) and (not iC) then begin
AddE(openList, node);
inc(ols);
end else
if iO then begin
if ol^.val^.f > node^.f then begin
AddE(openList, node);
inc(ols);
end
else begin dispose(ns);dispose(node);end;
end
else
if iC then begin
if cl^.val^.f > node^.f then begin
DelE(closedList, cl^.val);
AddE(openList, node);
end
else begin dispose(ns);dispose(node); end;
end;
board[newy][newx] := t; //пустую клетку - на место
board[s^.y][s^.x] := 0;
end;
end;
end;
end;
var
rGoal: int64;
//проверяет, "а не цель ли это?"
function isGoal(s: pState): boolean;
begin
var i, j, v: integer;
if s^.id = rGoal then isGoal := true else isGoal := false;
end;
function genstep(n: pNode; c: integer): string;
var
i, j: integer;
b: tA;
s: string;
begin
unpackID(@b, n^.state^.id);
str(c, s);
result := 'step ' + s + #13;
for i := 0 to 3 do
begin
for j := 0 to 3 do
begin
str(b[i][j], s);
result := result + s + ' ';
end;
result := result + #13;
end;
result := result + #13;
end;
//строит строку-результат, пробегая узлы от конца к началу
procedure buildResult(lastNode: pNode);
var
currentNode: pNode;
n: integer;
step: string;
begin
resultString := '';
step := '';
currentNode := lastNode;
while (currentNode^.parent <> nil) do
begin
resultString := currentNode^.move + resultString;
step := genstep(currentNode, n) + step;
inc(n);
currentNode := currentNode^.parent;
end;
writeln(step);
write('moves:');
writeln(n);
end;
var
minh: integer;
function solve: boolean ;
var
mini, i: integer;
node: pNode;
list,prev,mprev,mlist: pList;
begin
AddE(openList, initNode);
inc(ols);
//основной A* цикл
while openList <> nil do
begin
//ищем минимальный узел в OPEN-списке (по критерию min(f))
minNode := openList^.val;
list := openList;
prev := nil;
mlist:=openList;
mprev:=nil;
while list <> nil do
begin
node := list^.val;
if (node^.f < minNode^.f) or ((node^.f = minNode^.f) and (node^.h < minNode^.h)) then begin
minNode := node;
mprev:=prev;
mlist:=list;
end;
prev := list;
list := list^.next;
end;
//удаляем minNode из OPEN-списка
if(mprev <> nil) then begin
if(mlist <> nil) then begin
mprev^.next:=mlist^.next;
dispose(mlist);mlist:=nil;
end
else
mprev^.next:=nil;
end
else if mlist <> nil then begin
openList:=mlist^.next;
dispose(mlist);mlist:=nil;
end;
dec(ols);
if minNode^.h < minh then
minh := minNode^.h;
if isGoal(minNode^.state) then begin
//если это цель
buildResult(minNode); //строим строку-результат
solve := true; //ура!
exit;
end;
//создаем потомков minNode и
//добавляем потомков minNode в OPENLIST
successors(minNode);
//добавляем минимальный узел в CLOSEDLIST
AddE(closedList, minNode);
inc(cls);
if(cls mod 50000) = 0 then begin write('|'); end else
if(cls mod 1000) = 0 then begin {writeln(cls);writeln(ols);}write('.'); end;
end;
writeln;
//если OPEN-список исчерпан
solve := false; //к цели не пришли :(
end;
// ----------------------------
begin
id := 0;
initGoalArrays();
board[0][0] := 2;
board[0][1] := 5;
board[0][2] := 4;
board[0][3] := 6;
board[1][0] := 1;
board[1][1] := 13;
board[1][2] := 11;
board[1][3] := 3;
board[2][0] := 14;
board[2][1] := 12;
board[2][2] := 7;
board[2][3] := 10;
board[3][0] := 8;
board[3][1] := 15;
board[3][2] := 9;
board[3][3] := 0;
// Исходная доска
{board[0][0] := 5;
board[0][1] := 1;
board[0][2] := 2;
board[0][3] := 3;
board[1][0] := 9;
board[1][1] := 7;
board[1][2] := 11;
board[1][3] := 4;
board[2][0] := 13;
board[2][1] := 6;
board[2][2] := 15;
board[2][3] := 8;
board[3][0] := 14;
board[3][1] := 10;
board[3][2] := 12;
board[3][3] := 0;
}
{
board[0][0] := 1;
board[0][1] := 2;
board[0][2] := 3;
board[0][3] := 13;
board[1][0] := 6;
board[1][1] := 4;
board[1][2] := 12;
board[1][3] := 0;
board[2][0] := 15;
board[2][1] := 5;
board[2][2] := 8;
board[2][3] := 7;
board[3][0] := 9;
board[3][1] := 10;
board[3][2] := 14;
board[3][3] := 11;
}
// Целевая доска
boardGoal[0][0] := 1;
boardGoal[0][1] := 2;
boardGoal[0][2] := 3;
boardGoal[0][3] := 4;
boardGoal[1][0] := 5;
boardGoal[1][1] := 6;
boardGoal[1][2] := 7;
boardGoal[1][3] := 8;
boardGoal[2][0] := 9;
boardGoal[2][1] := 10;
boardGoal[2][2] := 11;
boardGoal[2][3] := 12;
boardGoal[3][0] := 13;
boardGoal[3][1] := 14;
boardGoal[3][2] := 15;
boardGoal[3][3] := 0;
new(initNode);
new(initNode^.state);
find0cell;
SetState(getUniqueID(@board), initNode^.state, x0, y0);
initNode^.h := estimate(@board);
initNode^.g := 0;
initNode^.move := '0';
initNode^.parent := nil;
initNode^.f := initNode^.g + initNode^.h;
minh := initNode^.h;
writed(0, 0);
rGoal := getUniqueID(@boardGoal);
if not isSolvable then begin// если задача нерешаема
writeln('Задача неразрешима');
end
else if (estimate(@board) = 0) then begin//если это уже цель
writeln('Это уже цель');
end
else if (solve) then begin//делаем IDA* поиск
writeln('Путь:' + resultString); //выводим результат
end
else
writeln('A* failed');
DelA(openList);
DelA(closedList);
end.