Prolog Rubik's Cube Solver by Dennis Merritt

prolog-rubik-cube-solver.pro

% CUBE SOLVER II
%   A Rubik's Cube Solver
%   written by Dennis Merritt
%   as described in Building Expert Systems in Prolog (Springer-Verlag)
%   available from:
%     Amzi! inc.
%     40 Samuel Prescott Dr.
%     Stow, MA 01775 USA
%     Tel 508/897-7332, FAX 508/897-2784
%     e-mail [email protected]
%
%  This program may be copied, modified and redistributed although proper
%  acknowledgement is appreciated.
%
%  This implementation was done with Cogent Prolog, also available
%  from Amzi! inc.
%
%  This is the main module which contains the predicates for
%         the main control loop,
%         manual mode,
%         solve mode, and
%         utility functions.
%
% Note - The Cogent/Prolog compiler supports modules.  The export declarations
%        are for predicates defined in the current module which may be used
%        by other modules.  The import declarations are for predicates
%        defined in other modules.

:-export main/0.
:-export append/3.
:-export get_flag/2.
:-export set_flag/2.
:-export error/1.
:-export reverse/2.

:-import add_history/1.     % rubhist
:-import cnd/2.             % rubdata
:-import cube_print/1.      % rubdisp
:-import get_color/1.       % rubedit
:-import pristine/1.        % rubdata
:-import rub_help/0.        % rubhelp
:-import m_disp/1.          % rubdisp
:-import m_choose/2.        % rubdisp
:-import move/3.            % rubmov
:-import orientation/2.     % rubdata
:-import pln/2.             % rubdata
:-import rdfield/2.         % rubdisp
:-import rdchar/2.          % rubdisp
:-import redit/1.           % rubedit
:-import rewrite/2.         % rubedit
:-import rot/3.             % rubmov
:-import seq/2.             % rubdata
:-import side_color/1.      % rubdata
:-import s_r/2.             % rubdata
:-import vw/2.              % rubdata
:-import wrfield/2.         % rubdisp
:-import writec/2.          % rubdisp

:-import logfile/1.     % dynamic db
:-import impplan/1.        % dynamic db
:-import state/1.          % dynamic db
:-import crit/1.           % dynamic db
:-import ghoul/1.          % dynamic db
:-import sidecolor/1.      % dynamic db
:-import flag/2.        % dynamic db
:-import cand/1.        % dynamic db
:-import candmove/1.      % dynamic db

:-op(500,xfy,:).

main :- banner, go.  % The start up entry point

go:-                       % The main control loop
  repeat,
  init_color,
  m_disp(main),            % The main menu
  m_choose(main,X),        % Select an item
  do(X),                   % Execute it
  X == exit.               % Go back to the repeat or end

% These are the predicates which are called for the various
% main menu choices.  The cut after each ensures they wont be
% backtracked into when the main loop fails.

do(solve):-solve,!.        % in this module
do(manual):-manual,!.      % in this module
do(help):-rub_help,!.      % in rubhelp
do(exit).                  % built-in predicate to exit

banner:-
  nl,nl,
  write($Cube Solver II$),nl,
  write($An illustrative Prolog program from$),nl,
  write($Building Expert Systems in Prolog (Springer-Verlag) by Dennis Merritt$),nl,
  write($implemented in Cogent Prolog$),nl,nl,
  write($For more information contact:$),nl,
  write($Amzi! inc.$),nl,
  write($40 Samuel Prescott Dr.$),nl,
  write($Stow, MA 01775 USA$),nl,
  write($Tel 508/897-7332, FAX 508/897-2784$),nl,
  write($e-mail [email protected]$),nl,nl.

% These predicates initialize the state to the goal state (ghoul),
% and allow you to enter single moves.  They are intended to demonstrate the
% effects of the various sequences used by the solve routines.

% They are also called by the solve routine if manual scrambling
% is requested

manual:-
  pristine(G),                            % Start with the goal state
  retractif(state(_)),
  assert(state(G)),
  cube_print(G),                       % Display it
  disp_moves,                          % List the possible moves
  repeat,                              % Start repeat-fail loop
  rdfield(move,M),                     % Get a move
  (M==q, nl, !                         % If '', clear and end
   ;
   state(S),
   man_move(M,S,S2),                   % Apply move to it
   retract(state(_)),
   assert(state(S2)),
   cube_print(S2),fail).               % Print it and fail back

man_move(M,S,S2):-
  movel(M,S,S2),!.
man_move(M,S,S2):-               % Pop a + in front of an unsigned move
  movel(+M,S,S2),!.
man_move(M,_,_):-
  error('Unknown move'-M),!,fail.

disp_moves:-                  % List the three types of moves
  wrfield(moves,''),          % Heading
  move(X,_,_),                % Will backtrack through all moves
  write(X),tab(1),            % Write move
  fail.                       % Go back for the next one
disp_moves:-
  nl,
  wrfield(rotations,''),      % No more moves, do the same for rots
  rot(X,_,_),
  write(X),tab(1),
  fail.
disp_moves:-                  % And again for seqs
  nl,
  wrfield(sequences,''),
  seq(X,_),
  write(X),tab(1),
  fail.
disp_moves:-                 % Got em all, end
  nl,
  wrfield(end_disp,'').

% This is the main body of the program which actually solves the cube.
% See rubdoc1 and rubdoc2 for the big picture

solve:-
  m_disp(solve),              % solve submenu
  m_choose(solve,X),
  rdchar(stepmode,SM),
  (SM==`y , set_flag(stepmode,on)   % check for a y (scan code 21)
   ;
   set_flag(stepmode,off)),
  solve(X).                   % call solve w/ arity one with menu choice

solve(X):-
  init_solve(X),              % initialize all the stuff
  T1 is cputime,
  stages,
  T is cputime - T1,
  state(S),
  cube_print(S),
  write($Done  time = $),
  write(T), nl, nl.
solve(X):-
  error('failing to solve'),
  halt.             % something wrong, back to main

init_solve(X):-
  wrfield(prob,X),
  initialize(X),               % getting closer to the real work
  !.

initialize(X):-
  pristine(G),
  retractall(ghoul(_)),
  assert(ghoul(G)),
  init_crit(Crit),           % set up the initial criteria (all variables
  retractall(crit(_)),
  assert(crit(Crit)),
  retractall(stage(_)),
  assert(stage(1)),           % the first stage will call the others
  !,initial(X).              % get specific start state in the database

initial(random):-                 % create a new random cube
  random_cube(Cube),
  retractall(state(_)),
  assert(state(Cube)), !.
initial(edit):-                   % edit your own
  redit(Cube),
  retractall(state(_)),
  assert(state(Cube)),
  new_colors(Cube), !.
initial(manual):-                 % scramble your own
  manual,
  state(Cube),
  new_colors(Cube),!.

stages:-
  repeat,
  retract(stage(N)),
  init_stage(N,Plan),        % Set the stage, get the plan
  state(S),
  cube_print(S),
  build_plan(Plan),
  improve(N,Plan),                % Put the pieces in the plan in place
  vw(N,V),                   % undo the stage view (done by init_stage)
  undo_view(V),
  N2 is N + 1,               % next stage
  assert(stage(N2)),
  N2 >= 7.

build_plan([]) :- !.
build_plan([H|T]) :-
  assert(impplan(H)),
  build_plan(T).

% init_stage goes to rubdata to get the table entries which define
% the heuristics for the stage

init_stage(N,Plan):-         % return list of target pieces for this stage
  wrfield(stage,N),
  cnd(N,Cands),              % set up candidate moves used by search
  build_cand(Cands),
  vw(N,V),                   % set up preferred view for stage
  set_view(V),
  pln(N,Plan),!.             % get list of target pieces

% improve - works through the list of target pieces for the stage.
%           it first checks to see if its already in place

improve(Stage,[]) :- !.
improve(Stage,[Piece|Rest]) :-
  impro(Stage,Piece),
  !, improve(Stage,Rest).

improve(Stage):-
  impplan(Piece),
  impro(Stage,Piece).

impro(Stage,Piece) :-
  add_criteria(Piece,Crit),                % Add new piece to criteria
  target_loc(Piece,Pos,Orient),            % Where is it
  impr(Orient,Stage,Pos,Piece),
  !.

impr(0,_,_,_) :- !.                        % In place and oriented
impr(_,Stage,Pos,Piece) :- imp(Stage,Pos,Piece).

% imp - getting into the real work

imp(Stage,Pos,Piece):-
  color_piece(PieceC,Piece),         % translate side notation to
  wrfield(target,PieceC),            %   color notation for display
  heuristics(Stage,Pos),             % See if special help is needed.
  orientation(Piece, View),          % Preferred view for this piece.
  set_view(View),
  crit(Crit),
  state(State),
  cntr_set(4,0),            % to limit wild searches
%  gc(7),
  rotate(Moves,State,Crit),      % Search for moves which transform
  retract(state(_)),
  assert(state(Crit)),
  wrfield(rot,Moves),
  add_history(Moves),
  undo_view(View),!.

heuristics(Stage,Pos):-
  (shift_right_1(Stage,Pos);
   shift_right_2(Stage,Pos)),!.
heuristics(_,_):-true.

% The shift_right heuristics are used to avoid the situations where
% the piece is in one of the target positions for the stage, but the
% wrong one, or mis-oriented.  By blindly moving it to the right the
% search is reduced since it doesn't have to search to move it both
% out of a critical target position and back into the correct one.

shift_right_1(1,Pos):-
  smember('L',Pos),            % Is the target piece already on the left?
  s_r(Pos,Moves),              % If so get the canned moves to move it
  change(Moves),               % right for easy search.
  !.

shift_right_2(Stage,Pos):-
  Stage < 4,                   % If the target piece is not on the right
  notsmember('R',Pos),         % side, get the canned moves to put it
  s_r(Pos,Moves),              % there to allow easier search
  change(Moves),
  !.

% rotate - the real guts of the solution, all the rest of the code provides
%          support for these six lines.

% These lines illustrate the power and obscurity of Prolog.
% Prolog can be very expressive when the main information is carried
% in the predicate.  However, sometimes the work is being done by
% unification, and it is not at all apparent by reading the code.
% Furthermore, since Prolog predicates often work backwards and
% forwards, it is not clear in a given case what is intended to be
% be input, and what is the output, and, as in this case, what might
% be an in-out.

% The input and output states of rotate are:

% Input: Moves - unbound
%        State - bound to the cube structure for the current state
%        Crit  - partially bound cube structure.  the bound portions
%                represent the pieces in place + the current goal piece

% Output: Moves - a list of moves
%         State - same as input
%         Crit  - fully bound to the new state

% rotate does a breadth first search by recursively calling itself
% before it calls get_move which trys new moves.  it does not save the
% search trees as most breadth first algorithms do, but rather recalculates
% the moves since they can be executed so fast.

% get_move fails when called with the partially bound Crit, unless
% it is a move which reaches the desired state.  The failure causes
% backtracking.  However when rotate calls itself, it gives it a
% fully unbound variable NextState.  This call to rotate succeeds and
% keeps adding new moves generated by get_move on backtracking.

% eventually get_move finds a match and rotate succeeds.

rotate([], State, State).            % start with a no move
rotate(Moves, State, Crit):-         % nothing didnt work, get serious
  rotate(PriorMoves, State, NextState), % get something to build on
%  cntr_inc(4,N4),
%  check_prog(N4),
  get_move(ThisMove, NextState, Crit),  % generate possible moves
  append(PriorMoves, [ThisMove], Moves).   % build up the list

check_prog(N) :- N < 250, !.
check_prog(_) :-
  error('not converging'),
  halt.


% The following predicates all perform various useful services
% for the main predicates above.  Some are declared export as well
% and are used by other modules

% add_criteria puts a new piece on the criteria structure.  it works
% by creating two piece format lists, one of the goal state, and the
% other of the current criteria.  It then walks through the two lists
% simultaneously looking for the target piece in the goal state.
% when it finds it it adds it to the criteria.  Crit is unbound on entry

add_criteria(Piece,Crit):-
  crit(OldCrit),
  pieces(OldCrit, OldCritP),
  ghoul(Ghoul),
  pieces(Ghoul, GhoulP),
  add_crit(OldCritP, GhoulP, NewCritP, Piece),
  pieces(Crit, NewCritP),
  retract(crit(_)),
  assert(crit(Crit)), !.

add_crit([V1|V2], [V3|V4], [V3|V2], V5):-
  matches(V3, V5),!.
add_crit([V1|V2], [V3|V4], [V1|V5], V6):-
  !,add_crit(V2, V4, V5, V6).
add_crit(V1, V2, V3, V4):-
  error('something wrong with add_crit'),!.

% The center tiles dont move on the cube.  Sooo if someone enters a cube
% with different color sides then we must find the new center tiles
% and map the new colors to the sides accordingly

new_colors(Cube):-
  rewrite(ColorCube,Cube),
  get_color(ColorCube),
  rewrite(ColorCube,NewCube),
  retract(state(_)),
  assert(state(NewCube)).

% Set up the initial mapping of sides to colors

init_color:-
  side_color(SC),
  retractall(sidecolor(_)),
  ini_col(SC).

ini_col([]):- !.
ini_col([S-C|T]):-
  assert(sidecolor(S-C)),
  ini_col(T).

% translate a piece in piece notation to color notation

color_piece(PieceC,Piece):-
  Piece=..[p|Args],
  col_p(ArgsC,Args),
  PieceC=..[p|ArgsC].

col_p([],[]):- !.
col_p([PC|RestC],[P|Rest]):-
  sidecolor(P-PC),
  col_p(RestC,Rest).

% execute about 50 or 60 random rotations to the goal cube.  due to the
% random function, the random cubes will be the same from run to
% run.  It always starts from the same seed.

random_cube(Cube):-
  ghoul(Start),
  rand_cub(Start,Cube,50).

rand_cub(Cube,Cube,0).
rand_cub(Now,Cube,N):-
  repeat,
  rand_move(M,RN),
  movel(M,Now,Next),
  NN is N - 1,
  !,rand_cub(Next,Cube,NN).

rand_move(M,RN):-
  RN is integer(random*12),
  arg(RN,m(+f,+b,+r,+l,+u,+d,-f,-b,-r,-l,-u,-d),M).

% the classic

member(V1, [V1|V2]):- !.
member(V1, [V2|V3]):-
  member(V1, V3).

% display a list of terms without the list notation

write_list([]):-true.
write_list([H|T]):-
  write(H),tab(1),
  write_list(T).

% target_loc finds the location of a given piece on the cube.  it can
% also be used to find the piece at a given location.  it returns the
% orientation as well, which is 0 if in place, or 1 if in place but
% twisted

target_loc(Piece, Pos, Orient):-
  ghoul(Gt),
  pieces(Gt, G),
  state(St),
  pieces(St, S),
  find_piece(G, S, Pos, Piece, Orient),!.
target_loc(Piece, _,_):-
  error('Failing to find piece'-Piece),
  fail.

% find_piece does the work for target_loc, walking two lists simultaneously
% looking for either the piece or the position, whichever is bound.

find_piece([Gh|Gt], [Sh|St], Pos, Piece, Orient):-
  matches(Pos, Gh),
  matches(Piece, Sh),
  comp(Gh,Sh,Orient),!.
find_piece([V1|V2], [V3|V4], V5, V6, Orient):-
  !,find_piece(V2, V4, V5, V6, Orient).

matches(V1, V2):-
  comp(V1, V2, V3),
  V3 < 2,!.

% comp returns 0 if direct hit, 1 if in place but twisted, and
% 2 if no match

comp(p(V1), p(V1), 0):- !.
comp(p(V1, V2), p(V1, V2), 0):- !.
comp(p(V1, V2), p(V2, V1), 1):- !.
comp(p(V1, V2, V3), p(V1, V2, V3), 0):- !.
comp(p(V1, V2, V3), p(V1, V3, V2), 1):- !.
comp(p(V1, V2, V3), p(V2, V1, V3), 1):- !.
comp(p(V1, V2, V3), p(V2, V3, V1), 1):- !.
comp(p(V1, V2, V3), p(V3, V1, V2), 1):- !.
comp(p(V1, V2, V3), p(V3, V2, V1), 1):- !.
comp(V1, V2, 2).

% allows easy handling of database entries used as flags

set_flag(Flag,Val):-
  retract(flag(Flag,_)),
  assert(flag(Flag,Val)), !.
set_flag(Flag,Val):-
  assert(flag(Flag,Val)).

get_flag(Flag,Val):-
  flag(Flag,Val).

% get_move is used by rotate to generate moves.  the possible moves
% are stored in the database under the key cand.  backtracking causes
% successive moves to be tried

get_move(+V1, V2, V3):-
  cand(V1),
  movep(V1, V2, V3).
get_move(-V1, V2, V3):-
  cand(V1),
  movep(V1, V3, V2).

% build_cand creates the database of possible moves for a given stage.
% this is one of the important heuristics for limiting the search

build_cand(V1):-
  retractall(cand(_)),
  retractall(candmove(_)),
  build_cands(V1),!.

build_cands([]):- !.
build_cands([V1|V2]):-
  can_seq(V1),
  assertz(cand(V1)),
  !,build_cands(V2).

can_seq(M):-                      % if the search move is a sequence
  seq(M,S),                       % precompute it, so it isn't constantly
  variable(X),                    % redone during search.
  move_list(S,X,Y),
  assertz(candmove(m(M,X,Y))), !.
can_seq(_).

% another classic

append([], V1, V1).
append([V1|V2], V3, [V1|V4]):-
  append(V2, V3, V4).

% apply a list of moves to a state

move_list([], V1, V1):- !.
move_list([Move|V3], V4, V5):-
  movel(Move, V4, V6),
  !,move_list(V3, V6, V5).

% movel is the basic move predicate called from everywhere

movel(+M, V2, V3):-        % distinguish between clockwise
  movep(M, V2, V3),!.
movel(-M, V2, V3):-        % and counter clockwise moves
  movep(M, V3, V2),!.

% find the move, be it a simple move, a rotation, or a sequence.
% if its a sequence break it into its simple componenents

movep(M, X, Y):- move(M, X, V3), !, Y = V3.
movep(M, X, Y):- rot(M, X, V3), !, Y = V3.
movep(M, X, Y):- candmove(m(M,X,V3)), !, Y = V3.
movep(V1, V2, V3):-
  seq(V1, V4), !,
  move_list(V4, V2, V3),!.
movep([V1|V2], V3, V4):- move_list([V1|V2], V3, V4),!.

% same as move_list, only print new state when done

move_listp(V1, V2, V3):-
  move_list(V1, V2, V3),
  wrfield(rot,V1).

% change is move_list for keeps.
% it takes the old value changes it, updates it,
% and records the history.  it is called by the heuristic routines

change(ML):-
  retract(state(Old)),
  move_listp(ML,Old,New),
  add_history(ML),
  assert(state(New)), !.

% establish a new view.  this means not just rotating the cube, but also
% rotating the criteria and the goal structures.  this is necessary so
% any predicates working with any of the three winds up comparing
% apples and apples.

set_view([]):- !.
set_view(V):-
  retract(state(S1)),
  move_list(V, S1, S2),
  assert(state(S2)),
  retract(ghoul(G1)),
  move_list(V, G1, G2),
  assert(ghoul(G2)),
  retract(crit(C1)),
  move_list(V, C1, C2),
  assert(crit(C2)),
  wrfield(rot,V),
  add_history(V),!.

undo_view([]):- !.
undo_view(RV):-
  reverse(RV,V),
  set_view(V),!.


% convert a cube structure to a list of pieces and visa versa

pieces(cube(X1, X2, X3, X4, X5, X6,
  V7, V8, V9, V10, V11, V12, V13, V14, V15, V16, V17,
  V18, V19, V20, V21, V22, V23, V24, V25, V26, V27, V28, V29, V30,
  V31, V32, V33, V34, V35, V36, V37, V38, V39, V40, V41, V42, V43,
  V44, V45, V46, V47, V48, V49, V50, V51, V52, V53, V54),
    [p(X1), p(X2), p(X3), p(X4), p(X5), p(X6),
  p(V7, V8, V9), p(V10, V11, V12), p(V13, V14, V15), p(V16, V17, V18),
  p(V19, V20, V21), p(V22, V23, V24), p(V25, V26, V27), p(V28, V29, V30),
  p(V31, V32), p(V33, V34), p(V35, V36), p(V37, V38),
  p(V39, V40), p(V41, V42),
  p(V43, V44), p(V45, V46), p(V47, V48),
  p(V49, V50), p(V51, V52), p(V53, V54)]).

% get an unbound cube

variable(cube(X1, X2, X3, X4, X5, X6,
  V7, V8, V9, V10, V11, V12, V13, V14, V15, V16, V17, V18, V19,
  V20, V21, V22, V23, V24, V25, V26, V27, V28, V29, V30, V31, V32, V33,
  V34, V35, V36, V37, V38, V39, V40, V41, V42, V43, V44, V45, V46, V47,
  V48, V49, V50, V51, V52, V53, V54)).

% the initial criteria, unbound except for the six center tiles

init_crit(cube('F', 'R', 'U', 'B', 'L', 'D',
  V7, V8, V9, V10, V11, V12, V13, V14, V15, V16, V17, V18, V19,
  V20, V21, V22, V23, V24, V25, V26, V27, V28, V29, V30, V31, V32, V33,
  V34, V35, V36, V37, V38, V39, V40, V41, V42, V43, V44, V45, V46, V47,
  V48, V49, V50, V51, V52, V53, V54)).

notsmember(X,Y):-smember(X,Y),!,fail.
notsmember(X,Y):-true.

% like the classic, but works on a structure instead

smember(X,Y):-
  Y=..[Fun|Args],
  member(X,Args).

% display errors

error(X):-
  wrfield(error,X), nl,
  get1(_).

% reverse a list of moves, and flip the signs along the way

reverse(L, R) :- rever(L, [], R).

rever([], Z, Z).
rever([H|T], X, Z) :-
  flip_sign(H, FH),
  rever(T, [FH|X], Z).

flip_sign(+ X, - X):- !.
flip_sign(- X, + X):- !.

retractif(X) :-
  retract(X),
  !.
retractif(_).