# Functions for "Solving a Sliding Block Puzzle" SolutionList := function(Graph, N) # Purpose: Determine all sequences of legal moves # Input: Graph - list of (ordered pairs) edges of the graph # The pairs will be used as transpositions # The graph has N vertices. # N - number of vertices. Originally movable discs # are on vertices numbered 1 through N-1 # Output: Sols - list of ordered pairs, [mv, t], where # mv is the identity and t = N or # mv = r*t, where r is a placement whose length is one # less than the length of mv. Note: Since t^2 is the # identity, mv*t = r. # # Warning: Suppress the output from this function. # local Sols, S0, S1, S2, T0, T2, newm, m, e; # # S0 - moves length <= j # Moves found on previous iterations # S1 - moves length = j # Moves which could yield further moves # S2 - moves length > j # Moves found on current iteration # T0 - moves in S0 which return the blank disc to vertex N # T2 - moves in S2 which return the blank disc to vertex N # m - loop counter for a move in S1 # e - loop counter for an edge of Graph # Sols := [[(),N]]; # The second entry is the number of vertices. # This allows one less parameter to be used in the Solve function. S0 := [()]; S1 := [()]; S2 := []; T0 := [()]; T2 := []; repeat # until no further moves could be found for m in S1 do for e in Graph do # The position of the blank disk in move m is # N^m. The blank disc can be moved along # edge e when N^m is on e. if not (N^m)^e = N^m then # The result of moving the blank disc along e # is the move m*e. newm := m*e; # We must check whether or not # this move has already been found. if not newm in S0 then if not newm in S2 then AddSet(S2, newm); AddSet(Sols, [newm, e]); fi; fi; fi; od; od; # Compute any new moves which return the blank disc to vertex N. T2 := Filtered(S2, x -> N^x = N); # Update for next loop. S0 := Union(S0,S2); T0 := Union(T0,T2); S1 := S2; S2 := []; until Size(S1) = 0; return Sols; end; MinimalMoves := function(Graph, N, Length) # Purpose: Determine all sequences of legal moves of # length Length on a sliding block puzzle. # Input: Graph - list of (ordered pairs) edges of the graph. # The pairs will be used as transpositions. # The graph has N vertices. # N - number of vertices. Originally movable discs # are on vertices numbered 1 through N-1. # Length - maximum length of a move to be found. # # Output: Size(T0) - number of moves of length Length or # less which return the blank disc to # vertex N. # local S0, S1, S2, T0, T2, newm, j, m, e; # # S0 - moves length <= j - 1 # S1 - moves length = j - 1 # S2 - moves length = j # T0 - moves in S0 which return the blank disc to vertex N # T2 - moves in S2 which return the blank disc to vertex N # j - loop counter for length of move # m - loop counter for a move in S1 # e - loop counter for an edge of Graph # S0 := [()]; S1 := [()]; S2 := []; T0 := [()]; T2 := []; for j in [1..Length] do for m in S1 do for e in Graph do # The position of the blank disk in move m is # N^m. The blank disc can be moved along # edge e when N^m is on e. if not (N^m)^e = N^m then # The result of moving the blank disc along e # is the move m*e. newm := m*e; # check whether this move was previously found if not newm in S0 then if not newm in S2 then AddSet(S2, newm); fi; fi; fi; od; od; # Compute new moves which return the blank disc to vertex N. T2 := Filtered(S2, x -> N^x = N); # Update for next loop. S0 := Union(S0,S2); T0 := Union(T0,T2); S1 := S2; S2 := []; od; return T2; end; Solve := function(Solns, Move) # Purpose : To find the minimal solution to Move, a move on a # sliding block puzzle on N vertices. # Input: Solns - List of ordered pairs [mv, t] where mv is a # move, t is a simple move, and mv*t^-1 is a # move of minimal length with one pair being # [(), N] # Move - move to be solved, given as a permutation # Output: soln - a list giving the path of minimal length # which gives move m local N, mv, pr, soln, rev; # At the start of the while not loop # m results by either doing mv and then going along path given by # soln or by doing move mv*pr[1]^-1 and then going along # the path given by [pr(1)] + soln mv := Move; N := First(Solns, x -> x[1] = ())[2]; pr := First(Solns, x -> x[1] = mv); if pr = fail then Print("No solution exists \n"); fi; soln := [N^mv]; while not pr[2] = N do mv := pr[1]*pr[2]; # pr[2]^-1 = pr[2] rev := Reversed(soln); # placing (n+1)^m at the beginning Add(rev, N^mv); # of soln soln := Reversed(rev); pr := First(Solns, x -> x[1] = mv); od; return soln; end;