solutions to masak/workshop

FRINGE.pl

# this solves the FRINGE problem, to lazily compare the
# fringes (left-to-right traversals of the leaves) of
# two trees and aborts as early as a difference is found.

# highlights of this include:
#
# - use of my excellent ADT module ;)
# - returning a False value for "same-fringe", whose
#   .Str returns a detailed report
# - overriding the .storage method of a leaf in the
#   test code to verify that an early abort has
#   happened

use v6;
use ADT;

my $adt = q{Tree = Branch Tree left, Tree right | Leaf Str storage};
my %res = create_adt($adt);
my \Tree = %res<Tree>;
my \Branch = %res<Branch>;
my \Leaf = %res<Leaf>;

my $a = Tree.new-branch(
    Tree.new-leaf("a"), 
    Tree.new-branch(
        Tree.new-leaf("b"),
        Tree.new-leaf("c")));
my $b = Tree.new-branch(
    Tree.new-branch(
        Tree.new-leaf("a"),
        Tree.new-leaf("b")),
    Tree.new-leaf("c"));
my $c = Tree.new-branch(
    Tree.new-branch(
        Tree.new-leaf("a"),
        Tree.new-leaf("c")),
    Tree.new-leaf("b"));

sub fringe($t) {
    multi sub iter-tree($_) {
        when Branch {
            iter-tree($_.left);
            iter-tree($_.right);
        }
        when Leaf {
            take $_.storage
        }
    }
    gather iter-tree($t);
}

sub same-fringe($a, $b) {
    my $pos = 1;
    for fringe($a) Z fringe($b) -> $fa, $fb {
        return False but "difference at $pos: $fa !eq $fb" if $fa ne $fb;
        $pos++;
    }
    return True;
}

use Test;

plan 7;

ok same-fringe($a, $b);
ok !same-fringe($a, $c);
is ~same-fringe($a, $c), "difference at 2: b !eq c";

{
    my $*fail = False;

    my $d = Tree.new-branch(
        Tree.new-branch(
            Tree.new-leaf("x"),
            Tree.new-leaf("c")),
        Tree.new-leaf("a") but role { method storage { $*fail = True; "a" } });

    is $d.right.storage, "a", "storage of mocked Leaf works";
    is $*fail, True, "storage of mocked Leaf sets failure";
    $*fail = False;

    ok ~same-fringe($a, $d) ~~ /'at 1'/;
    ok !$*fail, "lazyness of fringe.";
}

GRAPH.pl

# this is my solution to GRAPH.
# it offers an interactive mode and some test cases

use v6;

class Graph {
    has @!nodes;
    has %!neighbour;

    method !connect($a, $b) {
        push %!neighbour{$a}, $b;
        push %!neighbour{$b}, $a;
    }
    method neighbours($node) {
        %!neighbour{$node};
    }
    method are-adjacent($a, $b) {
        any(%!neighbour{$a}.list) eq $b;
    }
    method new(:@nodes!, :@edges!) {
        self.bless(*, :@nodes, :@edges);
    }
    submethod BUILD(:@nodes, :@edges) {
        @!nodes = @nodes[];
        die "duplicate nodes" if +@!nodes != +set(@!nodes);
        for @edges -> $k, $v {
            self!connect($k, $v);
        }
    }
}

sub find-path(Graph \g, $start, $end) {
    # the parent of a node is the node that's closer to the start.
    my %parent;
    # the nodes we have discovered so far, starting at $start.
    my @nodes;
    # all the nodes that have had all their neighbours inspected
    # are visited.
    my KeySet $visited .= new;

    $visited{$start} = True;

    @nodes.push: $start;

    loop {
        my $cursor = @nodes.shift;

        for @(g.neighbours($cursor)) -> $neighbour {
            # if we see this node for the first time,
            if !$visited{$neighbour} {
                # mark our cursor as its parent
                %parent{$neighbour} = $cursor;

                # and we are also interested in its neighbours now.
                # (but add it to the end of the queue)
                @nodes.push($neighbour);
            }
        }
        $visited{$cursor} = True;

        # when we found a path to the end, the parent of
        # $end will have been set.
        if %parent{$end} :exists {
            return ($end, { %parent{$_} } ... $start).reverse;
        }

        # if we run out of interesting nodes, we won't find
        # a path to the end.
        if +@nodes == 0 {
            die "no path found from $start to $end";
        }
    }
}

sub run(:@nodes, :@edges, :$start = @nodes[0], :$end = @nodes[*-1]) {
    my $g = Graph.new(
        nodes => @nodes, edges => @edges
    );
    my @path = find-path($g, $start, $end);
    say "I found a path: @path[]";
}

multi sub MAIN() {
    say q:to/WELCOME/;
        Hey, welcome to my neat GRAPH pathfinder.

        run it with "test" to run some sanity checks or with
        "interact" to enter a graph manually.
        WELCOME

    run(
        :nodes( <A B C D E F G H> ),
        :edges( <A B   B C   A D   D E   E G   B F   C H   G H> )
    );
}

multi sub MAIN("interact") {
    say q:to/INTRO/; 
        Enter as many nodes as you wish in one line to make a connection
        End with an empty line.
        The program will then find a route from the alphabetically
        earliest to the alphabetically last node.
        INTRO

    my @edges;

    loop {
        my @edge = (prompt("edges> ") // "").comb(/<ident>/);
        for @edge -> $node {
            @edges.push(state $prev, $node) if $prev.defined;
            $prev = $node;
        }
        last unless @edge;
    }
    my @nodes = set(@edges).list.sort;
    die "no nodes supplied." unless +@nodes;
    run(
        :@nodes,
        :@edges
    );
}

multi sub MAIN("test") {
    use Test;

    {
        my $g = Graph.new(
            :nodes( <A B C D E F G H I> ),
            :edges( (<A B   B C   A D   D E   E G   B F   C H   G H>) )
        );
        ok $g.are-adjacent("A", "B");
        ok $g.are-adjacent("B", "A");
        ok not $g.are-adjacent("A", "C");
        ok not $g.are-adjacent("C", "A");

        is set($g.neighbours("A")), set(<B D>);
        is set($g.neighbours("B")), set(<A C F>);

        ok find-path($g, "A", "H");
    }
    done;
}

JAPH.pl

# this is my solution to JAPH
# it makes a fancy blinky animation!

use v6;

my @phrase = "Just Another Perl Hacker".comb;

my @visible = False xx +@phrase;

loop {
    @visible = do for @visible.kv -> $k, $v {
        $v ?? (False, True xx 14).pick !! (True, False xx 3).pick;
    }
    print "\r", (for @phrase.keys { @visible[$_] ?? @phrase[$_] !! " " }).join("");

    last if all(@visible);
}
say "";