Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: masak/crypt
base: 871274399b
...
head fork: masak/crypt
compare: 49bb657205
  • 5 commits
  • 9 files changed
  • 0 commit comments
  • 1 contributor
Commits on Jul 31, 2012
@masak [bin/crypt] de-special-cased crypt wrapper methods
...and put the special hanoi-handling logic in hooks instead.
4a89e8f
@masak put everything into their own modules
All the tests still pass.
de755db
@masak [README.md] added 95b2d2e
@masak moved Adventure::Engine out of crypt
...and into its own module in the ecosystem.
e10a8b7
@masak added LICENSE and META.info 49bb657
View
201 LICENSE
@@ -0,0 +1,201 @@
+ The Artistic License 2.0
+
+ Copyright (c) 2000-2006, The Perl Foundation.
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+Preamble
+
+This license establishes the terms under which a given free software
+Package may be copied, modified, distributed, and/or redistributed.
+The intent is that the Copyright Holder maintains some artistic
+control over the development of that Package while still keeping the
+Package available as open source and free software.
+
+You are always permitted to make arrangements wholly outside of this
+license directly with the Copyright Holder of a given Package. If the
+terms of this license do not permit the full use that you propose to
+make of the Package, you should contact the Copyright Holder and seek
+a different licensing arrangement.
+
+Definitions
+
+ "Copyright Holder" means the individual(s) or organization(s)
+ named in the copyright notice for the entire Package.
+
+ "Contributor" means any party that has contributed code or other
+ material to the Package, in accordance with the Copyright Holder's
+ procedures.
+
+ "You" and "your" means any person who would like to copy,
+ distribute, or modify the Package.
+
+ "Package" means the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection and/or of
+ those files. A given Package may consist of either the Standard
+ Version, or a Modified Version.
+
+ "Distribute" means providing a copy of the Package or making it
+ accessible to anyone else, or in the case of a company or
+ organization, to others outside of your company or organization.
+
+ "Distributor Fee" means any fee that you charge for Distributing
+ this Package or providing support for this Package to another
+ party. It does not mean licensing fees.
+
+ "Standard Version" refers to the Package if it has not been
+ modified, or has been modified only in ways explicitly requested
+ by the Copyright Holder.
+
+ "Modified Version" means the Package, if it has been changed, and
+ such changes were not explicitly requested by the Copyright
+ Holder.
+
+ "Original License" means this Artistic License as Distributed with
+ the Standard Version of the Package, in its current version or as
+ it may be modified by The Perl Foundation in the future.
+
+ "Source" form means the source code, documentation source, and
+ configuration files for the Package.
+
+ "Compiled" form means the compiled bytecode, object code, binary,
+ or any other form resulting from mechanical transformation or
+ translation of the Source form.
+
+
+Permission for Use and Modification Without Distribution
+
+(1) You are permitted to use the Standard Version and create and use
+Modified Versions for any purpose without restriction, provided that
+you do not Distribute the Modified Version.
+
+
+Permissions for Redistribution of the Standard Version
+
+(2) You may Distribute verbatim copies of the Source form of the
+Standard Version of this Package in any medium without restriction,
+either gratis or for a Distributor Fee, provided that you duplicate
+all of the original copyright notices and associated disclaimers. At
+your discretion, such verbatim copies may or may not include a
+Compiled form of the Package.
+
+(3) You may apply any bug fixes, portability changes, and other
+modifications made available from the Copyright Holder. The resulting
+Package will still be considered the Standard Version, and as such
+will be subject to the Original License.
+
+
+Distribution of Modified Versions of the Package as Source
+
+(4) You may Distribute your Modified Version as Source (either gratis
+or for a Distributor Fee, and with or without a Compiled form of the
+Modified Version) provided that you clearly document how it differs
+from the Standard Version, including, but not limited to, documenting
+any non-standard features, executables, or modules, and provided that
+you do at least ONE of the following:
+
+ (a) make the Modified Version available to the Copyright Holder
+ of the Standard Version, under the Original License, so that the
+ Copyright Holder may include your modifications in the Standard
+ Version.
+
+ (b) ensure that installation of your Modified Version does not
+ prevent the user installing or running the Standard Version. In
+ addition, the Modified Version must bear a name that is different
+ from the name of the Standard Version.
+
+ (c) allow anyone who receives a copy of the Modified Version to
+ make the Source form of the Modified Version available to others
+ under
+
+ (i) the Original License or
+
+ (ii) a license that permits the licensee to freely copy,
+ modify and redistribute the Modified Version using the same
+ licensing terms that apply to the copy that the licensee
+ received, and requires that the Source form of the Modified
+ Version, and of any works derived from it, be made freely
+ available in that license fees are prohibited but Distributor
+ Fees are allowed.
+
+
+Distribution of Compiled Forms of the Standard Version
+or Modified Versions without the Source
+
+(5) You may Distribute Compiled forms of the Standard Version without
+the Source, provided that you include complete instructions on how to
+get the Source of the Standard Version. Such instructions must be
+valid at the time of your distribution. If these instructions, at any
+time while you are carrying out such distribution, become invalid, you
+must provide new instructions on demand or cease further distribution.
+If you provide valid instructions or cease distribution within thirty
+days after you become aware that the instructions are invalid, then
+you do not forfeit any of your rights under this license.
+
+(6) You may Distribute a Modified Version in Compiled form without
+the Source, provided that you comply with Section 4 with respect to
+the Source of the Modified Version.
+
+
+Aggregating or Linking the Package
+
+(7) You may aggregate the Package (either the Standard Version or
+Modified Version) with other packages and Distribute the resulting
+aggregation provided that you do not charge a licensing fee for the
+Package. Distributor Fees are permitted, and licensing fees for other
+components in the aggregation are permitted. The terms of this license
+apply to the use and Distribution of the Standard or Modified Versions
+as included in the aggregation.
+
+(8) You are permitted to link Modified and Standard Versions with
+other works, to embed the Package in a larger work of your own, or to
+build stand-alone binary or bytecode versions of applications that
+include the Package, and Distribute the result without restriction,
+provided the result does not expose a direct interface to the Package.
+
+
+Items That are Not Considered Part of a Modified Version
+
+(9) Works (including, but not limited to, modules and scripts) that
+merely extend or make use of the Package, do not, by themselves, cause
+the Package to be a Modified Version. In addition, such works are not
+considered parts of the Package itself, and are not subject to the
+terms of this license.
+
+
+General Provisions
+
+(10) Any use, modification, and distribution of the Standard or
+Modified Versions is governed by this Artistic License. By using,
+modifying or distributing the Package, you accept this license. Do not
+use, modify, or distribute the Package, if you do not accept this
+license.
+
+(11) If your Modified Version has been derived from a Modified
+Version made by someone other than you, you are nevertheless required
+to ensure that your Modified Version complies with the requirements of
+this license.
+
+(12) This license does not grant you the right to use any trademark,
+service mark, tradename, or logo of the Copyright Holder.
+
+(13) This license includes the non-exclusive, worldwide,
+free-of-charge patent license to make, have made, use, offer to sell,
+sell, import and otherwise transfer the Package with respect to any
+patent claims licensable by the Copyright Holder that are necessarily
+infringed by the Package. If you institute patent litigation
+(including a cross-claim or counterclaim) against any party alleging
+that the Package constitutes direct or contributory patent
+infringement, then this Artistic License to you shall terminate on the
+date that such litigation is filed.
+
+(14) Disclaimer of Warranty:
+THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
+IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
+NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
+LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
+BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
8 META.info
@@ -0,0 +1,8 @@
+{
+ "name" : "Crypt::Game",
+ "version" : "0.2.0",
+ "description" : "An adventure game.",
+ "author" : "Carl Mäsak",
+ "depends" : ["Adventure::Engine"],
+ "source-url" : "git://github.com/masak/crypt.git"
+}
View
4 README.md
@@ -0,0 +1,4 @@
+Crypt
+=====
+
+An adventure game written in Perl 6.
View
3,733 bin/crypt
292 additions, 3,441 deletions not shown
View
276 lib/Crypt/Game.pm
@@ -0,0 +1,276 @@
+use Adventure::Engine;
+use Hanoi::Game;
+
+class X::Crypt is Exception {
+}
+
+class X::Crypt::NoDisksHere is X::Crypt {
+}
+
+class Crypt::Game {
+ has $!engine;
+ has $!hanoi;
+ has $!player_location;
+
+ submethod BUILD() {
+ $!engine = Adventure::Engine.new();
+
+ given $!engine {
+ # Rooms
+ .connect: <clearing hill>, 'east';
+ .alias_direction: 'hill', 'in', 'south';
+ .alias_direction: 'chamber', 'out', 'north';
+ .on_try_exit: 'chamber', 'north', {
+ if .thing_is_in('butterfly', 'player inventory') {
+ .remark('made-it-out-with-treasure'),
+ .finish(),
+ False;
+ }
+ else {
+ True;
+ }
+ };
+ .alias_direction: 'chamber', 'in', 'south';
+ .alias_direction: 'hall', 'out', 'north';
+ .connect: <cave crypt>, 'northwest';
+ .on_try_exit: 'cave', 'northwest', {
+ if .thing_is_in('fire', 'cave') {
+ .remark('walk-past-fire-too-hot'),
+ False;
+ }
+ else {
+ True;
+ }
+ };
+ .make_room_dark: 'hall';
+ .make_room_dark: 'cave';
+ .make_room_dark: 'crypt';
+
+ # Things in clearing
+ .place_thing: 'car', 'clearing';
+ .place_thing: 'flashlight', 'contents:car';
+ .make_thing_carryable: 'flashlight';
+ .make_thing_a_light_source: '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' }
+ when 'water' {
+ $!engine.remark('car-is-now-wet'),
+ $!engine.place_thing('water', 'hill');
+ }
+ };
+
+ # 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'), .remark('door-under-grass') };
+ .on_examine: 'bushes',
+ { .unhide_thing('door'), .remark('door-under-grass') };
+ .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';
+ .place_thing: 'brook', 'hill';
+ .make_thing_a_container: 'brook';
+ .on_remove_from: 'brook',
+ -> $_ {
+ when 'helmet' {
+ $!engine.place_thing('water', 'contents:helmet');
+ }
+ };
+ .place_thing: 'water', 'hill';
+ .on_take: 'water',
+ {
+ $!engine.remark('bare-hands-carry-water'),
+ $!engine.drop('water');
+ };
+ .make_thing_implicit: 'water';
+ .make_thing_carryable: 'water';
+
+ # Things in chamber
+ .place_thing: 'basket', 'chamber';
+ .make_thing_a_container: 'basket';
+ .place_thing: 'sign', 'chamber';
+ .make_thing_readable: 'sign';
+ .on_put:
+ 'basket',
+ -> $_ {
+ when 'leaves' {
+ $!engine.connect(<chamber hall>, 'south'),
+ $!engine.remark('passageway-opens-up');
+ }
+ };
+
+ # Things in hall
+ .place_thing: 'helmet', 'hall';
+ .make_thing_carryable: 'helmet';
+ .make_thing_a_container: 'helmet';
+ .place_thing: 'hanoi', 'hall';
+ .make_thing_implicit: 'hanoi';
+ .make_thing_a_container: 'hanoi';
+ for <left middle right> X~ ' rod' -> $rod {
+ .place_thing: $rod, 'contents:hanoi';
+ .make_thing_a_platform: $rod;
+ .on_put: $rod,
+ -> $_ {
+ when 'tiny disk' {
+ my @events = $!hanoi.add: $_, $rod.words[0];
+ for @events {
+ when Hanoi::AchievementUnlocked {
+ push @events,
+ $!engine.remark('floor-reveals-hole'),
+ $!engine.connect(<hall cave>, 'down');
+ }
+ }
+ @events;
+ }
+ };
+ }
+ for <tiny small medium large huge> X~ ' disk' -> $disk {
+ .place_thing: $disk, 'contents:left rod';
+ }
+ .make_thing_carryable: 'tiny disk';
+ .on_take: 'tiny disk', { $!hanoi.remove: 'tiny disk' };
+
+ # Things in cave
+ .place_thing: 'fire', 'cave';
+ .make_thing_a_container: 'fire';
+ .on_put:
+ 'fire',
+ -> $_ {
+ when 'water' {
+ $!engine.remark('fire-dies'),
+ $!engine.hide_thing('fire');
+ }
+ };
+
+ # Things in crypt
+ .place_thing: 'pedestal', 'crypt';
+ .make_thing_a_platform: 'pedestal';
+ .on_put:
+ 'pedestal',
+ -> $_ {
+ when 'butterfly' | 'tiny disk' {
+ # XXX: Need to change signature of .put_out_fuse to
+ # accept a closure, to be run if there was a fuse to
+ # put out.
+ $!engine.put_out_fuse('cavern-collapse'),
+ $!engine.remark('alarm-stops');
+ }
+ };
+ .on_remove_from:
+ 'pedestal',
+ -> $_ {
+ when 'butterfly' | 'tiny disk' {
+ # XXX: Should be 3, will fix when getting sagas
+ $!engine.light_fuse(4, 'cavern-collapse', {
+ $!engine.remark('cavern-collapses'),
+ $!engine.finish();
+ }),
+ $!engine.remark('alarm-starts');
+ }
+ };
+ .place_thing: 'butterfly', 'contents:pedestal';
+ .make_thing_carryable: 'butterfly';
+
+ .place_player: $!player_location = 'clearing';
+ }
+
+ $!hanoi = Hanoi::Game.new();
+ }
+
+ method look {
+ return $!engine.look;
+ }
+
+ method !update_local_state(@events) {
+ for @events {
+ when Adventure::PlayerWalked { $!player_location = .to }
+ when Adventure::PlayerWasPlaced { $!player_location = .in }
+ }
+ }
+
+ method walk($direction) {
+ my @events = $!engine.walk($direction);
+ self!update_local_state(@events);
+ @events;
+ }
+
+ method open($thing) {
+ return $!engine.open($thing);
+ }
+
+ method examine($thing) {
+ return $!engine.examine($thing);
+ }
+
+ method inventory() {
+ return $!engine.inventory();
+ }
+
+ method take($thing) {
+ return $!engine.take($thing);
+ }
+
+ method drop($thing) {
+ return $!engine.drop($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 read($thing) {
+ return $!engine.read($thing);
+ }
+
+ method use($thing) {
+ return $!engine.use($thing);
+ }
+
+ method move($source, $target) {
+ die X::Crypt::NoDisksHere.new
+ unless $!player_location eq 'hall';
+
+ my @events = $!hanoi.move($source, $target);
+ for @events {
+ when Hanoi::AchievementUnlocked {
+ push @events,
+ $!engine.remark('floor-reveals-hole'),
+ $!engine.connect(<hall cave>, 'down');
+ }
+ when Hanoi::AchievementLocked {
+ push @events,
+ $!engine.remark('floor-hides-hole'),
+ $!engine.disconnect(<hall cave>, 'down');
+ }
+ }
+ return @events;
+ }
+
+ method save {
+ $!engine.save;
+ }
+
+ method restore($save) {
+ $!engine .= restore($save);
+ return;
+ }
+}
View
9 lib/Event.pm
@@ -0,0 +1,9 @@
+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;
+ }
+}
View
327 lib/Hanoi/Game.pm
@@ -0,0 +1,327 @@
+use Event;
+
+module Hanoi {
+ class DiskMoved does Event {
+ has $.disk;
+ has $.source;
+ has $.target;
+ }
+
+ class AchievementUnlocked does Event {
+ }
+
+ class AchievementLocked does Event {
+ }
+
+ class DiskRemoved does Event {
+ has $.disk;
+ has $.source;
+ }
+
+ class DiskAdded does Event {
+ has $.disk;
+ has $.target;
+ }
+
+ our sub print_hanoi_game(@all_events) {
+ my @disks = <tiny small medium large huge> X~ ' disk';
+ my @rods = <left middle right>;
+
+ 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;
+ }
+}
+
+class X::Hanoi is Exception {
+ class LargerOnSmaller is X::Hanoi {
+ has $.larger;
+ has $.smaller;
+
+ method message {
+ "Cannot put the $.larger on the $.smaller"
+ }
+ }
+
+ class NoSuchRod is X::Hanoi {
+ has $.rod;
+ has $.name;
+
+ method message {
+ "No such $.rod rod '$.name'"
+ }
+ }
+
+ class RodHasNoDisks is X::Hanoi {
+ has $.name;
+
+ method message {
+ "Cannot move from the $.name rod because there is no disk there"
+ }
+ }
+
+ class 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 ForbiddenDiskRemoval is X::Hanoi {
+ has $.disk;
+
+ method message {
+ "Removing the $.disk is forbidden"
+ }
+ }
+
+ class DiskHasBeenRemoved is X::Hanoi {
+ has $.disk;
+ has $.action;
+
+ method message {
+ "Cannot $.action the $.disk because it has been removed"
+ }
+ }
+
+ class NoSuchDisk is X::Hanoi {
+ has $.disk;
+ has $.action;
+
+ method message {
+ "Cannot $.action a $.disk because there is no such disk"
+ }
+ }
+
+ class 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);
+ }
+ }
+}
+
+sub CLI {
+ my Hanoi::Game $game .= new;
+
+ 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;
+
+ Hanoi::print_hanoi_game(@all_events);
+ 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 "";
+ my @disks = <tiny small medium large huge> X~ ' disk';
+ my @rods = <left middle right>;
+ say "Disks: ", join ', ', @disks;
+ say "Rods: ", join ', ', @rods;
+ }
+ when 's' | 'show' { Hanoi::print_hanoi_game(@all_events) }
+
+ 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;
+ Hanoi::print_hanoi_game(@all_events);
+ 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 "";
+ }
+}
View
714 t/crypt.t
@@ -0,0 +1,714 @@
+use v6;
+use Test;
+use Crypt::Game;
+
+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';
+ }
+ }
+ }
+}
+
+sub game_from_chamber {
+ my $game = Crypt::Game.new();
+
+ $game.open('car');
+ $game.take('flashlight');
+ $game.walk('east');
+ $game.take('leaves');
+ $game.examine('bushes');
+ $game.open('door');
+ $game.walk('in');
+ return $game;
+}
+
+sub game_from_hall {
+ my $game = game_from_chamber();
+
+ $game.put_thing_in('leaves', 'basket'),
+ $game.walk('south');
+ return $game;
+}
+
+sub game_after_hanoi_is_solved {
+ my $game = game_from_hall();
+
+ multi hanoi_moves($source, $, $target, 1) { { :$source, :$target } }
+ multi hanoi_moves($source, $helper, $target, $n) {
+ hanoi_moves($source, $target, $helper, $n-1),
+ hanoi_moves($source, $helper, $target, 1),
+ hanoi_moves($helper, $source, $target, $n-1);
+ }
+
+ $game.use('flashlight');
+ $game.move(.<source>, .<target>)
+ for hanoi_moves('left', 'middle', 'right', 5);
+ return $game;
+}
+
+sub game_after_putting_out_the_fire {
+ my $game = game_after_hanoi_is_solved();
+
+ $game.take('helmet');
+ $game.walk('north');
+ $game.walk('north');
+ $game.put_thing_in('water', 'helmet');
+ $game.walk('south');
+ $game.walk('south');
+ $game.walk('down');
+ $game.put_thing_in('water', 'fire');
+ return $game;
+}
+
+sub game_from_crypt {
+ my $game = game_after_putting_out_the_fire();
+
+ $game.walk('northwest');
+ return $game;
+}
+
+{
+ my $game = Crypt::Game.new();
+
+ is $game.look(),
+ Adventure::PlayerLooked.new(
+ :room<clearing>,
+ :exits<east>,
+ :things<car>,
+ ),
+ 'looking at the room';
+}
+
+{
+ my $game = Crypt::Game.new();
+
+ is $game.walk('east'),
+ [
+ Adventure::PlayerWalked.new(
+ :to<hill>,
+ ),
+ Adventure::PlayerLooked.new(
+ :room<hill>,
+ :exits<west>,
+ :things<brook>,
+ ),
+ ],
+ '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 $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<north>,
+ :things<basket sign>,
+ ),
+ ],
+ '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';
+}
+
+{
+ 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';
+}
+
+{
+ my $game = game_from_chamber();
+
+ is $game.read('sign'),
+ Adventure::PlayerRead.new(
+ :thing<sign>,
+ ),
+ 'reading the sign';
+}
+
+{
+ my $game = game_from_hall();
+
+ is $game.look(),
+ Adventure::PlayerLookedAtDarkness.new(
+ ),
+ 'looking without the flashlight switched on';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ is $game.look(),
+ Adventure::PlayerLooked.new(
+ :room<hall>,
+ :exits<north>,
+ :things<helmet>,
+ ),
+ 'looking with the flashlight switched on';
+}
+
+{
+ my $game = game_from_chamber();
+
+ throws_exception
+ { $game.move('left', 'middle') },
+ X::Crypt::NoDisksHere,
+ 'moving disks in the right room (-)';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ is $game.move('left', 'middle'),
+ Hanoi::DiskMoved.new(
+ :disk('tiny disk'),
+ :source<left>,
+ :target<middle>,
+ ),
+ 'moving disks in the right room (+)';
+}
+
+{
+ my $game = game_after_hanoi_is_solved();
+
+ is $game.walk('down')[0],
+ Adventure::PlayerWalked.new(
+ :to<cave>,
+ ),
+ 'can walk down after solving the hanoi game (+)';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ is $game.take('helmet'),
+ Adventure::PlayerTook.new(
+ :thing<helmet>,
+ ),
+ 'taking the helmet (+)';
+}
+
+{
+ my $game = game_from_hall();
+
+ throws_exception
+ { $game.take('helmet') },
+ X::Adventure::PitchBlack,
+ 'taking the helmet (-) pitch black',
+ {
+ is .action, 'take', '.action attribute';
+ is .message,
+ "You cannot take anything, because it is pitch black",
+ '.message attribute';
+ };
+}
+
+{
+ my $game = game_from_hall();
+
+ throws_exception
+ { $game.examine('helmet') },
+ X::Adventure::PitchBlack,
+ 'examining the helmet (-) pitch black',
+ {
+ is .action, 'see', '.action attribute';
+ is .message,
+ "You cannot see anything, because it is pitch black",
+ '.message attribute';
+ };
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ $game.take('helmet');
+ $game.walk('north');
+ $game.walk('north');
+ is $game.put_thing_in('water', 'helmet'),
+ Adventure::PlayerPutIn.new(
+ :thing<water>,
+ :in<helmet>,
+ ),
+ 'filling the helmet with water';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ $game.take('helmet');
+ $game.walk('north');
+ $game.walk('north');
+ $game.put_thing_in('helmet', 'brook');
+ is $game.take('helmet'),
+ [
+ Adventure::PlayerTook.new(
+ :thing<helmet>,
+ ),
+ Adventure::ThingPlaced.new(
+ :thing<water>,
+ :room<contents:helmet>,
+ ),
+ ],
+ 'picking helmet up from brook fills it with water';
+}
+
+{
+ my $game = Crypt::Game.new();
+
+ $game.walk('east');
+ is $game.take('water'),
+ [
+ Adventure::PlayerTook.new(
+ :thing<water>,
+ ),
+ Adventure::GameRemarked.new(
+ :remark<bare-hands-carry-water>,
+ ),
+ Adventure::PlayerDropped.new(
+ :thing<water>,
+ ),
+ ],
+ 'picking up water with your bare hands fails';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ $game.take('helmet');
+ $game.walk('north');
+ $game.walk('north');
+ $game.put_thing_in('water', 'helmet');
+ $game.walk('west');
+ is $game.put_thing_in('water', 'car'),
+ [
+ Adventure::PlayerPutIn.new(
+ :thing<water>,
+ :in<car>,
+ ),
+ Adventure::GameRemarked.new(
+ :remark<car-is-now-wet>,
+ ),
+ Adventure::ThingPlaced.new(
+ :thing<water>,
+ :room<hill>,
+ ),
+ ],
+ 'putting water into the car';
+}
+
+{
+ my $game = game_after_hanoi_is_solved();
+
+ $game.take('helmet');
+ $game.walk('north');
+ $game.walk('north');
+ $game.put_thing_in('water', 'helmet');
+ $game.walk('south');
+ $game.walk('south');
+ $game.walk('down');
+ is $game.put_thing_in('water', 'fire'),
+ [
+ Adventure::PlayerPutIn.new(
+ :thing<water>,
+ :in<fire>,
+ ),
+ Adventure::GameRemarked.new(
+ :remark<fire-dies>,
+ ),
+ Adventure::ThingHidden.new(
+ :thing<fire>,
+ ),
+ ],
+ 'putting out the fire with water';
+}
+
+{
+ my $game = game_after_putting_out_the_fire();
+
+ is $game.walk('northwest')[0],
+ Adventure::PlayerWalked.new(
+ :to<crypt>,
+ ),
+ 'after water is gone, can walk into crypt';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ $game.take('helmet');
+ $game.walk('north');
+ $game.walk('north');
+ $game.put_thing_in('water', 'helmet');
+ is $game.drop('water'),
+ Adventure::PlayerDropped.new(
+ :thing<water>,
+ ),
+ 'dropping water in the helmet';
+}
+
+{
+ my $game = game_from_crypt();
+
+ is $game.take('butterfly'),
+ [
+ Adventure::PlayerTook.new(
+ :thing<butterfly>,
+ ),
+ Adventure::GameRemarked.new(
+ :remark<alarm-starts>,
+ ),
+ ],
+ 'taking the butterfly triggers an alarm';
+}
+
+{
+ my $game = game_from_crypt();
+
+ $game.take('butterfly');
+ $game.walk('southeast');
+ $game.walk('up');
+ is $game.walk('north'),
+ [
+ Adventure::PlayerWalked.new(
+ :to<chamber>,
+ ),
+ Adventure::GameRemarked.new(
+ :remark<cavern-collapses>,
+ ),
+ Adventure::GameFinished.new(
+ ),
+ ],
+ 'not getting out in time before the cavern collapses';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ is $game.take('tiny disk'),
+ [
+ Adventure::PlayerTook.new(
+ :thing('tiny disk'),
+ ),
+ Hanoi::DiskRemoved.new(
+ :disk('tiny disk'),
+ :source<left>,
+ ),
+ ],
+ 'can take the tiny disk from the hanoi game';
+}
+
+{
+ my $game = game_after_putting_out_the_fire();
+
+ $game.walk('up');
+ $game.take('tiny disk');
+ $game.walk('down');
+ $game.walk('northwest');
+ $game.take('butterfly');
+ $game.put_thing_on('tiny disk', 'pedestal');
+ $game.walk('southeast');
+ $game.walk('up');
+ $game.walk('north');
+ is $game.walk('north'),
+ [
+ Adventure::GameRemarked.new(
+ :remark<made-it-out-with-treasure>,
+ ),
+ Adventure::GameFinished.new(
+ ),
+ ],
+ 'making it out alive with the treasure';
+}
+
+{
+ my $game = Crypt::Game.new();
+
+ is $game.walk('e'),
+ [
+ Adventure::PlayerWalked.new(
+ :to<hill>,
+ ),
+ Adventure::PlayerLooked.new(
+ :room<hill>,
+ :exits<west>,
+ :things<brook>,
+ ),
+ ],
+ 'walking (+) abbreviated directions';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ $game.take('tiny disk');
+ is $game.put_thing_on('tiny disk', 'middle rod'),
+ [
+ Adventure::PlayerPutOn.new(
+ :thing('tiny disk'),
+ :on('middle rod'),
+ ),
+ Hanoi::DiskAdded.new(
+ :disk('tiny disk'),
+ :target<middle>,
+ ),
+ ],
+ 'can put tiny disk back after taking it';
+}
+
+{
+ my $game = game_after_hanoi_is_solved();
+
+ $game.take('tiny disk');
+ $game.move('right', 'middle');
+ $game.move('middle', 'right');
+ is $game.put_thing_on('tiny disk', 'right rod'),
+ [
+ Adventure::PlayerPutOn.new(
+ :thing('tiny disk'),
+ :on('right rod'),
+ ),
+ Hanoi::DiskAdded.new(
+ :disk('tiny disk'),
+ :target('right'),
+ ),
+ Hanoi::AchievementUnlocked.new(
+ ),
+ Adventure::GameRemarked.new(
+ :remark<floor-reveals-hole>,
+ ),
+ Adventure::TwoRoomsConnected.new(
+ :rooms<hall cave>,
+ :direction<down>,
+ ),
+ ],
+ 'can unlock the game by putting the tiny rod back';
+}
+
+{
+ my $game = game_from_hall();
+
+ $game.use('flashlight');
+ $game.take('tiny disk');
+ $game.put_thing_on('tiny disk', 'right rod');
+ is $game.take('tiny disk'),
+ [
+ Adventure::PlayerTook.new(
+ :thing('tiny disk'),
+ ),
+ Hanoi::DiskRemoved.new(
+ :disk<tiny disk>,
+ :source<right>,
+ ),
+ ],
+ 'can take the tiny disk, put it back, and take it again';
+}
+
+done;
View
309 t/hanoi.t
@@ -0,0 +1,309 @@
+use v6;
+use Test;
+use Hanoi::Game;
+
+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';
+ }
+ }
+ }
+}
+
+{
+ 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');
+ { $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;

No commit comments for this range

Something went wrong with that request. Please try again.