# 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;