crypt

#! /usr/local/bin/nom

use Test;

role Event {
    method Str {
        sub event() { self.^name }
        sub name($attr) { $attr.name.substr(2) }
        sub value($attr) { $attr.get_value(self) }

        "{event}[{map { ":{name $_}<{value $_}>" }, self.^attributes}]"
    }
}

class Hanoi::DiskMoved does Event {
    has $.disk;
    has $.source;
    has $.target;
}

class Hanoi::AchievementUnlocked does Event {
}

class Hanoi::AchievementLocked does Event {
}

class Hanoi::DiskRemoved does Event {
    has $.disk;
    has $.source;
}

class Hanoi::DiskAdded does Event {
    has $.disk;
    has $.target;
}

class X::Hanoi is Exception {
}

class X::Hanoi::LargerOnSmaller is X::Hanoi {
    has $.larger;
    has $.smaller;

    method message {
        "Cannot put the $.larger on the $.smaller"
    }
}

class X::Hanoi::NoSuchRod is X::Hanoi {
    has $.rod;
    has $.name;

    method message {
        "No such $.rod rod '$.name'"
    }
}

class X::Hanoi::RodHasNoDisks is X::Hanoi {
    has $.name;

    method message {
        "Cannot move from the $.name rod because there is no disk there"
    }
}

class X::Hanoi::CoveredDisk is X::Hanoi {
    has $.disk;
    has @.covered_by;

    method message {
        sub last_and(@things) {
            map { "{'and ' if $_ == @things.end}@things[$_]" }, ^@things
        }
        my $disklist = @.covered_by > 1
            ?? join ', ', last_and map { "the $_" }, @.covered_by
            !! "the @.covered_by[0]";
        "Cannot move the $.disk: it is covered by $disklist"
    }
}

class X::Hanoi::ForbiddenDiskRemoval is X::Hanoi {
    has $.disk;

    method message {
        "Removing the $.disk is forbidden"
    }
}

class X::Hanoi::DiskHasBeenRemoved is X::Hanoi {
    has $.disk;
    has $.action;

    method message {
        "Cannot $.action the $.disk because it has been removed"
    }
}

class X::Hanoi::NoSuchDisk is X::Hanoi {
    has $.disk;
    has $.action;

    method message {
        "Cannot $.action a $.disk because there is no such disk"
    }
}

class X::Hanoi::DiskAlreadyOnARod is X::Hanoi {
    has $.disk;

    method message {
        "Cannot add the $.disk because it is already on a rod"
    }
}

class Hanoi::Game {
    my @disks = <tiny small medium large huge> X~ ' disk';
    my %size_of = @disks Z 1..5;

    has %!state =
        left   => [reverse @disks],
        middle => [],
        right  => [],
    ;

    has $!achievement = 'locked';

    method move($source is copy, $target) {
        if $source eq any @disks {
            $source = self!rod_with_disk($source, 'move');
        }
        die X::Hanoi::NoSuchRod.new(:rod<source>, :name($source))
            unless %!state.exists($source);
        die X::Hanoi::NoSuchRod.new(:rod<target>, :name($target))
            unless %!state.exists($target);
        my @source_rod := %!state{$source};
        die X::Hanoi::RodHasNoDisks.new(:name($source))
            unless @source_rod;
        my @target_rod := %!state{$target};
        my $moved_disk = @source_rod[*-1];
        if @target_rod {
            my $covered_disk = @target_rod[*-1];
            if %size_of{$moved_disk} > %size_of{$covered_disk} {
                die X::Hanoi::LargerOnSmaller.new(
                    :larger($moved_disk),
                    :smaller($covered_disk)
                );
            }
        }
        my @events
            = Hanoi::DiskMoved.new(:disk($moved_disk), :$source, :$target);
        if %!state<right> == @disks-1
           && $target eq 'right'
           && $!achievement eq 'locked' {
            @events.push(Hanoi::AchievementUnlocked.new);
        }
        if $moved_disk eq 'small disk' && $!achievement eq 'unlocked' {
            @events.push(Hanoi::AchievementLocked.new);
        }
        self!apply($_) for @events;
        return @events;
    }

    method remove($disk) {
        die X::Hanoi::NoSuchDisk.new(:action<remove>, :$disk)
            unless $disk eq any(@disks);
        my $source = self!rod_with_disk($disk, 'remove');
        die X::Hanoi::ForbiddenDiskRemoval.new(:$disk)
            unless $disk eq 'tiny disk';
        my @events = Hanoi::DiskRemoved.new(:$disk, :$source);
        self!apply($_) for @events;
        return @events;
    }

    method add($disk, $target) {
        die X::Hanoi::NoSuchDisk.new(:action<add>, :$disk)
            unless $disk eq any(@disks);
        die X::Hanoi::NoSuchRod.new(:rod<target>, :name($target))
            unless %!state.exists($target);
        die X::Hanoi::DiskAlreadyOnARod.new(:$disk)
            if grep { $disk eq any(@$_) }, %!state.values;
        my @events = Hanoi::DiskAdded.new(:$disk, :$target);
        if %!state<right> == @disks-1
           && $target eq 'right'
           && $!achievement eq 'locked' {
            @events.push(Hanoi::AchievementUnlocked.new);
        }
        self!apply($_) for @events;
        return @events;
    }

    # The method will throw X::Hanoi::CoveredDisk if the disk is not topmost,
    # or X::Hanoi::DiskHasBeenRemoved if the disk isn't found on any rod.
    method !rod_with_disk($disk, $action) {
        for %!state -> (:key($rod), :value(@disks)) {
            if $disk eq any(@disks) {
                sub smaller_disks {
                    grep { %size_of{$_} < %size_of{$disk} }, @disks;
                }
                die X::Hanoi::CoveredDisk.new(:$disk, :covered_by(smaller_disks))
                    unless @disks[*-1] eq $disk;
                return $rod;
            }
        }
        die X::Hanoi::DiskHasBeenRemoved.new(:$disk, :$action);
    }

    # RAKUDO: private multimethods NYI
    method !apply(Event $_) {
        when Hanoi::DiskMoved {
            my @source_rod := %!state{.source};
            my @target_rod := %!state{.target};
            @target_rod.push( @source_rod.pop );
        }
        when Hanoi::AchievementUnlocked {
            $!achievement = 'unlocked';
        }
        when Hanoi::AchievementLocked {
            $!achievement = 'locked';
        }
        when Hanoi::DiskRemoved {
            my @source_rod := %!state{.source};
            @source_rod.pop;
        }
        when Hanoi::DiskAdded {
            my @target_rod := %!state{.target};
            @target_rod.push(.disk);
        }
    }
}

class Adventure::PlayerWalked does Event {
    has $.to;
}

class Adventure::PlayerWasPlaced does Event {
    has $.in;
}

class Adventure::PlayerLooked does Event {
    has $.room;
    has @.exits;
}

class Adventure::TwoRoomsConnected does Event {
    has @.rooms;
    has $.direction;
}

class Adventure::DirectionAliased does Event {
    has $.room;
    has $.direction;
    has $.alias;
}

class Adventure::PlayerExamined does Event {
    has $.thing;
}

class Adventure::ThingPlaced does Event {
    has $.thing;
    has $.room;
}

class Adventure::PlayerOpened does Event {
    has $.thing;
}

class X::Adventure is Exception {
}

class X::Adventure::NoSuchDirection is X::Adventure {
    has $.direction;

    method message {
        "Cannot connect rooms because direction '$.direction' does not exist"
    }
}

class X::Adventure::NoExitThere is X::Adventure {
    has $.direction;

    method message {
        "Cannot walk $.direction because there is no exit there"
    }
}

class X::Adventure::PlayerIsNowhere is X::Adventure {
    method message {
        "Cannot move because the player isn't anywhere"
    }
}

class X::Adventure::NoSuchThingHere is X::Adventure {
    has $.thing;

    method message {
        "You see no $.thing here"
    }
}

class Adventure::Engine {
    my @possible_directions = <
        north south east west
        northeast northwest southeast southwest
        up down
    >;

    has @!events;
    has $!player_location;
    has %!exits;
    has %!exit_aliases;
    has %!seen_room;
    has %!try_exit_hooks;
    has %!thing_rooms;

    method connect(@rooms, $direction) {
        die X::Adventure::NoSuchDirection.new(:action('connect rooms'), :$direction)
            unless $direction eq any(@possible_directions);

        my @events = Adventure::TwoRoomsConnected.new(:@rooms, :$direction);
        self!apply($_) for @events;
        @events;
    }

    method walk($direction) {
        die X::Adventure::PlayerIsNowhere.new()
            unless defined $!player_location;

        my $actual_direction =
            %!exit_aliases.exists($!player_location)
            && %!exit_aliases{$!player_location}.exists($direction)
                ?? %!exit_aliases{$!player_location}{$direction}
                !! $direction;

        my $to = %!exits{$!player_location}{$actual_direction};

        die X::Adventure::NoExitThere.new(:$direction)
            unless defined $to;

        if %!try_exit_hooks{$!player_location}{$actual_direction} -> &hook {
            return unless &hook();
        }

        my @events = Adventure::PlayerWalked.new(:$to);
        unless %!seen_room{$to}++ {
            @events.push(Adventure::PlayerLooked.new(
                :room($to),
                :exits(%!exits{$to}.keys),
            ));
        }
        self!apply($_) for @events;
        @events;
    }

    method look() {
        my @events = Adventure::PlayerLooked.new(
            :room($!player_location),
            :exits(%!exits{$!player_location}.keys),
        );
        self!apply($_) for @events;
        @events;
    }

    method place_player($in) {
        my @events = Adventure::PlayerWasPlaced.new(:$in);
        unless %!seen_room{$in}++ {
            @events.push(Adventure::PlayerLooked.new(
                :room($in),
                :exits(%!exits{$in}.keys),
            ));
        }
        self!apply($_) for @events;
        @events;
    }

    method alias_direction($room, $alias, $direction) {
        my @events = Adventure::DirectionAliased.new(
            :$room, :$alias, :$direction
        );
        self!apply($_) for @events;
        @events;
    }

    method place_thing($thing, $room) {
        my @events = Adventure::ThingPlaced.new(
            :$thing, :$room
        );
        self!apply($_) for @events;
        @events;
    }

    method examine($thing) {
        die X::Adventure::NoSuchThingHere.new(:$thing)
            unless (%!thing_rooms{$thing} // '') eq $!player_location;

        my @events = Adventure::PlayerExamined.new(
            :$thing
        );
        self!apply($_) for @events;
        @events;
    }

    method make_thing_openable($thing) {
    }

    method open($thing) {
        Adventure::PlayerOpened.new(:$thing);
    }

    method on_try_exit($room, $direction, &hook) {
        %!try_exit_hooks{$room}{$direction} = &hook;
    }

    my class Save {
        has @.events;
    }

    method save {
        return Save.new(:@!events);
    }

    method restore(Save $save) {
        my $new-engine = Adventure::Engine.new();
        $new-engine!apply($_) for $save.events.list;
        return $new-engine;
    }

    sub opposite($direction) {
        my %opposites =
            'north'     => 'south',
            'east'      => 'west',
            'northeast' => 'southwest',
            'northwest' => 'southeast',
            'up'        => 'down',
            'in'        => 'out',
        ;

        %opposites.push( %opposites.invert );

        %opposites{$direction};
    }

    # RAKUDO: private multimethods NYI
    method !apply(Event $_) {
        push @!events, $_;
        when Adventure::TwoRoomsConnected {
            my ($room1, $room2) = .rooms.list;
            my $direction = .direction;
            %!exits{$room1}{$direction} = $room2;
            %!exits{$room2}{opposite $direction} = $room1;
        }
        when Adventure::PlayerWalked {
            $!player_location = .to;
        }
        when Adventure::PlayerWasPlaced {
            $!player_location = .in;
        }
        when Adventure::DirectionAliased {
            %!exit_aliases{.room}{.alias} = .direction;
        }
        when Adventure::ThingPlaced {
            %!thing_rooms{.thing} = .room;
        }
    }
}

class X::Crypt is Exception {
}

class Crypt::Game {
    has $!engine handles <walk save>;

    submethod BUILD() {
        $!engine = Adventure::Engine.new();

        given $!engine {
            .connect(<clearing hill>, 'east');
            .alias_direction('hill', 'in', 'south');
            .alias_direction('chamber', 'out', 'north');
            .connect(<chamber hall>, 'south');
            .connect(<hall cave>, 'down');
            .connect(<cave crypt>, 'northwest');
            .on_try_exit('cave', 'northwest', {
                say "You try to walk past the fire, but it's too hot!";
                False;
            });
            .place_player('clearing');
        }
    }

    method look {
        return $!engine.look;
    }

    method restore($save) {
        $!engine .= restore($save);
        return;
    }
}

multi MAIN() {
    say "CRYPT";
    say "=====";
    say "";

    say "You've heard there's supposed to be an ancient hidden crypt in these";
    say "woods. One containing a priceless treasure. Well, there's only one way";
    say "to find out...";
    say "";

    my $game = Crypt::Game.new();
    my $save;
    my %descriptions;
    for slurp("game-data/descriptions").trim.split(/\n\n/) {
        /^^ '== ' (\N+) \n (.*)/
            or die "Could not parse 'descriptions' file: $_";
        %descriptions{$0} = ~$1;
    }

    sub params($method) {
        $method.signature.params
            ==> grep { .positional && !.invocant }
            ==> map { .name.substr(1) }
    }
    my %commands = map { $^m.name => params($m) }, $game.^methods;

    my @possible_directions = <
        north south east west
        northeast northwest southeast southwest
        up down in out
    >;

    given 'clearing' {
        say .ucfirst;
        say "";
        say %descriptions{$_};
        say "You can go east.";
        say "";
    }

    loop {
        my $command = prompt('> ');
        given $command {
            when !.defined || .lc eq "q" | "quit" {
                say "";
                last;
            }

            $command .= lc;
            $command .= trim;

            when /^help>>/|"h"|"?" {
                say "Here are some (made-up) examples of commands you can use:";
                say "";
                say "look";
                say "[walk] north/south/east/west";
            }

            when 'save' {
                $save = $game.save;
                say "Game saved.";
            }

            when 'restore' {
                when !defined $save {
                    say "No game has been saved yet.";
                }
                $game.restore($save);

                my @events = $game.look;
                for @events {
                    when Adventure::PlayerLooked {
                        say ucfirst .room;
                        say "";
                        say %descriptions{.room};
                        if .exits {
                            say "You can go {join ' and ', .exits}.";
                        }
                    }
                }
            }

            when any @possible_directions {
                $command = "walk $command";
                proceed;
            }

            my $verb = $command.words[0];
            my @args = $command.words[1..*];
            when %commands.exists($verb) {
                my @req_args = %commands{$verb}.list;
                when @args != @req_args {
                    say "You passed in {+@args} arguments, but $verb requires {+@req_args}.";
                    say "The arguments are {map { "<$_>" }, @req_args}.";
                }
                my @events = $game."$verb"(|@args);
                for @events {
                    when Adventure::PlayerWalked { say ucfirst .to; say "" }
                    when Adventure::PlayerLooked {
                        say %descriptions{.room};
                        if .exits {
                            say "You can go {join ' and ', .exits}.";
                        }
                    }
                }
                CATCH {
                    when X::Adventure { say .message, '.' }
                }
            }

            default {
                say "Sorry, I did not understand that.";
            }
        }
        say "";
    }
}

multi MAIN('hanoi') {
    my Hanoi::Game $game .= new;
    my @disks = <tiny small medium large huge> X~ ' disk';
    my @rods = <left middle right>;

    sub params($method) {
        $method.signature.params
            ==> grep { .positional && !.invocant }
            ==> map { .name.substr(1) }
    }
    my %commands = map { $^m.name => params($m) }, $game.^methods;
    my @all_events;

    sub print_board() {
        my %s =
            left   => [reverse @disks],
            middle => [],
            right  => [],
        ;
        for @all_events {
            when Hanoi::DiskMoved   { %s{.target}.push: %s{.source}.pop }
            when Hanoi::DiskRemoved { %s{.source}.pop }
            when Hanoi::DiskAdded   { %s{.target}.push: .disk }
        }

        say "";
        for reverse ^6 -> $line {
            my %disks =
                'none'        => '     |     ',
                'tiny disk'   => '     =     ',
                'small disk'  => '    ===    ',
                'medium disk' => '   =====   ',
                'large disk'  => '  =======  ',
                'huge disk'   => ' ========= ',
            ;

            sub disk($rod) {
                my $disk = %s{$rod}[$line] // 'none';
                %disks{ $disk };
            }

            say join '  ', map &disk, @rods;
        }
        say join '--', '-----------' xx @rods;
    }

    print_board();
    say "";
    loop {
        my $command = prompt('> ');
        unless defined $command {
            say "";
            last;
        }
        given lc $command {
            when 'q' | 'quit' { last }
            when 'h' | 'help' {
                say "Goal: get all the disks to the right rod.";
                say "You can never place a larger disk on a smaller one.";
                say "Available commands:";
                for %commands.sort {
                    say "  {.key} {map { "<$_>" }, .value.list}";
                }
                say "  q[uit]";
                say "  h[elp]";
                say "  s[how]";
                say "";
                say "Disks: ", join ', ', @disks;
                say "Rods: ", join ', ', @rods;
            }
            when 's' | 'show' { print_board() }

            sub munge   { $^s.subst(/' disk'»/, '_disk', :g) }
            sub unmunge { $^s.subst(/'_disk'»/, ' disk', :g) }
            my $verb = .&munge.words[0].&unmunge;
            my @args = .&munge.words[1..*]».&unmunge;
            when %commands.exists($verb) {
                my @req_args = %commands{$verb}.list;
                when @args != @req_args {
                    say "You passed in {+@args} arguments, but $verb requires {+@req_args}.";
                    say "The arguments are {map { "<$_>" }, @req_args}.";
                    say "'help' for more help.";
                }
                my @events = $game."$verb"(|@args);
                push @all_events, @events;
                print_board();
                for @events {
                    when Hanoi::AchievementUnlocked { say "Achievement unlocked!" }
                    when Hanoi::AchievementLocked { say "Achievement locked!" }
                }
                CATCH {
                    when X::Hanoi { say .message, '.' }
                }
            }

            default {
                say "Sorry, the game doesn't recognize that command. :/";
                say "'help' if you're confused as well.";
            }
        }
        say "";
    }
}

sub throws_exception(&code, $ex_type, $message, &followup = {;}) {
    &code();
    ok 0, $message;
    if &followup {
        diag 'Not running followup because an exception was not triggered';
    }
    CATCH {
        default {
            ok 1, $message;
            my $type_ok = $_.WHAT === $ex_type;
            ok $type_ok , "right exception type ({$ex_type.^name})";
            if $type_ok {
                &followup($_);
            } else {
                diag "Got:      {$_.WHAT.gist}\n"
                    ~"Expected: {$ex_type.gist}";
                diag "Exception message: $_.message()";
                diag 'Not running followup because type check failed';
            }
        }
    }
}

multi MAIN('test') {
    {
        my $game = Crypt::Game.new();

        is $game.look(),
            Adventure::PlayerLooked.new(
                :room<clearing>,
                :exits<east>,
            ),
            'looking at the room';
    }

    {
        my $engine = Adventure::Engine.new();

        my @rooms = <kitchen veranda>;
        is $engine.connect(@rooms, my $direction = 'south'),
            Adventure::TwoRoomsConnected.new(
                :@rooms,
                :$direction,
            ),
            'connecting two rooms (+)';
    }

    {
        my $engine = Adventure::Engine.new();

        my $direction = 'oops';
        throws_exception
            { $engine.connect(<boat lawn>, $direction) },
            X::Adventure::NoSuchDirection,
            'connecting two rooms (-) no such direction',
            {
                is .direction, $direction, '.direction attribute';
                is .message,
                    "Cannot connect rooms because direction "
                        ~ "'$direction' does not exist",
                    '.message attribute';
            };
    }

    {
        my $game = Crypt::Game.new();

        is $game.walk('east'),
            [
                Adventure::PlayerWalked.new(
                    :to<hill>,
                ),
                Adventure::PlayerLooked.new(
                    :room<hill>,
                    :exits<west>,
                ),
            ],
            'walking (+)';
    }

    {
        my $game = Crypt::Game.new();

        throws_exception
            { $game.walk('south') },
            X::Adventure::NoExitThere,
            'walking (-) in a direction without an exit',
            {
                is .direction, 'south', '.direction attribute';
                is .message,
                    "Cannot walk south because there is no exit there",
                    '.message attribute';
            };
    }

    {
        my $game = Crypt::Game.new();

        $game.walk('east');
        throws_exception
            { $game.walk('east') },
            X::Adventure::NoExitThere,
            'the player actually moves to the next room';
    }

    {
        my $engine = Adventure::Engine.new();

        my @rooms = <first_floor second_floor>;
        is $engine.connect(@rooms, my $direction = 'up'),
            Adventure::TwoRoomsConnected.new(
                :@rooms,
                :$direction,
            ),
            'connecting two rooms vertically';
        $engine.place_player('first_floor');
        is $engine.walk('up')[0],
            Adventure::PlayerWalked.new(
                :to<second_floor>,
            ),
            'going up to the second floor';
    }

    {
        my $engine = Adventure::Engine.new();

        my @rooms = <outside inside>;
        is $engine.connect(@rooms, my $direction = 'southwest'),
            Adventure::TwoRoomsConnected.new(
                :@rooms,
                :$direction,
            ),
            'connecting outside and inside';
        is $engine.alias_direction('outside', 'in', 'southwest'),
            Adventure::DirectionAliased.new(
                :room<outside>,
                :direction<southwest>,
                :alias<in>,
            ),
            'aliasing "southwest" as "in"';
        is $engine.place_player('outside')[0],
            Adventure::PlayerWasPlaced.new(
                :in<outside>,
            ),
            'placing the player';
        is $engine.walk('in'),
            [
                Adventure::PlayerWalked.new(
                    :to<inside>,
                ),
                Adventure::PlayerLooked.new(
                    :room<inside>,
                    :exits<northeast>,
                ),
            ],
            'going inside now means going southwest';
    }

    {
        my $engine = Adventure::Engine.new();

        my @rooms = <kitchen veranda>;
        $engine.connect(@rooms, my $direction = 'south');
        $engine.place_player('kitchen');
        $engine.walk('south');
        is $engine.walk('north'),
            Adventure::PlayerWalked.new(
                :to<kitchen>,
            ),
            'connecting two rooms creates a mutual connection';
    }

    {
        my $engine = Adventure::Engine.new();

        $engine.place_thing('ball', 'street');
        $engine.place_player('street');
        is $engine.examine('ball'),
            Adventure::PlayerExamined.new(
                :thing<ball>,
            ),
            'examining an object (+)';
    }

    {
        my $engine = Adventure::Engine.new();

        $engine.place_player('street');
        throws_exception
            { $engine.examine('ball') },
            X::Adventure::NoSuchThingHere,
            'examining an object (-) no such object here',
            {
                is .thing, 'ball', '.thing attribute';
                is .message, "You see no ball here", '.message attribute';
            };
    }

    {
        my $engine = Adventure::Engine.new();

        $engine.place_thing('car', 'street');
        $engine.make_thing_openable('car');
        $engine.place_player('street');
        is $engine.open('car'),
            Adventure::PlayerOpened.new(
                :thing<car>,
            ),
            'opening an object (+)';
    }

    done;
}

multi MAIN('test', 'hanoi') {
    {
        my $game = Hanoi::Game.new();

        is $game.move('left', 'middle'),
           Hanoi::DiskMoved.new(
                :disk('tiny disk'),
                :source<left>,
                :target<middle>
           ),
           'moving a disk (+)';

        throws_exception
            { $game.move('left', 'middle') },
            X::Hanoi::LargerOnSmaller,
            'moving a disk (-) larger disk on smaller',
            {
                is .larger, 'small disk', '.larger attribute';
                is .smaller, 'tiny disk', '.smaller attribute';
                is .message,
                   'Cannot put the small disk on the tiny disk',
                   '.message attribute';
            };

        throws_exception
            { $game.move('gargle', 'middle') },
            X::Hanoi::NoSuchRod,
            'moving a disk (-) no such source rod',
            {
                is .rod, 'source', '.rod attribute';
                is .name, 'gargle', '.name attribute';
                is .message,
                   q[No such source rod 'gargle'],
                   '.message attribute';
            };

        throws_exception
            { $game.move('middle', 'clown') },
            X::Hanoi::NoSuchRod,
            'moving a disk (-) no such target rod',
            {
                is .rod, 'target', '.rod attribute';
                is .name, 'clown', '.name attribute';
                is .message,
                   q[No such target rod 'clown'],
                   '.message attribute';
            };

        throws_exception
            { $game.move('right', 'middle') },
            X::Hanoi::RodHasNoDisks,
            'moving a disk (-) rod has no disks',
            {
                is .name, 'right', '.name attribute';
                is .message,
                   q[Cannot move from the right rod because there is no disk there],
                   '.message attribute';
            };
    }

    {
        my $game = Hanoi::Game.new();

        multi hanoi_moves($source, $, $target, 1) {
            # A single disk, easy; just move it directly.
            $source, 'to', $target
        }
        multi hanoi_moves($source, $helper, $target, $n) {
            # $n-1 disks on to; move them off to the $helper rod first...
            hanoi_moves($source, $target, $helper, $n-1),
            # ...then move over the freed disk at the bottom...
            hanoi_moves($source, $helper, $target, 1),
            # ...and finally move the rest from $helper to $target.
            hanoi_moves($helper, $source, $target, $n-1)
        }

        # Let's play out the thing to the end. 32 moves.
        my @moves = hanoi_moves("left", "middle", "right", 5);
        # RAKUDO: .splice doesn't do WhateverCode yet: wanted *-3
        my @last_move = @moves.splice(@moves.end-2);

        lives_ok {
            for @moves -> $source, $, $target {
                my ($event, @rest) = $game.move($source, $target);
                die "Unexpected event type: {$event.name}"
                    unless $event ~~ Hanoi::DiskMoved;
                die "Unexpected extra events: @rest"
                    if @rest;
            }
        }, 'making all the moves to the end of the game works';

        {
            my ($source, $, $target) = @last_move;
            is $game.move($source, $target), (
                Hanoi::DiskMoved.new(:disk('tiny disk'), :$source, :$target),
                Hanoi::AchievementUnlocked.new(),
            ), 'putting all disks on the right rod unlocks achievement';

            $game.move($target, $source);
            is $game.move($source, $target), (
                Hanoi::DiskMoved.new(:disk('tiny disk'), :$source, :$target),
            ), 'moving things back and forth does not unlock achievement again';
        }

        {
            $game.move('right', 'middle');
            is $game.move(my $source = 'right', my $target = 'left'), (
                Hanoi::DiskMoved.new(:disk('small disk'), :$source, :$target),
                Hanoi::AchievementLocked.new(),
            ), 'removing two disks from the right rod locks achievement';
        }

        {
            $game.move('left', 'right');
            $game.remove('tiny disk');
            is $game.add(my $disk = 'tiny disk', my $target = 'right'), (
                Hanoi::DiskAdded.new(:$disk, :$target),
                Hanoi::AchievementUnlocked.new(),
            ), 'you can also unlock achievement by adding the disk';
        }
    }

    {
        my $game = Hanoi::Game.new();

        is $game.move('tiny disk', my $target = 'middle'),
           Hanoi::DiskMoved.new(:disk('tiny disk'), :source<left>, :$target),
           'naming source disk instead of the rod (+)';
    }

    {
        my $game = Hanoi::Game.new();

        throws_exception
            { $game.move('large disk', 'right') },
            X::Hanoi::CoveredDisk,
            'naming source disk instead of the rod (-)',
            {
                is .disk, 'large disk', '.disk attribute';
                is .covered_by, ['medium disk', 'small disk', 'tiny disk'],
                    '.covered_by attribute';
                is .message,
                   'Cannot move the large disk: it is covered by '
                   ~ 'the medium disk, the small disk, and the tiny disk',
                   '.message attribute';
            };
    }

    {
        my $game = Hanoi::Game.new();

        throws_exception
            { $game.move('small disk', 'right') },
            X::Hanoi::CoveredDisk,
            'naming source disk instead of the rod (-) no and for one-item lists',
            {
                is .message,
                   'Cannot move the small disk: it is covered by the tiny disk',
                   '.message attribute';
            };
    }

    {
        my $game = Hanoi::Game.new();

        is $game.remove('tiny disk'),
           Hanoi::DiskRemoved.new(:disk('tiny disk'), :source<left>),
           'removing a disk (+)';

        throws_exception
            { $game.remove('small disk') },
            X::Hanoi::ForbiddenDiskRemoval,
            'removing a disk (-) removing disk is forbidden',
            {
                is .disk, 'small disk', '.disk attribute';
                is .message,
                   'Removing the small disk is forbidden',
                   '.message attribute';
            };

        throws_exception
            { $game.remove('medium disk') },
            X::Hanoi::CoveredDisk,
            'removing a disk (-) the disk is covered',
            {
                is .disk, 'medium disk', '.disk attribute';
                is .covered_by, ['small disk'],
                    '.covered_by attribute';
            };

        $game.move('small disk', 'middle');
        throws_exception
            { $game.remove('medium disk') },
            X::Hanoi::ForbiddenDiskRemoval,
            'removing a disk (-) uncovered, removal is still forbidden',
            {
                is .disk, 'medium disk', '.disk attribute';
            };
    }

    {
        my $game = Hanoi::Game.new();

        $game.remove('tiny disk');

        throws_exception
            { $game.remove('tiny disk') },
            X::Hanoi::DiskHasBeenRemoved,
            'removing a disk (-) the disk had already been removed',
            {
                is .disk, 'tiny disk', '.disk attribute';
                is .action, 'remove', '.action attribute';
                is .message,
                   'Cannot remove the tiny disk because it has been removed',
                   '.message attribute';
            };

        throws_exception
            { $game.move('tiny disk', 'middle') },
            X::Hanoi::DiskHasBeenRemoved,
            'moving a disk (-) the disk had already been removed',
            {
                is .disk, 'tiny disk', '.disk attribute';
                is .action, 'move', '.action attribute';
                is .message,
                    'Cannot move the tiny disk because it has been removed',
                    '.message attribute';
            };

        throws_exception
            { $game.add('tiny disk', 'pineapple') },
            X::Hanoi::NoSuchRod,
            'moving a disk (-) the rod does not exist',
            {
                is .rod, 'target', '.rod attribute';
                is .name, 'pineapple', '.name attribute';
            };

        is $game.add('tiny disk', 'left'),
           Hanoi::DiskAdded.new(:disk('tiny disk'), :target<left>),
           'adding a disk (+)';

        throws_exception
            { $game.add('humongous disk', 'middle') },
            X::Hanoi::NoSuchDisk,
            'adding a disk (-) there is no such disk',
            {
                is .action, 'add', '.action attribute';
                is .disk, 'humongous disk', '.disk attribute';
                is .message,
                    'Cannot add a humongous disk because there is no such disk',
                    '.message attribute';
            };

        throws_exception
            { $game.add('tiny disk', 'right') },
            X::Hanoi::DiskAlreadyOnARod,
            'adding a disk (-) the disk is already on a rod',
            {
                is .disk, 'tiny disk', '.disk attribute';
                is .message,
                    'Cannot add the tiny disk because it is already on a rod',
                    '.message attribute';
            };
    }

    {
        my $game = Hanoi::Game.new();

        throws_exception
            { $game.remove('masakian disk') },
            X::Hanoi::NoSuchDisk,
            'removing a disk (-) the disk does not exist',
            {
                is .action, 'remove', '.action attribute';
                is .disk, 'masakian disk', '.disk attribute';
                is .message,
                   'Cannot remove a masakian disk because there is no such disk',
                   '.message attribute';
            };

    }

    done;
}