SWISH -- SWI-Prolog for SHaring

/* Notes for this are at https://www.seatavern.co.za/TowerOfHanoi */

:- dynamic true/1, does/2.
role(player).
init(on(disc5, pillar1)).
init(on(disc4, disc5)).
init(on(disc3, disc4)).
init(on(disc2, disc3)).
init(on(disc1, disc2)).
init(clear(disc1)).
init(clear(pillar2)).
init(clear(pillar3)).
init(step(0)).

legal(player, puton(X, Y)) :- true(clear(X)), true(clear(Y)), smallerdisc(X, Y).
next(step(Y)) :- true(step(X)), succ(X, Y).
next(on(X, Y)) :- does(player, puton(X, Y)).
next(on(X, Y)) :- true(on(X, Y)), \+(put_on_any(X)).
next(clear(Y)) :- true(on(X, Y)), put_on_any(X).
next(clear(Y)) :- true(clear(Y)), \+(put_any_on(Y)).
put_on_any(X) :- does(player, puton(X, _Y)).
put_any_on(Y) :- does(player, puton(_X, Y)).
goal(player, 100) :- tower(pillar3, 5).
goal(player, 80) :- tower(pillar3, 4).
goal(player, 60) :- tower(pillar3, 3).
goal(player, 40) :- tower(pillar3, 2).
goal(player, 0) :- tower(pillar3, Height), smaller(Height, 2).
terminal :- true(step(31)).
tower(X, 0) :- true(clear(X)).
tower(X, Height) :- true(on(Y, X)), disc_or_pillar(Y), tower(Y, Height1), succ(Height1, Height).
pillar(pillar1).
pillar(pillar2).
pillar(pillar3).
nextsize(disc1, disc2).
nextsize(disc2, disc3).
nextsize(disc3, disc4).
nextsize(disc4, disc5).
nextsize(disc5, Pillar) :- pillar(Pillar).
disc_or_pillar(disc1).
disc_or_pillar(disc2).
disc_or_pillar(disc3).
disc_or_pillar(disc4).
disc_or_pillar(disc5).
disc_or_pillar(P) :- pillar(P).
smallerdisc(A, B) :- nextsize(A, B).
smallerdisc(A, B) :- nextsize(A, C), smallerdisc(C, B).

smaller(X, Y) :- succ(X, Y).
smaller(X, Y) :- succ(X, Z), smaller(Z, Y).

findinits(Start) :-
  findall(Base, init(Base), Unsorted),
  sort(Unsorted, Start).

update_state(State) :-
  retractall(true(_)), 
  forall(member(Base, State), assertz(true(Base))).

update_does(Player, Action) :-
  retractall(does(Player, _)), 
  assertz(does(Player, Action)).

findlegals(Role, Legals) :-
    findall(legal(Role, Action), legal(Role, Action), Unsorted),
    sort(Unsorted, Legals).

findnext(legal(Role, Action), Next) :-
    update_does(Role, Action),
    findall(Base, next(Base), Unsorted),
    sort(Unsorted, Next).

findreward(Role, State, goal(Role, Reward)) :-
    update_state(State),
    goal(Role, Reward).

combinelists(_, [], [], [], []).
combinelists(State, [legal(Player, Action)|Legals], [Next|Nexts], [Goal|Goals],
             [move(State, does(Player, Action), Next, Goal)|Moves]) :-
    combinelists(State, Legals, Nexts, Goals, Moves).

generatemoves_(_, []) :-
    terminal.

generatemoves_(Parent, Moves) :-
    \+terminal,
    role(Player),
    findlegals(Player, Legals),
    maplist(findnext, Legals, Nexts),
    maplist(findreward(Player), Nexts, Rewards),
    combinelists(Parent, Legals, Nexts, Rewards, Moves).

generatemoves(Parent, Moves) :-
    update_state(Parent),
    generatemoves_(Parent, Moves), !.

remove_culdesacs([], Graph, Graph).
remove_culdesacs([move(Parent, _, _, _)|DeadEnds], GraphIn, Acc) :-
    findall(move(Grandparent, Action, Parent, Goal),
            (   member(move(Grandparent, Action, Parent, Goal), GraphIn),
                \+memberchk(move(Parent, _, _, _), GraphIn)
            ), Ps),
    subtract(GraphIn, Ps, GraphOut),
    append(Ps, DeadEnds, Unsorted),
    sort(Unsorted, NewDeadEnds),
    remove_culdesacs(NewDeadEnds, GraphOut, Acc).

removestep(move(Parent, _, _, _), NoStep) :-
    select(step(_), Parent, NoStep).

deadleaf(Limit, move(Parent, _, Child, goal(_, Value))) :-
    member(step(Limit), Parent),
    Value < 100,
    update_state(Child),
    terminal.

cycle(Limit, NoSteps, move(Parent, _, Child, _)) :-
    member(step(Limit), Parent),
    select(step(_), Child, NoStep),
    memberchk(NoStep, NoSteps).

childless(M, Graph, move(Parent, _, Child, _)) :-
    succ(N, M),
    member(step(N), Parent),
    \+memberchk(move(Child, _, _, _), Graph).

deadstate(Limit, _NoSteps, Move) :-
    deadleaf(Limit, Move), !.

deadstate(Limit, NoSteps, Move) :-
    cycle(Limit, NoSteps, Move).

prune(Limit, Unpruned, Pruned) :-
    maplist(removestep, Unpruned, NoSteps),
    exclude(deadstate(Limit, NoSteps), Unpruned, G2),
    partition(childless(Limit, G2), G2, Childless, G3),
    remove_culdesacs(Childless, G3, Pruned).

getchildren(Parent, Visited, Children) :-
    generatemoves(Parent, Moves),
    findall(Move, 
            (member(Move, Moves), \+memberchk(Move, Visited)), 
            NoDuplicates),  
    sort(NoDuplicates, Children).

depthfirst(_, [], RGraph, Graph) :-
    reverse(RGraph, Graph).

depthfirst(Limit, [move(Parent, Action, Child, Goal)|Frontier], Visited, Acc) :-
    memberchk(step(Depth), Child),
    Depth \== Limit,
    depthfirst(Limit, Frontier, [move(Parent, Action, Child, Goal)|Visited], Acc).

depthfirst(Limit, [move(Parent, Action, Child, Goal)|Frontier], Visited, Acc) :-
    memberchk(step(Limit), Child),
    getchildren(Child, Visited, GrandChildren),
    append(GrandChildren, Frontier, NewFrontier),
    depthfirst(Limit, NewFrontier, 
               [move(Parent, Action, Child, Goal)|Visited], Acc).

iterative_deepening(_, Graph, Graph) :-
    memberchk(move(_, _, _, goal(_, 100)), Graph).

iterative_deepening(Depth, GraphIn, Acc) :-
    \+memberchk(move(_, _, _, goal(_, 100)), GraphIn),
    depthfirst(Depth, GraphIn, [], Unpruned),
    Unpruned \== GraphIn,
    prune(Depth, Unpruned, GraphOut),
    succ(Depth, Limit),
    iterative_deepening(Limit, GraphOut, Acc).

getactions(Start, Graph, [Node|_], Actions, [Action|Actions]) :-
    member(move(Start, Action, Node, _), Graph).

getactions(Start, Graph, [Child|Path], Actions, Acc) :-
    member(move(Parent, Action, Child, _), Graph),
    Parent \== Start,
    getactions(Start, Graph, [Parent, Child|Path], [Action|Actions], Acc).

route(Actions) :-
    findinits(Start),
    getchildren(Start, [], G1),
    prune(0, G1, G2),
    iterative_deepening(1, G2, G3),
    member(move(_, _, End, goal(_, 100)), G3),
    getactions(Start, G3, [End], [], Actions).