Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 5fcb6488f7
Fetching contributors…

Cannot retrieve contributors at this time

executable file 2353 lines (2009 sloc) 69.355 kB
#! /usr/local/bin/nom
use Test;
role Event {
method Str {
sub name($attr) { $attr.name.substr(2) }
sub value($attr) { $attr.get_value(self) }
sub attrpair($attr) { ":{name $attr}<{value $attr}>" }
sprintf '%s[%s]',
self.^name,
~map &attrpair, 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_and_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_and_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_and_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);
}
method !apply_and_return(@events) {
self!apply($_) for @events;
return @events;
}
# 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;
has @.things;
}
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 Adventure::PlayerPutIn does Event {
has $.thing;
has $.in;
}
class Adventure::ThingMadeAContainer does Event {
has $.thing;
}
class Adventure::PlayerPutOn does Event {
has $.thing;
has $.on;
}
class Adventure::ThingMadeAPlatform does Event {
has $.thing;
}
class Adventure::PlayerRead does Event {
has $.thing;
}
class Adventure::ThingMadeReadable does Event {
has $.thing;
}
class Adventure::ThingHidden does Event {
has $.thing;
}
class Adventure::ThingUnhidden does Event {
has $.thing;
}
class Adventure::PlayerTook does Event {
has $.thing;
}
class Adventure::ThingMadeCarryable does Event {
has $.thing;
}
class Adventure::PlayerDropped does Event {
has $.thing;
}
class Adventure::ThingMadeImplicit does Event {
has $.thing;
}
class Adventure::ContentsRevealed does Event {
has $.container;
has @.contents;
}
class Adventure::GameRemarked does Event {
has $.remark;
}
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::PlayerNowhere 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 X::Adventure::ThingNotOpenable is X::Adventure {
has $.thing;
method message {
"You cannot open the $.thing"
}
}
class X::Adventure::ThingAlreadyOpen is X::Adventure {
has $.thing;
method message {
"The $.thing is open"
}
}
class X::Adventure::CannotPutInNonContainer is X::Adventure {
has $.in;
method message {
"You cannot put things in the $.in"
}
}
class X::Adventure::YoDawg is X::Adventure {
has $.relation;
has $.thing;
method message {
"Yo dawg, I know you like a $.thing so I put a $.thing $.relation your $.thing"
}
}
class X::Adventure::CannotPutOnNonPlatform is X::Adventure {
has $.on;
method message {
"You cannot put things on the $.on"
}
}
class X::Adventure::ThingNotReadable is X::Adventure {
has $.thing;
method message {
"There is nothing to read on the $.thing"
}
}
class X::Adventure::ThingNotCarryable is X::Adventure {
has $.action;
has $.thing;
method message {
"You cannot $.action the $.thing"
}
}
class X::Adventure::PlayerAlreadyCarries is X::Adventure {
has $.thing;
method message {
"You already have the $.thing"
}
}
class X::Adventure::PlayerDoesNotHave is X::Adventure {
has $.thing;
method message {
"You are not carrying the $.thing"
}
}
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;
has %!openable_things;
has %!open_things;
has %!containers;
has %!platforms;
has %!readable_things;
has %!hidden_things;
has %!examine_hooks;
has %!carryable_things;
has %!implicit_things;
has %!open_hooks;
has %!put_hooks;
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_and_return: @events;
}
method !contents_of($thing) {
return %!thing_rooms.grep({.value eq "contents:$thing"})>>.key;
}
method !explicit_things_at($location) {
sub here_visible_and_explicit($_) {
%!thing_rooms{$_} eq $location
&& !%!hidden_things{$_} && !%!implicit_things{$_}
}
return unless $location;
return gather for %!thing_rooms.keys -> $thing {
next unless here_visible_and_explicit($thing);
if %!open_things{$thing} && self!contents_of($thing) {
take $thing => self!explicit_things_at("contents:$thing");
}
else {
take $thing;
}
}
}
method !is_thing_in($sought, $location) {
return unless $location;
for %!thing_rooms.keys -> $thing {
next unless %!thing_rooms{$thing} eq $location;
return True if $thing eq $sought;
if %!open_things{$thing} && self!contents_of($thing) {
return True if self!is_thing_in($sought, "contents:$thing");
}
}
return False;
}
method !thing_in_room_or_inventory($thing) {
self!is_thing_in($thing, $!player_location)
|| self!is_thing_in($thing, 'player inventory');
}
method walk($direction) {
die X::Adventure::PlayerNowhere.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),
:things(self!explicit_things_at($to)),
));
}
self!apply_and_return: @events;
}
method look() {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
my @events = Adventure::PlayerLooked.new(
:room($!player_location),
:exits((%!exits{$!player_location} // ()).keys),
:things(self!explicit_things_at($!player_location)),
);
self!apply_and_return: @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),
:things(self!explicit_things_at($in)),
));
}
self!apply_and_return: @events;
}
method alias_direction($room, $alias, $direction) {
my @events = Adventure::DirectionAliased.new(
:$room, :$alias, :$direction
);
self!apply_and_return: @events;
}
method place_thing($thing, $room) {
my @events = Adventure::ThingPlaced.new(
:$thing, :$room
);
self!apply_and_return: @events;
}
method examine($thing) {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
die X::Adventure::NoSuchThingHere.new(:$thing)
unless self!is_thing_in($thing, $!player_location);
die X::Adventure::NoSuchThingHere.new(:$thing)
if %!hidden_things{$thing};
my @events = Adventure::PlayerExamined.new(
:$thing
);
if %!examine_hooks{$thing} -> &hook {
@events.push(&hook());
}
self!apply_and_return: @events;
}
method make_thing_openable($thing) {
%!openable_things{$thing} = True;
}
method open($thing) {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
die X::Adventure::NoSuchThingHere.new(:$thing)
unless (%!thing_rooms{$thing} // '') eq $!player_location;
die X::Adventure::NoSuchThingHere.new(:$thing)
if %!hidden_things{$thing};
die X::Adventure::ThingNotOpenable.new(:$thing)
unless %!openable_things{$thing};
die X::Adventure::ThingAlreadyOpen.new(:$thing)
if %!open_things{$thing};
my @events = Adventure::PlayerOpened.new(:$thing);
my @contents = self!contents_of($thing);
if @contents {
@events.push(
Adventure::ContentsRevealed.new(
:container($thing), :@contents
)
);
}
if %!open_hooks{$thing} -> &hook {
@events.push(&hook());
}
self!apply_and_return: @events;
}
method make_thing_a_container($thing) {
my @events = Adventure::ThingMadeAContainer.new(:$thing);
self!apply_and_return: @events;
}
method put_thing_in($thing, $in) {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
die X::Adventure::NoSuchThingHere.new(:$thing)
unless self!thing_in_room_or_inventory($thing);
die X::Adventure::NoSuchThingHere.new(:thing($in))
unless self!thing_in_room_or_inventory($in);
die X::Adventure::ThingNotCarryable.new(:action<put>, :$thing)
unless %!carryable_things{$thing};
die X::Adventure::CannotPutInNonContainer.new(:$in)
unless %!containers{$in};
die X::Adventure::YoDawg.new(:relation<in>, :thing($in))
if $thing eq $in;
my @events;
if %!openable_things{$in} && !%!open_things{$in} {
@events.push(Adventure::PlayerOpened.new(:thing($in)));
}
@events.push(Adventure::PlayerPutIn.new(:$thing, :$in));
if %!put_hooks{$in} -> &hook {
@events.push($_) when Event for &hook($thing);
}
self!apply_and_return: @events;
}
method make_thing_a_platform($thing) {
my @events = Adventure::ThingMadeAPlatform.new(:$thing);
self!apply_and_return: @events;
}
method put_thing_on($thing, $on) {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
# XXX: should check if the first thing is there
# XXX: should check if the second thing is there
die X::Adventure::ThingNotCarryable.new(:action<put>, :$thing)
unless %!carryable_things{$thing};
die X::Adventure::CannotPutOnNonPlatform.new(:$on)
unless %!platforms{$on};
die X::Adventure::YoDawg.new(:relation<on>, :thing($on))
if $thing eq $on;
my @events = Adventure::PlayerPutOn.new(:$thing, :$on);
if %!put_hooks{$on} -> &hook {
@events.push($_) when Event for &hook($thing);
}
self!apply_and_return: @events;
}
method make_thing_readable($thing) {
my @events = Adventure::ThingMadeReadable.new(:$thing);
self!apply_and_return: @events;
}
method read($thing) {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
# XXX: should check if the thing is there
die X::Adventure::ThingNotReadable.new(:$thing)
unless %!readable_things{$thing};
Adventure::PlayerRead.new(:$thing);
}
method hide_thing($thing) {
my @events = Adventure::ThingHidden.new(:$thing);
self!apply_and_return: @events;
}
method unhide_thing($thing) {
my @events = Adventure::ThingUnhidden.new(:$thing);
self!apply_and_return: @events;
}
method make_thing_carryable($thing) {
my @events = Adventure::ThingMadeCarryable.new(:$thing);
self!apply_and_return: @events;
}
method take($thing) {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
die X::Adventure::PlayerAlreadyCarries.new(:$thing)
if (%!thing_rooms{$thing} // '') eq 'player inventory';
die X::Adventure::NoSuchThingHere.new(:$thing)
unless self!is_thing_in($thing, $!player_location);
die X::Adventure::ThingNotCarryable.new(:action<take>, :$thing)
unless %!carryable_things{$thing};
my @events = Adventure::PlayerTook.new(:$thing);
self!apply_and_return: @events;
}
method drop($thing) {
die X::Adventure::PlayerNowhere.new()
unless defined $!player_location;
die X::Adventure::PlayerDoesNotHave.new(:$thing)
unless %!thing_rooms{$thing} eq 'player inventory';
my @events = Adventure::PlayerDropped.new(:$thing);
self!apply_and_return: @events;
}
method remark($remark) {
my @events = Adventure::GameRemarked.new(:$remark);
self!apply_and_return: @events;
}
method make_thing_implicit($thing) {
my @events = Adventure::ThingMadeImplicit.new(:$thing);
self!apply_and_return: @events;
}
method on_try_exit($room, $direction, &hook) {
%!try_exit_hooks{$room}{$direction} = &hook;
}
method on_examine($thing, &hook) {
%!examine_hooks{$thing} = &hook;
}
method on_open($thing, &hook) {
%!open_hooks{$thing} = &hook;
}
method on_put($thing, &hook) {
%!put_hooks{$thing} = &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};
}
method !apply_and_return(@events) {
self!apply($_) for @events;
return @events;
}
# 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;
}
when Adventure::PlayerOpened {
%!open_things{.thing} = True;
}
when Adventure::ThingMadeAContainer {
%!containers{.thing} = True;
}
when Adventure::ThingMadeAPlatform {
%!platforms{.thing} = True;
}
when Adventure::ThingMadeReadable {
%!readable_things{.thing} = True;
}
when Adventure::ThingHidden {
%!hidden_things{.thing} = True;
}
when Adventure::ThingUnhidden {
%!hidden_things{.thing} = False;
}
when Adventure::ThingMadeCarryable {
%!carryable_things{.thing} = True;
}
when Adventure::PlayerTook {
%!thing_rooms{.thing} = 'player inventory';
}
when Adventure::PlayerDropped {
%!thing_rooms{.thing} = $!player_location;
}
when Adventure::ThingMadeImplicit {
%!implicit_things{.thing} = True;
}
}
}
class Crypt::Game {
has $!engine;
submethod BUILD() {
$!engine = Adventure::Engine.new();
given $!engine {
# Rooms
.connect(<clearing hill>, 'east');
.alias_direction('hill', 'in', 'south');
.alias_direction('chamber', 'out', 'north');
.connect(<chamber hall>, 'south');
.alias_direction('chamber', 'in', 'south');
.alias_direction('hall', 'out', 'north');
.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;
});
# Things in clearing
.place_thing('car', 'clearing');
.place_thing('flashlight', 'contents:car');
.make_thing_carryable('flashlight');
.place_thing('rope', 'contents:car');
.make_thing_carryable('rope');
.make_thing_openable('car');
.make_thing_a_container('car');
.on_put(
'car',
-> $_ {
when 'leaves' { $!engine.remark('car-full-of-leaves') }
});
# Things on hill
.place_thing('grass', 'hill');
.make_thing_implicit('grass');
.place_thing('bushes', 'hill');
.make_thing_implicit('bushes');
.place_thing('door', 'hill');
.make_thing_openable('door');
.hide_thing('door');
.on_examine('grass', { .unhide_thing('door') });
.on_examine('bushes', { .unhide_thing('door') });
.on_open('door', { .connect(<hill chamber>, 'south') });
.place_thing('trees', 'hill');
.make_thing_implicit('trees');
.place_thing('leaves', 'hill');
.make_thing_implicit('leaves');
.make_thing_carryable('leaves');
# Things in chamber
.place_thing('basket', 'chamber');
.make_thing_a_container('basket');
.on_put(
'basket',
-> $_ {
when 'leaves' {
$!engine.connect(<chamber hall>, 'south'),
$!engine.remark('passageway-opens-up');
}
});
.place_player('clearing');
}
}
method look {
return $!engine.look;
}
method walk($direction) {
return $!engine.walk($direction);
}
method open($thing) {
return $!engine.open($thing);
}
method examine($thing) {
return $!engine.examine($thing);
}
method take($thing) {
return $!engine.take($thing);
}
method put_thing_in($thing, $in) {
return $!engine.put_thing_in($thing, $in);
}
method put_thing_on($thing, $on) {
return $!engine.put_thing_on($thing, $on);
}
method save {
$!engine.save;
}
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 "There is a car here.";
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};
for .things -> $thing {
if $thing ~~ Pair {
say "There is a $thing.key() here.";
# XXX: Needs to work for nested calls, too
say "The $thing.key() contains:";
for $thing.value.list -> $containee {
say " A $containee.";
}
}
else {
say "There is a $thing here.";
}
}
if .exits {
say "You can go {join ' and ', .exits}.";
}
}
}
}
when any @possible_directions {
$command = "walk $command";
proceed;
}
when /^ 'put' \h+ (\w+) \h+ ('in'|'on') \h+ (\w+) $/ {
$command = "put_thing_$1 $0 $2";
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}.";
if @req_args {
say "The arguments are {map { "<$_>" }, @req_args}.";
}
}
my @events = $game."$verb"(|@args);
for @events {
when Adventure::PlayerWalked { say ucfirst .to; }
when Adventure::PlayerLooked {
say "";
say %descriptions{.room};
for .things -> $thing {
if $thing ~~ Pair {
say "There is a $thing.key() here.";
# XXX: Needs to work for nested calls, too
say "The $thing.key() contains:";
for $thing.value.list -> $containee {
say " A $containee.";
}
}
else {
say "There is a $thing here.";
}
}
if .exits {
say "You can go {join ' and ', .exits}.";
}
}
when Adventure::PlayerExamined { say %descriptions{.thing} }
when Adventure::ContentsRevealed {
my $contents = join " and ", map { "a $_" }, .contents;
say "Opening the {.container} reveals $contents.";
}
when Adventure::PlayerTook {
say "You take the {.thing}.";
}
when Adventure::PlayerOpened {
say "You open the {.thing}.";
}
when Adventure::PlayerPutIn {
say "You put the {.thing} in the {.in}.";
}
when Adventure::GameRemarked {
say %descriptions{"remark:{.remark}"};
}
}
CATCH {
when X::Adventure { say .message, '.' }
}
}
default {
say "Sorry, I did not understand that.";
}
}
say "";
}
say "Thanks for playing.";
}
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>,
:things<car>,
),
'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 (+)';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('ball', 'street');
$engine.place_player('street');
throws_exception
{ $engine.open('ball') },
X::Adventure::ThingNotOpenable,
'opening an object (-) it is not openable',
{
is .thing, 'ball', '.thing attribute';
is .message, "You cannot open the ball", '.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('car', 'street');
$engine.make_thing_openable('car');
$engine.place_player('street');
$engine.open('car');
throws_exception
{ $engine.open('car') },
X::Adventure::ThingAlreadyOpen,
'opening an object (-) it is already open',
{
is .thing, 'car', '.thing attribute';
is .message, "The car is open", '.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('box', 'street');
$engine.make_thing_a_container('box');
$engine.place_thing('doll', 'street');
$engine.make_thing_carryable('doll');
$engine.place_player('street');
is $engine.put_thing_in('doll', 'box'),
Adventure::PlayerPutIn.new(
:thing<doll>,
:in<box>,
),
'putting a thing inside another (+)';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('brick', 'street');
# don't make brick a container
$engine.place_thing('doll', 'street');
$engine.make_thing_carryable('doll');
$engine.place_player('street');
throws_exception
{ $engine.put_thing_in('doll', 'brick') },
X::Adventure::CannotPutInNonContainer,
'putting a thing inside another (-) it is not a container',
{
is .in, 'brick', '.in attribute';
is .message,
"You cannot put things in the brick",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('crate', 'street');
$engine.make_thing_a_container('crate');
$engine.make_thing_openable('crate');
$engine.place_thing('doll', 'street');
$engine.make_thing_carryable('doll');
$engine.place_player('street');
is $engine.put_thing_in('doll', 'crate'),
[
Adventure::PlayerOpened.new(
:thing<crate>,
),
Adventure::PlayerPutIn.new(
:thing<doll>,
:in<crate>,
),
],
'putting a thing inside another (+) container was closed';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('box', 'street');
$engine.make_thing_a_container('box');
$engine.make_thing_carryable('box');
$engine.place_player('street');
throws_exception
{ $engine.put_thing_in('box', 'box') },
X::Adventure::YoDawg,
'putting a thing inside another (-) but it is the same thing',
{
is .relation, 'in', '.relation attribute';
is .thing, 'box', '.thing attribute';
is .message,
"Yo dawg, I know you like a box so I put a box in your box",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('surface', 'street');
$engine.make_thing_a_platform('surface');
$engine.place_thing('doll', 'street');
$engine.make_thing_carryable('doll');
$engine.place_player('street');
is $engine.put_thing_on('doll', 'surface'),
Adventure::PlayerPutOn.new(
:thing<doll>,
:on<surface>,
),
'putting a thing on another (+)';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('hole', 'street');
# don't make hole a platform
$engine.place_thing('doll', 'street');
$engine.make_thing_carryable('doll');
$engine.place_player('street');
throws_exception
{ $engine.put_thing_on('doll', 'hole') },
X::Adventure::CannotPutOnNonPlatform,
'putting a thing on another (-) it is not a platform',
{
is .on, 'hole', '.on attribute';
is .message,
"You cannot put things on the hole",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('surface', 'street');
$engine.make_thing_a_platform('surface');
$engine.make_thing_carryable('surface');
$engine.place_player('street');
throws_exception
{ $engine.put_thing_on('surface', 'surface') },
X::Adventure::YoDawg,
'putting a thing on another (-) but it is the same thing',
{
is .relation, 'on', '.relation attribute';
is .thing, 'surface', '.thing attribute';
is .message,
"Yo dawg, I know you like a surface so I put a surface on your surface",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('book', 'library');
$engine.make_thing_readable('book');
$engine.place_player('library');
is $engine.read('book'),
Adventure::PlayerRead.new(
:thing<book>,
),
'reading a thing (+)';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('ball', 'library');
# don't make ball readable
$engine.place_player('library');
throws_exception
{ $engine.read('ball') },
X::Adventure::ThingNotReadable,
'reading a thing (-) it is not readable',
{
is .thing, 'ball', '.thing attribute';
is .message,
"There is nothing to read on the ball",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('flask', 'chamber');
$engine.hide_thing('flask');
$engine.place_player('chamber');
throws_exception
{ $engine.examine('flask') },
X::Adventure::NoSuchThingHere,
'examining a hidden thing (-) cannot because it is hidden';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('flask', 'chamber');
$engine.make_thing_openable('flask');
$engine.hide_thing('flask');
$engine.place_player('chamber');
throws_exception
{ $engine.open('flask') },
X::Adventure::NoSuchThingHere,
'opening a hidden thing (-) cannot because it is hidden';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('flask', 'chamber');
$engine.make_thing_openable('flask');
$engine.place_player('bedroom');
throws_exception
{ $engine.open('flask') },
X::Adventure::NoSuchThingHere,
'opening a thing (-) cannot because it is in another room';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('door', 'hill');
$engine.place_thing('grass', 'hill');
$engine.make_thing_openable('door');
$engine.hide_thing('door');
$engine.on_examine('grass', { $engine.unhide_thing('door') });
$engine.place_player('hill');
$engine.examine('grass');
is $engine.open('door'),
Adventure::PlayerOpened.new(
:thing<door>,
),
'opening a thing (+) unhidden by a callback';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('box', 'saloon');
$engine.make_thing_carryable('box');
$engine.place_player('saloon');
is $engine.take('box'),
Adventure::PlayerTook.new(
:thing<box>,
),
'taking a thing (+)';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('table', 'saloon');
# don't make table carryable
$engine.place_player('saloon');
throws_exception
{ $engine.take('table') },
X::Adventure::ThingNotCarryable,
'taking a thing (-) it is not carryable',
{
is .action, 'take', '.action attribute';
is .thing, 'table', '.thing attribute';
is .message,
"You cannot take the table",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('box', 'street');
$engine.make_thing_a_container('box');
$engine.place_thing('doll', 'street');
# don't make doll carryable
$engine.place_player('street');
throws_exception
{ $engine.put_thing_in('doll', 'box') },
X::Adventure::ThingNotCarryable,
'putting a thing inside another (-) not carryable',
{
is .action, 'put', '.action attribute';
is .thing, 'doll', '.thing attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('surface', 'street');
$engine.make_thing_a_platform('surface');
$engine.place_thing('doll', 'street');
# don't make doll carryable
$engine.place_player('street');
throws_exception
{ $engine.put_thing_on('doll', 'surface') },
X::Adventure::ThingNotCarryable,
'putting a thing on another (-) not carryable',
{
is .action, 'put', '.action attribute';
is .thing, 'doll', '.thing attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('cup', 'porch');
$engine.make_thing_carryable('cup');
$engine.place_player('porch');
$engine.take('cup');
throws_exception
{ $engine.take('cup') },
X::Adventure::PlayerAlreadyCarries,
'taking a thing (-) player already has',
{
is .thing, 'cup', '.thing attribute';
is .message, "You already have the cup",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('cup', 'porch');
$engine.make_thing_carryable('cup');
$engine.place_player('porch');
$engine.take('cup');
is $engine.drop('cup'),
Adventure::PlayerDropped.new(
:thing<cup>,
),
'dropping a thing (+)';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('cup', 'porch');
$engine.make_thing_carryable('cup');
$engine.place_player('porch');
throws_exception
{ $engine.drop('cup') },
X::Adventure::PlayerDoesNotHave,
'dropping a thing (-) player does not have it',
{
is .thing, 'cup', '.thing attribute';
is .message, "You are not carrying the cup",
'.message attribute';
};
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('box', 'saloon');
$engine.make_thing_carryable('box');
$engine.place_player('saloon');
$engine.take('box');
$engine.drop('box');
is $engine.take('box'),
Adventure::PlayerTook.new(
:thing<box>,
),
'taking a thing (+) take, drop, take';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('dog', 'street');
$engine.place_player('street');
is $engine.look(),
Adventure::PlayerLooked.new(
:room<street>,
:things<dog>,
),
'looking at the room, explicit thing';
}
{
my $engine = Adventure::Engine.new();
$engine.place_thing('fog', 'street');
$engine.make_thing_implicit('fog');
$engine.place_player('street');
is $engine.look(),
Adventure::PlayerLooked.new(
:room<street>,
),
'looking at the room, implicit thing';
}
{
my $game = Crypt::Game.new();
is $game.open('car'),
[
Adventure::PlayerOpened.new(
:thing<car>,
),
Adventure::ContentsRevealed.new(
:container<car>,
:contents<flashlight rope>,
),
],
'opening the car';
}
{
my $game = Crypt::Game.new();
$game.open('car');
is $game.look(),
Adventure::PlayerLooked.new(
:room<clearing>,
:exits<east>,
:things(car => <flashlight rope>),
),
'looking inside the car';
}
{
my $game = Crypt::Game.new();
$game.open('car');
is $game.take('flashlight'),
Adventure::PlayerTook.new(
:thing<flashlight>,
),
'taking the flashlight from the car (+)';
}
{
my $game = Crypt::Game.new();
$game.open('car');
is $game.take('rope'),
Adventure::PlayerTook.new(
:thing<rope>,
),
'taking the rope from the car (+)';
}
{
my $game = Crypt::Game.new();
throws_exception
{ $game.take('flashlight') },
X::Adventure::NoSuchThingHere,
'taking the flashlight from the car (-) car not open';
}
{
my $game = Crypt::Game.new();
$game.open('car');
is $game.examine('flashlight'),
Adventure::PlayerExamined.new(
:thing<flashlight>,
),
'examining the flashlight in the car';
}
{
my $game = Crypt::Game.new();
$game.walk('east');
$game.examine('grass');
is $game.open('door')[0],
Adventure::PlayerOpened.new(
:thing<door>,
),
'opening the door (+) having examined the grass';
}
{
my $game = Crypt::Game.new();
$game.walk('east');
throws_exception
{ $game.open('door') },
X::Adventure::NoSuchThingHere,
'opening the door (-) without examining the grass';
}
{
my $game = Crypt::Game.new();
$game.walk('east');
$game.examine('bushes');
is $game.open('door')[0],
Adventure::PlayerOpened.new(
:thing<door>,
),
'opening the door (+) bushes work too';
}
{
my $game = Crypt::Game.new();
$game.walk('east');
$game.examine('bushes');
$game.open('door');
is $game.walk('in'),
[
Adventure::PlayerWalked.new(
:to<chamber>,
),
Adventure::PlayerLooked.new(
:room<chamber>,
:exits<south north>,
:things<basket>,
),
],
'walking into the hill (+) after opening the door';
}
{
my $game = Crypt::Game.new();
$game.walk('east');
is $game.take('leaves'),
Adventure::PlayerTook.new(
:thing<leaves>,
),
'taking the leaves';
}
{
my $game = Crypt::Game.new();
$game.walk('east');
$game.take('leaves');
$game.walk('west');
is $game.put_thing_in('leaves', 'car'),
[
Adventure::PlayerOpened.new(
:thing<car>,
),
Adventure::PlayerPutIn.new(
:thing<leaves>,
:in<car>,
),
Adventure::GameRemarked.new(
:remark<car-full-of-leaves>,
),
],
'putting the leaves in the car';
}
sub game_from_chamber {
my $game = Crypt::Game.new();
$game.walk('east');
$game.take('leaves');
$game.examine('bushes');
$game.open('door');
$game.walk('in');
return $game;
}
{
my $game = game_from_chamber();
is $game.put_thing_in('leaves', 'basket'),
[
Adventure::PlayerPutIn.new(
:thing<leaves>,
:in<basket>,
),
Adventure::TwoRoomsConnected.new(
:rooms<chamber hall>,
:direction<south>,
),
Adventure::GameRemarked.new(
:remark<passageway-opens-up>,
),
],
'putting the leaves in the basket';
}
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;
}
Jump to Line
Something went wrong with that request. Please try again.