Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[crypt.pl] all disks on the right rod => win

This commit is a bit messy, because it got tangled up with a refactor
of 'from'/'to' rods into 'source'/'target' rods. The latter terminology
took over and wanted to be everywhere.
  • Loading branch information...
commit b9caadefe07b226e23aedcf77845f76760603f02 1 parent efa9ba6
Carl Mäsak authored July 01, 2012

Showing 1 changed file with 113 additions and 64 deletions. Show diff stats Hide diff stats

  1. 177  crypt.pl
177  crypt.pl
@@ -12,8 +12,11 @@
12 12
 
13 13
 class DiskMoved does Event {
14 14
     has $.size;
15  
-    has $.from;
16  
-    has $.to;
  15
+    has $.source;
  16
+    has $.target;
  17
+}
  18
+
  19
+class AchievementUnlocked does Event {
17 20
 }
18 21
 
19 22
 class X::Hanoi::LargerOnSmaller is Exception {
@@ -43,27 +46,27 @@
43 46
 }
44 47
 
45 48
 class HanoiGame {
46  
-    my @names = map { "$_ disk" }, <tiny small medium big huge>;
47  
-    my %size_of = @names Z 1..5;
  49
+    my @disks = map { "$_ disk" }, <tiny small medium big huge>;
  50
+    my %size_of = @disks Z 1..5;
48 51
 
49 52
     has %!state =
50  
-        left   => [reverse @names],
  53
+        left   => [reverse @disks],
51 54
         middle => [],
52 55
         right  => [],
53 56
     ;
54 57
 
55  
-    method move($from, $to) {
56  
-        die X::Hanoi::NoSuchRod.new(:rod<source>, :name($from))
57  
-            unless %!state.exists($from);
58  
-        die X::Hanoi::NoSuchRod.new(:rod<target>, :name($to))
59  
-            unless %!state.exists($to);
60  
-        my @from_rod := %!state{$from};
61  
-        die X::Hanoi::RodHasNoDisks.new(:name($from))
62  
-            unless @from_rod;
63  
-        my @to_rod   := %!state{$to};
64  
-        my $moved_disk = @from_rod[*-1];
65  
-        if @to_rod {
66  
-            my $covered_disk = @to_rod[*-1];
  58
+    method move($source, $target) {
  59
+        die X::Hanoi::NoSuchRod.new(:rod<source>, :name($source))
  60
+            unless %!state.exists($source);
  61
+        die X::Hanoi::NoSuchRod.new(:rod<target>, :name($target))
  62
+            unless %!state.exists($target);
  63
+        my @source_rod := %!state{$source};
  64
+        die X::Hanoi::RodHasNoDisks.new(:name($source))
  65
+            unless @source_rod;
  66
+        my @target_rod := %!state{$target};
  67
+        my $moved_disk = @source_rod[*-1];
  68
+        if @target_rod {
  69
+            my $covered_disk = @target_rod[*-1];
67 70
             if %size_of{$moved_disk} > %size_of{$covered_disk} {
68 71
                 die X::Hanoi::LargerOnSmaller.new(
69 72
                     :larger($moved_disk),
@@ -71,9 +74,13 @@
71 74
                 );
72 75
             }
73 76
         }
74  
-        @to_rod.push( @from_rod.pop );
  77
+        @target_rod.push( @source_rod.pop );
75 78
         my $size = $moved_disk.words[0];
76  
-        DiskMoved.new(:$size, :$from, :$to);
  79
+        my @events = DiskMoved.new(:$size, :$source, :$target);
  80
+        if %!state<right> == @disks {
  81
+            @events.push(AchievementUnlocked.new);
  82
+        }
  83
+        return @events;
77 84
     }
78 85
 }
79 86
 
@@ -102,54 +109,96 @@ (&code, $ex_type, &followup?)
102 109
 }
103 110
 
104 111
 multi MAIN('test', 'hanoi') {
105  
-    my $game = HanoiGame.new();
  112
+    {
  113
+        my $game = HanoiGame.new();
  114
+
  115
+        is $game.move('left', 'middle'),
  116
+           DiskMoved.new(:size<tiny>, :source<left>, :target<middle>),
  117
+           'legal move (+)';
  118
+
  119
+        throws_exception
  120
+            { $game.move('left', 'middle') },
  121
+            X::Hanoi::LargerOnSmaller,
  122
+            {
  123
+                is .larger, 'small disk', '.larger attribute';
  124
+                is .smaller, 'tiny disk', '.smaller attribute';
  125
+                is .message,
  126
+                   'Cannot put the small disk on the tiny disk',
  127
+                   '.message attribute';
  128
+            };
  129
+
  130
+        throws_exception
  131
+            { $game.move('gargle', 'middle') },
  132
+            X::Hanoi::NoSuchRod,
  133
+            {
  134
+                is .rod, 'source', '.rod attribute';
  135
+                is .name, 'gargle', '.name attribute';
  136
+                is .message,
  137
+                   q[No such source rod 'gargle'],
  138
+                   '.message attribute';
  139
+            };
  140
+
  141
+        throws_exception
  142
+            { $game.move('middle', 'clown') },
  143
+            X::Hanoi::NoSuchRod,
  144
+            {
  145
+                is .rod, 'target', '.rod attribute';
  146
+                is .name, 'clown', '.name attribute';
  147
+                is .message,
  148
+                   q[No such target rod 'clown'],
  149
+                   '.message attribute';
  150
+            };
  151
+
  152
+        throws_exception
  153
+            { $game.move('right', 'middle') },
  154
+            X::Hanoi::RodHasNoDisks,
  155
+            {
  156
+                is .name, 'right', '.name attribute';
  157
+                is .message,
  158
+                   q[Cannot move from the right rod because there is no disk there],
  159
+                   '.message attribute';
  160
+            };
  161
+    }
106 162
 
107  
-    is $game.move('left', 'middle'),
108  
-       DiskMoved.new(:size<tiny>, :from<left>, :to<middle>),
109  
-       'legal move (+)';
  163
+    {
  164
+        my $game = HanoiGame.new();
  165
+
  166
+        multi hanoi_moves($source, $, $target, 1) {
  167
+            # A single disk, easy; just move it directly.
  168
+            $source, 'to', $target
  169
+        }
  170
+        multi hanoi_moves($source, $helper, $target, $n) {
  171
+            # $n-1 disks on to; move them off to the $helper rod first...
  172
+            hanoi_moves($source, $target, $helper, $n-1),
  173
+            # ...then move over the freed disk at the bottom...
  174
+            hanoi_moves($source, $helper, $target, 1),
  175
+            # ...and finally move the rest from $helper to $target.
  176
+            hanoi_moves($helper, $source, $target, $n-1)
  177
+        }
  178
+
  179
+        # Let's play out the thing to the end. 32 moves.
  180
+        my @moves = hanoi_moves("left", "middle", "right", 5);
  181
+        # RAKUDO: .splice doesn't do WhateverCode yet: wanted *-3
  182
+        my @last_move = @moves.splice(@moves.end-2);
  183
+
  184
+        lives_ok {
  185
+            for @moves -> $source, $, $target {
  186
+                my ($event, @rest) = $game.move($source, $target);
  187
+                die "Unexpected event type: {$event.name}"
  188
+                    unless $event ~~ DiskMoved;
  189
+                die "Unexpected extra events: @rest"
  190
+                    if @rest;
  191
+            }
  192
+        }, 'making all the moves to the end of the game works';
110 193
 
111  
-    throws_exception
112  
-        { $game.move('left', 'middle') },
113  
-        X::Hanoi::LargerOnSmaller,
114  
-        {
115  
-            is .larger, 'small disk', '.larger attribute';
116  
-            is .smaller, 'tiny disk', '.smaller attribute';
117  
-            is .message,
118  
-               'Cannot put the small disk on the tiny disk',
119  
-               '.message attribute';
120  
-        };
121  
-
122  
-    throws_exception
123  
-        { $game.move('gargle', 'middle') },
124  
-        X::Hanoi::NoSuchRod,
125  
-        {
126  
-            is .rod, 'source', '.rod attribute';
127  
-            is .name, 'gargle', '.name attribute';
128  
-            is .message,
129  
-               q[No such source rod 'gargle'],
130  
-               '.message attribute';
131  
-        };
132  
-
133  
-    throws_exception
134  
-        { $game.move('middle', 'clown') },
135  
-        X::Hanoi::NoSuchRod,
136  
-        {
137  
-            is .rod, 'target', '.rod attribute';
138  
-            is .name, 'clown', '.name attribute';
139  
-            is .message,
140  
-               q[No such target rod 'clown'],
141  
-               '.message attribute';
142  
-        };
143  
-
144  
-    throws_exception
145  
-        { $game.move('right', 'middle') },
146  
-        X::Hanoi::RodHasNoDisks,
147 194
         {
148  
-            is .name, 'right', '.name attribute';
149  
-            is .message,
150  
-               q[Cannot move from the right rod because there is no disk there],
151  
-               '.message attribute';
152  
-        };
  195
+            my ($source, $, $target) = @last_move;
  196
+            is $game.move($source, $target), (
  197
+                DiskMoved.new(:size<tiny>, :$source, :$target),
  198
+                AchievementUnlocked.new(),
  199
+            ), 'putting all disks on the right rod unlocks achievement';
  200
+        }
  201
+    }
153 202
 
154 203
     done;
155 204
 }

0 notes on commit b9caade

Please sign in to comment.
Something went wrong with that request. Please try again.