t4/zbiciak

Download the raw code.

#!/usr/local/bin/perl6

## ======================================================================== ##
##  Hex Puzzle solver
## 
##  This code uses a variant of A-star search to try to find a reasonable 
##  and efficient set of moves to solve the puzzle.  For speed purposes,
##  I rely on a set of precomputed tables to make it easy to determine
##  piece collisions and movement possibilities.
## ======================================================================== ##



## ------------------------------------------------------------------------ ##
##  Resource Tracking Bitmaps
##
##  Represent all piece positions as 38-bit bitmaps.  Two pieces coexist
##  if the bit-wise and between their bitmaps is 0.
##
##  Bit position assignments are in left-to-right order from the original
##  hexagon graph, starting with i1 in bit 37 and ending with o5 in bit 0.
## ------------------------------------------------------------------------ ##
my %piece_bmp = 
(
    #         iiiii jjjjjj kkkkk llllll mmmmm nnnnnn ooooo
    #         12345 123456 12345 123456 12345 123456 12345
    i12  => 0b11000_000000_00000_000000_00000_000000_00000,
    i23  => 0b01100_000000_00000_000000_00000_000000_00000,
    i34  => 0b00110_000000_00000_000000_00000_000000_00000,
    i45  => 0b00011_000000_00000_000000_00000_000000_00000,
    i123 => 0b11100_000000_00000_000000_00000_000000_00000,
    i234 => 0b01110_000000_00000_000000_00000_000000_00000,
    i345 => 0b00111_000000_00000_000000_00000_000000_00000,

    j12  => 0b00000_110000_00000_000000_00000_000000_00000,
    j23  => 0b00000_011000_00000_000000_00000_000000_00000,
    j34  => 0b00000_001100_00000_000000_00000_000000_00000,
    j45  => 0b00000_000110_00000_000000_00000_000000_00000,
    j56  => 0b00000_000011_00000_000000_00000_000000_00000,
    j123 => 0b00000_111000_00000_000000_00000_000000_00000,
    j234 => 0b00000_011100_00000_000000_00000_000000_00000,
    j345 => 0b00000_001110_00000_000000_00000_000000_00000,
    j456 => 0b00000_000111_00000_000000_00000_000000_00000,

    k12  => 0b00000_000000_11000_000000_00000_000000_00000,
    k23  => 0b00000_000000_01100_000000_00000_000000_00000,
    k34  => 0b00000_000000_00110_000000_00000_000000_00000,
    k45  => 0b00000_000000_00011_000000_00000_000000_00000,
    k123 => 0b00000_000000_11100_000000_00000_000000_00000,
    k234 => 0b00000_000000_01110_000000_00000_000000_00000,
    k345 => 0b00000_000000_00111_000000_00000_000000_00000,

    l12  => 0b00000_000000_00000_110000_00000_000000_00000,
    l23  => 0b00000_000000_00000_011000_00000_000000_00000,
    l34  => 0b00000_000000_00000_001100_00000_000000_00000,
    l45  => 0b00000_000000_00000_000110_00000_000000_00000,
    l56  => 0b00000_000000_00000_000011_00000_000000_00000,
    l123 => 0b00000_000000_00000_111000_00000_000000_00000,
    l234 => 0b00000_000000_00000_011100_00000_000000_00000,
    l345 => 0b00000_000000_00000_001110_00000_000000_00000,
    l456 => 0b00000_000000_00000_000111_00000_000000_00000,

    m12  => 0b00000_000000_00000_000000_11000_000000_00000,
    m23  => 0b00000_000000_00000_000000_01100_000000_00000,
    m34  => 0b00000_000000_00000_000000_00110_000000_00000,
    m45  => 0b00000_000000_00000_000000_00011_000000_00000,
    m123 => 0b00000_000000_00000_000000_11100_000000_00000,
    m234 => 0b00000_000000_00000_000000_01110_000000_00000,
    m345 => 0b00000_000000_00000_000000_00111_000000_00000,

    n12  => 0b00000_000000_00000_000000_00000_110000_00000,
    n23  => 0b00000_000000_00000_000000_00000_011000_00000,
    n34  => 0b00000_000000_00000_000000_00000_001100_00000,
    n45  => 0b00000_000000_00000_000000_00000_000110_00000,
    n56  => 0b00000_000000_00000_000000_00000_000011_00000,
    n123 => 0b00000_000000_00000_000000_00000_111000_00000,
    n234 => 0b00000_000000_00000_000000_00000_011100_00000,
    n345 => 0b00000_000000_00000_000000_00000_001110_00000,
    n456 => 0b00000_000000_00000_000000_00000_000111_00000,

    o12  => 0b00000_000000_00000_000000_00000_000000_11000,
    o23  => 0b00000_000000_00000_000000_00000_000000_01100,
    o34  => 0b00000_000000_00000_000000_00000_000000_00110,
    o45  => 0b00000_000000_00000_000000_00000_000000_00011,
    o123 => 0b00000_000000_00000_000000_00000_000000_11100,
    o234 => 0b00000_000000_00000_000000_00000_000000_01110,
    o345 => 0b00000_000000_00000_000000_00000_000000_00111,

    #         edcba fedcba fedcb gfedcb gfedc hgfedc hgfed
    #         11111 122222 23333 134444 24555 135666 24677
    a12  => 0b00001_000001_00000_000000_00000_000000_00000,

    #            1      2      3      4 
    b12  => 0b00010_000010_00000_000000_00000_000000_00000,
    b23  => 0b00000_000010_00001_000000_00000_000000_00000,
    b34  => 0b00000_000000_00001_000001_00000_000000_00000,

    b123 => 0b00010_000010_00001_000000_00000_000000_00000,
    b234 => 0b00000_000010_00001_000001_00000_000000_00000,

    #           1      2      3      4      5      6
    c12  => 0b00100_000100_00000_000000_00000_000000_00000,
    c23  => 0b00000_000100_00010_000000_00000_000000_00000,
    c34  => 0b00000_000000_00010_000010_00000_000000_00000,
    c45  => 0b00000_000000_00000_000010_00001_000000_00000,
    c56  => 0b00000_000000_00000_000000_00001_000001_00000,

    c123 => 0b00100_000100_00010_000000_00000_000000_00000,
    c234 => 0b00000_000100_00010_000010_00000_000000_00000,
    c345 => 0b00000_000000_00010_000010_00001_000000_00000,
    c456 => 0b00000_000000_00000_000010_00001_000001_00000,

    #          1      2      3      4      5      6      7
    d12  => 0b01000_001000_00000_000000_00000_000000_00000,
    d23  => 0b00000_001000_00100_000000_00000_000000_00000,
    d34  => 0b00000_000000_00100_000100_00000_000000_00000,
    d45  => 0b00000_000000_00000_000100_00010_000000_00000,
    d56  => 0b00000_000000_00000_000000_00010_000010_00000,
    d67  => 0b00000_000000_00000_000000_00000_000010_00001,

    d123 => 0b01000_001000_00100_000000_00000_000000_00000,
    d234 => 0b00000_001000_00100_000100_00000_000000_00000,
    d345 => 0b00000_000000_00100_000100_00010_000000_00000,
    d456 => 0b00000_000000_00000_000100_00010_000010_00000,
    d567 => 0b00000_000000_00000_000000_00010_000010_00001,

    #         1      2      3      4      5      6      7 
    e12  => 0b10000_010000_00000_000000_00000_000000_00000,
    e23  => 0b00000_010000_01000_000000_00000_000000_00000,
    e34  => 0b00000_000000_01000_001000_00000_000000_00000,
    e45  => 0b00000_000000_00000_001000_00100_000000_00000,
    e56  => 0b00000_000000_00000_000000_00100_000100_00000,
    e67  => 0b00000_000000_00000_000000_00000_000100_00010,

    e123 => 0b10000_010000_01000_000000_00000_000000_00000,
    e234 => 0b00000_010000_01000_001000_00000_000000_00000,
    e345 => 0b00000_000000_01000_001000_00100_000000_00000,
    e456 => 0b00000_000000_00000_001000_00100_000100_00000,
    e567 => 0b00000_000000_00000_000000_00100_000100_00010,

    #               1      2      3      4      5      6      
    f12  => 0b00000_100000_10000_000000_00000_000000_00000,
    f23  => 0b00000_000000_10000_010000_00000_000000_00000,
    f34  => 0b00000_000000_00000_010000_01000_000000_00000,
    f45  => 0b00000_000000_00000_000000_01000_001000_00000,
    f56  => 0b00000_000000_00000_000000_00000_001000_00100,

    f123 => 0b00000_100000_10000_010000_00000_000000_00000,
    f234 => 0b00000_000000_10000_010000_01000_000000_00000,
    f345 => 0b00000_000000_00000_010000_01000_001000_00000,
    f456 => 0b00000_000000_00000_000000_01000_001000_00100,

    #                            1      2      3      4      
    g12  => 0b00000_000000_00000_100000_10000_000000_00000,
    g23  => 0b00000_000000_00000_000000_10000_010000_00000,
    g34  => 0b00000_000000_00000_000000_00000_010000_01000,

    g123 => 0b00000_000000_00000_100000_10000_010000_00000,
    g234 => 0b00000_000000_00000_000000_10000_010000_01000,

    #                                         1      2
    h34  => 0b00000_000000_00000_000000_00000_100000_10000,

    #         pqrst pqrstu qrstu qrstuv rstuv rstuvw stuvw
    #         24677 135666 24555 134444 23333 122222 11111
    p12  => 0b10000_100000_00000_000000_00000_000000_00000,

    #          4     3     2     1                         
    q12  => 0b00000_000000_10000_100000_00000_000000_00000,
    q23  => 0b00000_010000_10000_000000_00000_000000_00000,
    q34  => 0b01000_010000_00000_000000_00000_000000_00000,

    q123 => 0b00000_010000_10000_100000_00000_000000_00000,
    q234 => 0b01000_010000_10000_000000_00000_000000_00000,

    #           6     5     4     3     2     1             
    r12  => 0b00000_000000_00000_000000_10000_100000_00000,
    r23  => 0b00000_000000_00000_010000_10000_000000_00000,
    r34  => 0b00000_000000_01000_010000_00000_000000_00000,
    r45  => 0b00000_001000_01000_000000_00000_000000_00000,
    r56  => 0b00100_001000_00000_000000_00000_000000_00000,

    r123 => 0b00000_000000_00000_010000_10000_100000_00000,
    r234 => 0b00000_000000_01000_010000_10000_000000_00000,
    r345 => 0b00000_001000_01000_010000_00000_000000_00000,
    r456 => 0b00100_001000_01000_000000_00000_000000_00000,

    #            7     6     5     4     3     2     1     
    s12  => 0b00000_000000_00000_000000_00000_010000_10000,
    s23  => 0b00000_000000_00000_000000_01000_010000_00000,
    s34  => 0b00000_000000_00000_001000_01000_000000_00000,
    s45  => 0b00000_000000_00100_001000_00000_000000_00000,
    s56  => 0b00000_000100_00100_000000_00000_000000_00000,
    s67  => 0b00010_000100_00000_000000_00000_000000_00000,

    s123 => 0b00000_000000_00000_000000_01000_010000_10000,
    s234 => 0b00000_000000_00000_001000_01000_010000_00000,
    s345 => 0b00000_000000_00100_001000_01000_000000_00000,
    s456 => 0b00000_000100_00100_001000_00000_000000_00000,
    s567 => 0b00010_000100_00100_000000_00000_000000_00000,

    #             7     6     5     4     3     2     1     
    t12  => 0b00000_000000_00000_000000_00000_001000_01000,
    t23  => 0b00000_000000_00000_000000_00100_001000_00000,
    t34  => 0b00000_000000_00000_000100_00100_000000_00000,
    t45  => 0b00000_000000_00010_000100_00000_000000_00000,
    t56  => 0b00000_000010_00010_000000_00000_000000_00000,
    t67  => 0b00001_000010_00000_000000_00000_000000_00000,

    t123 => 0b00000_000000_00000_000000_00100_001000_01000,
    t234 => 0b00000_000000_00000_000100_00100_001000_00000,
    t345 => 0b00000_000000_00010_000100_00100_000000_00000,
    t456 => 0b00000_000010_00010_000100_00000_000000_00000,
    t567 => 0b00001_000010_00010_000000_00000_000000_00000,

    #                    6     5     4     3     2     1     
    u12  => 0b00000_000000_00000_000000_00000_000100_00100,
    u23  => 0b00000_000000_00000_000000_00010_000100_00000,
    u34  => 0b00000_000000_00000_000010_00010_000000_00000,
    u45  => 0b00000_000000_00001_000010_00000_000000_00000,
    u56  => 0b00000_000001_00001_000000_00000_000000_00000,

    u123 => 0b00000_000000_00000_000000_00010_000100_00100,
    u234 => 0b00000_000000_00000_000010_00010_000100_00000,
    u345 => 0b00000_000000_00001_000010_00010_000000_00000,
    u456 => 0b00000_000001_00001_000010_00000_000000_00000,

    #                                 4     3     2     1     
    v12  => 0b00000_000000_00000_000000_00000_000010_00010,
    v23  => 0b00000_000000_00000_000000_00001_000010_00000,
    v34  => 0b00000_000000_00000_000001_00001_000000_00000,

    v123 => 0b00000_000000_00000_000000_00001_000010_00010,
    v234 => 0b00000_000000_00000_000001_00001_000010_00000,

    #                                              2     1     
    w12  => 0b00000_000000_00000_000000_00000_000001_00001,
);

## ------------------------------------------------------------------------ ##
##  Movement Connectivity
##
##  %succ moves a piece toward the next higher index in its groove.
##  %pred moves a piece toward the next lower index.
##
##  A move in a particular direction is allowed if and only if 
##  .contains($curr) == True for that direction.
## ------------------------------------------------------------------------ ##
my %succ = 
(
    i12 => 'i23', i23 => 'i34', i34 => 'i45', 
    j12 => 'j23', j23 => 'j34', j34 => 'j45', j45 => 'j56',
    k12 => 'k23', k23 => 'k34', k34 => 'k45', 
    l12 => 'l23', l23 => 'l34', l34 => 'l45', l45 => 'l56',
    m12 => 'm23', m23 => 'm34', m34 => 'm45',
    n12 => 'n23', n23 => 'n34', n34 => 'n45', n45 => 'n56', 
    o12 => 'o23', o23 => 'o34', o34 => 'o45',

    i123 => 'i234', i234 => 'i345',
    j123 => 'j234', j234 => 'j345', j345 => 'j456', 
    k123 => 'k234', k234 => 'k345', 
    l123 => 'l234', l234 => 'l345', l345 => 'l456', 
    m123 => 'm234', m234 => 'm345', 
    n123 => 'n234', n234 => 'n345', n345 => 'n456',
    o123 => 'o234', o234 => 'o345', 

    b12 => 'b23', b23 => 'b34',
    c12 => 'c23', c23 => 'c34', c34 => 'c45', c45 => 'c56',
    d12 => 'd23', d23 => 'd34', d34 => 'd45', d45 => 'd56', d56 => 'd67',
    e12 => 'e23', e23 => 'e34', e34 => 'e45', e45 => 'e56', e56 => 'e67',
    f12 => 'f23', f23 => 'f34', f34 => 'f45', f45 => 'f56',
    g12 => 'g23', g23 => 'g34',

    b123 => 'b234',
    c123 => 'c234', c234 => 'c345', c345 => 'c456',
    d123 => 'd234', d234 => 'd345', d345 => 'd456', d456 => 'd567',
    e123 => 'e234', e234 => 'e345', e345 => 'e456', e456 => 'e567',
    f123 => 'f234', f234 => 'f345', f345 => 'f456',
    g123 => 'g234',

    q12 => 'q23', q23 => 'q34',
    r12 => 'r23', r23 => 'r34', r34 => 'r45', r45 => 'r56',
    s12 => 's23', s23 => 's34', s34 => 's45', s45 => 's56', r56 => 'r67',
    t12 => 't23', t23 => 't34', t34 => 't45', t45 => 't56', s56 => 's67',
    u12 => 'u23', u23 => 'u34', u34 => 'u45', u45 => 'u56',
    v12 => 'v23', v23 => 'v34',

    q123 => 'q234',
    r123 => 'r234', r234 => 'r345', r345 => 'r456',
    s123 => 's234', s234 => 's345', s345 => 's456', s456 => 's567',
    t123 => 't234', t234 => 't345', t345 => 't456', t456 => 't567',
    u123 => 'u234', u234 => 'u345', u345 => 'u456',
    v123 => 'v234',
);

my %pred = %succ.invert;


## ------------------------------------------------------------------------ ##
##  Helper function:  Render a from/to as a move in desired output format
## ------------------------------------------------------------------------ ##
sub render_move(Str $from, Str $to)
{
    return $from.substr(0, 1) 
            ~ "[" ~ $from.substr(1) ~ " -> " ~ $to.substr(1) ~ "]";
}

## ------------------------------------------------------------------------ ##
##  A-star Search
##
##  Note that this implementation goes light on the abstraction.  That can
##  always be added later when it's time to reuse the code.
##
##  The class a-star-node encapsulates a single state node from the 
##  state tree search.  The class a-star encapsulates knowledge of visited
##  states and handles iterating the actual a-star search.
## ------------------------------------------------------------------------ ##

class a-star-node
{
    has Int  $!cost;
    has Str  $!move;
    has Int  $!in_use;
    has      @!pieces;
    has Bool $!bullet;
    has Str  $!parent;
    has Int  $!est_cost;

    method Str() {
        return @!pieces.join();
    }

    method is_goal() {
        return @!pieces[0] eq 'l56';
    }

    method add_piece(Str $piece) {
        # This is used only when populating start nodes from the input
        say "Invalid piece name." and exit(1) 
                                            if !%piece_bmp.contains($piece);

        my $new_bmp = %piece_bmp{$piece};

        say "Overlapping pieces." and exit(1) if $!in_use +& $new_bmp;

        $!in_use +|= $new_bmp;

        if ($piece eq 'l12') {
            $!bullet = True;
            unshift @!pieces, $piece;
        } else {
            say "No solution." and exit(1) if $piece.substr(0,1) eq 'l';
            push @!pieces, $piece;
        }
    }

    method has_bullet {
        # This is used only when populating start nodes from the input
        return $!bullet;
    }

    method get_moves {
        my (Int $piece, Int $cost, Str $orig, Str $curr, Int $others, 
            Int $p, $next, @moves);

        ## Try to move each piece as far backward as possible,
        ## then try to move each piece as far forward as possible.  
        ##
        ## Cost of the move is 3 + # of segments.
        ##
        ## Insert the options into the result buffer in reverse
        ## order, so the first move we consider is the one that
        ## moves the bullet the furthest right.

        for $(%pred), $(%succ) -> $next { 
            for @!pieces.elems-1 ... 0 -> $p {
                my @p_copy = @!pieces;
                $curr = $orig = @!pieces[$p];
                $cost = $!cost + 1;

                $others = $!in_use +^ %piece_bmp{$orig};

                while ( $next.contains($curr) ) {
                    $curr = $next{$curr};
                    $cost++;

                    if ($others +& %piece_bmp{$curr}) == 0 {
                        @p_copy[$p] = $curr;

                        @moves.unshift(
                            a-star-node.new(
                                cost   => $cost,
                                move   => render_move($orig, $curr),
                                in_use => $others +| %piece_bmp{$curr},
                                pieces => @p_copy,
                                bullet => $!bullet,
                                parent => self.Str
                            )
                        )
                    } else {
                        last;
                    }
                }
            }
        }

        return @moves;
    }

    method get_parent { return $!parent; }
    method get_move   { return $!move; }

    method tot_cost_to_here {
        # Actual cost incurred getting to this node.
        return $!cost;
    }

    method est_cost_to_goal {
        return $!est_cost if $!est_cost > 0;

        # Estimated cost to get from this node to the goal state.
        #
        # Our heuristic:  
        #  -- Number of slots the bullet needs to slide, plus
        #  -- Number of other piece segments overlapping l1 .. l6 to
        #     the right of the bullet, plus
        #  -- 1, to cover the minimum cost of any move.
        #
        # Because we start calculating "overlapping piece segments"
        # on the right-edge of the "bullet", we don't need to add 1
        # explicitly.

        my Int $bull_pos = @!pieces[0].substr(1,1).Int;
        my Int $in_way   = 0;
        my Int $bit_num;

        for (21 - $bull_pos) ... 16 -> $bit_num {
            $in_way += ($!in_use +> $bit_num) +& 1;
        }

        return $!est_cost = ( 5 - $bull_pos ) + $in_way;
    }

    submethod BUILD
    (
        :$!cost   = 0,
        :$!move   = '',
        :$!in_use = 0,
        :@!pieces = ( ),
        :$!bullet = False,
        :$!parent = 'START',
        :$!est_cost = -1
    ) {
    }
};


class a-star
{
    has %!visited; 
    has @!frontier;

    method !visit(a-star-node $state) {
        my Str  $str = $state.Str;
        my Bool $was_visited = %!visited.contains($str);

        %!visited{$str} = $state
            if (!$was_visited || 
                $state.tot_cost_to_here < %!visited{$str}.tot_cost_to_here);

        return $was_visited;
    }

    method !best_path(a-star-node $end) {
        my @moves;
        my $state = $end.Str;

        while (%!visited.contains($state)) {
            @moves.unshift( %!visited{$state}.get_move );
            $state = %!visited{$state}.get_parent;
        }

        shift @moves;   ## remove extra move from last iter

        return @moves;
    }

    method !pick() {
        my Int $best_idx  = 0;
        my Int $best_cost = 99999999;

        for 0 ..^ @!frontier.elems {
            my $tot_est_cost = @!frontier[$_].tot_cost_to_here +
                               @!frontier[$_].est_cost_to_goal;

            if  $best_cost > $tot_est_cost {
                $best_cost = $tot_est_cost;
                $best_idx  = $_;
            }
        }

        my $pick = @!frontier[$best_idx];

        @!frontier.splice( $best_idx, 1 );
        return $pick;
    }

    method search {
        my (a-star-node $node, a-star-node $exit);
        my (@exits, $curr);

        while (@!frontier.elems > 0) {

            $node = self!pick;
            $curr = $node.Str;

            if $node.is_goal {
                return self!best_path($node);
            }

            @exits = $node.get_moves;

            for @exits -> $exit {
                my $was_visited = self!visit($exit);

                if !$was_visited {
                    push @!frontier, $exit;
                }
            }
        }

        return @( );
    }

    submethod BUILD(:$start) {
        push @!frontier, $start;
        self!visit($start);
    }
};




## ======================================================================== ##
##  MAIN PROGRAM
## ======================================================================== ##

sub MAIN
{
    my $start = a-star-node.new;

    for lines() {
        $start.add_piece( $_ );
    }

    say "No bullet specified" and exit(1) if !$start.has_bullet;

    my $a-star = a-star.new(start => $start);
    my @path   = $a-star.search;

    if @path.elems {
        say @path.join("\n");
    } else {
        say "No solution.";
    }
}

Correctness

The program does an A star search. It seems to work as intended.

Consistency

The program is nicely formatted, indented with spaces, and with pleasant interspersed comments where necessary.

Clarity of intent

The program is clearly structured, with lookup tables, class definitions, and a MAIN routine.

The method name !pick is a teensy bit unfortunate, considering that it means 'take a random item' in the rest of Perl 6.

Algorithmic efficiency

This program is impressively fast.

Idiomatic use of Perl 6

The whole program has a quality of balance and purpose to it.

Nice use of .invert.

One doesn't need to close one's class definitions with };. (C programmer interference?)

The empty BUILD submethod in a-star-node could have been removed, and the defaults just put on the attributes instead.

No need to put parens around the condition of a while loop.

Brevity

The program sacrifices brevity on the altar of performance tweaks.