Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 334 lines (292 sloc) 10.407 kb
35435dc Carl Mäsak [crypt.pl] hanoi game, legal move
authored
1 use Test;
2
3 role Event {
4 method Str {
5 sub event() { self.^name }
6 sub name($attr) { $attr.name.substr(2) }
7 sub value($attr) { $attr.get_value(self) }
8
9 "{event}[{map { ":{name $_}<{value $_}>" }, self.^attributes}]"
10 }
11 }
12
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
13 class Hanoi::DiskMoved does Event {
35435dc Carl Mäsak [crypt.pl] hanoi game, legal move
authored
14 has $.size;
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
15 has $.source;
16 has $.target;
17 }
18
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
19 class Hanoi::AchievementUnlocked does Event {
35435dc Carl Mäsak [crypt.pl] hanoi game, legal move
authored
20 }
21
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
22 class Hanoi::AchievementLocked does Event {
96d9cf3 Carl Mäsak [crypt.pl] achievements can be locked, too
authored
23 }
24
a47664c Carl Mäsak [crypt.pl] can remove disks
authored
25 class Hanoi::DiskRemoved does Event {
26 has $.size;
27 has $.source;
28 }
29
b0affd2 Carl Mäsak [crypt.pl] larger disk on smaller not allowed
authored
30 class X::Hanoi::LargerOnSmaller is Exception {
31 has $.larger;
32 has $.smaller;
33
34 method message($_:) {
35 "Cannot put the {.larger} on the {.smaller}"
36 }
37 }
38
4b7c1d2 Carl Mäsak [crypt.pl] can't use rod names which don't exist
authored
39 class X::Hanoi::NoSuchRod is Exception {
40 has $.rod;
41 has $.name;
42
43 method message($_:) {
44 "No such {.rod} rod '{.name}'"
45 }
46 }
47
efa9ba6 Carl Mäsak [crypt.pl] cannot move from a rod with no disks
authored
48 class X::Hanoi::RodHasNoDisks is Exception {
49 has $.name;
50
51 method message($_:) {
52 "Cannot move from the {.name} rod because there is no disk there"
53 }
54 }
55
0a4ebe5 Carl Mäsak [crypt.pl] error when trying to move covered disk
authored
56 class X::Hanoi::CoveredDisk is Exception {
57 has $.disk;
58 has @.covered_by;
59
60 method message($_:) {
61 sub last_and(@things) {
62 map { "{'and ' if $_ == @things.end}@things[$_]" }, ^@things
63 }
64 my $disklist = join ', ', last_and map { "the $_" }, @.covered_by;
65 "Cannot move the {.disk}: it is covered by $disklist"
66 }
67 }
68
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
69 class Hanoi::Game {
0a4ebe5 Carl Mäsak [crypt.pl] error when trying to move covered disk
authored
70 my @disks = map { "$_ disk" }, <tiny small medium large huge>;
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
71 my %size_of = @disks Z 1..5;
b0affd2 Carl Mäsak [crypt.pl] larger disk on smaller not allowed
authored
72
73 has %!state =
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
74 left => [reverse @disks],
b0affd2 Carl Mäsak [crypt.pl] larger disk on smaller not allowed
authored
75 middle => [],
76 right => [],
77 ;
78
6aa70d4 Carl Mäsak [crypt.pl] post-unlocking achievement logic
authored
79 has $!achievement = 'locked';
80
e2a3e5d Carl Mäsak [crypt.pl] allow move syntax specifying disks
authored
81 method move($source is copy, $target) {
82 my @source_rod;
83 if $source eq any @disks {
0a4ebe5 Carl Mäsak [crypt.pl] error when trying to move covered disk
authored
84 my $disk = $source;
e2a3e5d Carl Mäsak [crypt.pl] allow move syntax specifying disks
authored
85 for %!state -> ( :key($rod), :value(@disks) ) {
0a4ebe5 Carl Mäsak [crypt.pl] error when trying to move covered disk
authored
86 if $disk eq any(@disks) {
87 sub smaller_disks {
88 grep { %size_of{$_} < %size_of{$disk} }, @disks;
89 }
90 die X::Hanoi::CoveredDisk.new(:$disk, :covered_by(smaller_disks))
91 unless @disks[*-1] eq $disk;
e2a3e5d Carl Mäsak [crypt.pl] allow move syntax specifying disks
authored
92 @source_rod := @disks;
93 $source = $rod;
94 last;
95 }
96 }
97 }
98 else {
99 die X::Hanoi::NoSuchRod.new(:rod<source>, :name($source))
100 unless %!state.exists($source);
101 @source_rod := %!state{$source};
102 }
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
103 die X::Hanoi::NoSuchRod.new(:rod<target>, :name($target))
104 unless %!state.exists($target);
105 die X::Hanoi::RodHasNoDisks.new(:name($source))
106 unless @source_rod;
107 my @target_rod := %!state{$target};
108 my $moved_disk = @source_rod[*-1];
109 if @target_rod {
110 my $covered_disk = @target_rod[*-1];
b0affd2 Carl Mäsak [crypt.pl] larger disk on smaller not allowed
authored
111 if %size_of{$moved_disk} > %size_of{$covered_disk} {
112 die X::Hanoi::LargerOnSmaller.new(
113 :larger($moved_disk),
114 :smaller($covered_disk)
115 );
116 }
117 }
118 my $size = $moved_disk.words[0];
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
119 my @events = Hanoi::DiskMoved.new(:$size, :$source, :$target);
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
120 if %!state<right> == @disks-1
121 && $target eq 'right'
122 && $!achievement eq 'locked' {
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
123 @events.push(Hanoi::AchievementUnlocked.new);
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
124 }
96d9cf3 Carl Mäsak [crypt.pl] achievements can be locked, too
authored
125 if $size eq 'small' && $!achievement eq 'unlocked' {
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
126 @events.push(Hanoi::AchievementLocked.new);
96d9cf3 Carl Mäsak [crypt.pl] achievements can be locked, too
authored
127 }
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
128 self!apply($_) for @events;
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
129 return @events;
b0affd2 Carl Mäsak [crypt.pl] larger disk on smaller not allowed
authored
130 }
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
131
a47664c Carl Mäsak [crypt.pl] can remove disks
authored
132 method remove($disk) {
133 my $size = $disk.words[0];
134 my $source;
135 for %!state -> ( :key($rod), :value(@disks) ) {
136 if $disk eq any(@disks) {
137 $source = $rod;
138 last;
139 }
140 }
141 my @events = Hanoi::DiskRemoved.new(:$size, :$source);
142 self!apply($_) for @events;
143 return @events;
144 }
145
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
146 # RAKUDO: private multimethods NYI
147 method !apply(Event $_) {
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
148 when Hanoi::DiskMoved {
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
149 my @source_rod := %!state{.source};
150 my @target_rod := %!state{.target};
151 @target_rod.push( @source_rod.pop );
152 }
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
153 when Hanoi::AchievementUnlocked {
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
154 $!achievement = 'unlocked';
155 }
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
156 when Hanoi::AchievementLocked {
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
157 $!achievement = 'locked';
158 }
a47664c Carl Mäsak [crypt.pl] can remove disks
authored
159 when Hanoi::DiskRemoved {
160 my @source_rod := %!state{.source};
161 @source_rod.pop;
162 }
caea86f Carl Mäsak [crypt.pl] refactor - private apply method
authored
163 }
b0affd2 Carl Mäsak [crypt.pl] larger disk on smaller not allowed
authored
164 }
165
66e182d Carl Mäsak [crypt.pl] test function refactor
authored
166 sub throws_exception(&code, $ex_type, $message, &followup?) {
b0affd2 Carl Mäsak [crypt.pl] larger disk on smaller not allowed
authored
167 &code();
168 ok 0, $message;
169 if &followup {
170 diag 'Not running followup because an exception was not triggered';
171 }
172 CATCH {
173 default {
174 ok 1, $message;
175 my $type_ok = $_.WHAT === $ex_type;
176 ok $type_ok , "right exception type ({$ex_type.^name})";
177 if $type_ok {
178 &followup($_);
179 } else {
180 diag "Got: {$_.WHAT.gist}\n"
181 ~"Expected: {$ex_type.gist}";
182 diag "Exception message: $_.message()";
183 diag 'Not running followup because type check failed';
184 }
185 }
35435dc Carl Mäsak [crypt.pl] hanoi game, legal move
authored
186 }
187 }
188
189 multi MAIN('test', 'hanoi') {
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
190 {
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
191 my $game = Hanoi::Game.new();
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
192
193 is $game.move('left', 'middle'),
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
194 Hanoi::DiskMoved.new(:size<tiny>, :source<left>, :target<middle>),
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
195 'legal move (+)';
196
197 throws_exception
198 { $game.move('left', 'middle') },
199 X::Hanoi::LargerOnSmaller,
66e182d Carl Mäsak [crypt.pl] test function refactor
authored
200 'legal move (-) larger disk on smaller',
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
201 {
202 is .larger, 'small disk', '.larger attribute';
203 is .smaller, 'tiny disk', '.smaller attribute';
204 is .message,
205 'Cannot put the small disk on the tiny disk',
206 '.message attribute';
207 };
208
209 throws_exception
210 { $game.move('gargle', 'middle') },
211 X::Hanoi::NoSuchRod,
66e182d Carl Mäsak [crypt.pl] test function refactor
authored
212 'legal move (-) no such source rod',
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
213 {
214 is .rod, 'source', '.rod attribute';
215 is .name, 'gargle', '.name attribute';
216 is .message,
217 q[No such source rod 'gargle'],
218 '.message attribute';
219 };
220
221 throws_exception
222 { $game.move('middle', 'clown') },
223 X::Hanoi::NoSuchRod,
66e182d Carl Mäsak [crypt.pl] test function refactor
authored
224 'legal move (-) no such target rod',
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
225 {
226 is .rod, 'target', '.rod attribute';
227 is .name, 'clown', '.name attribute';
228 is .message,
229 q[No such target rod 'clown'],
230 '.message attribute';
231 };
232
233 throws_exception
234 { $game.move('right', 'middle') },
235 X::Hanoi::RodHasNoDisks,
66e182d Carl Mäsak [crypt.pl] test function refactor
authored
236 'legal move (-) rod has no disks',
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
237 {
238 is .name, 'right', '.name attribute';
239 is .message,
240 q[Cannot move from the right rod because there is no disk there],
241 '.message attribute';
242 };
243 }
35435dc Carl Mäsak [crypt.pl] hanoi game, legal move
authored
244
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
245 {
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
246 my $game = Hanoi::Game.new();
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
247
248 multi hanoi_moves($source, $, $target, 1) {
249 # A single disk, easy; just move it directly.
250 $source, 'to', $target
251 }
252 multi hanoi_moves($source, $helper, $target, $n) {
253 # $n-1 disks on to; move them off to the $helper rod first...
254 hanoi_moves($source, $target, $helper, $n-1),
255 # ...then move over the freed disk at the bottom...
256 hanoi_moves($source, $helper, $target, 1),
257 # ...and finally move the rest from $helper to $target.
258 hanoi_moves($helper, $source, $target, $n-1)
259 }
260
261 # Let's play out the thing to the end. 32 moves.
262 my @moves = hanoi_moves("left", "middle", "right", 5);
263 # RAKUDO: .splice doesn't do WhateverCode yet: wanted *-3
264 my @last_move = @moves.splice(@moves.end-2);
265
266 lives_ok {
267 for @moves -> $source, $, $target {
268 my ($event, @rest) = $game.move($source, $target);
269 die "Unexpected event type: {$event.name}"
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
270 unless $event ~~ Hanoi::DiskMoved;
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
271 die "Unexpected extra events: @rest"
272 if @rest;
273 }
274 }, 'making all the moves to the end of the game works';
35435dc Carl Mäsak [crypt.pl] hanoi game, legal move
authored
275
efa9ba6 Carl Mäsak [crypt.pl] cannot move from a rod with no disks
authored
276 {
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
277 my ($source, $, $target) = @last_move;
278 is $game.move($source, $target), (
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
279 Hanoi::DiskMoved.new(:size<tiny>, :$source, :$target),
280 Hanoi::AchievementUnlocked.new(),
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
281 ), 'putting all disks on the right rod unlocks achievement';
6aa70d4 Carl Mäsak [crypt.pl] post-unlocking achievement logic
authored
282
283 $game.move($target, $source);
284 is $game.move($source, $target), (
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
285 Hanoi::DiskMoved.new(:size<tiny>, :$source, :$target),
6aa70d4 Carl Mäsak [crypt.pl] post-unlocking achievement logic
authored
286 ), 'moving things back and forth does not unlock achievement again';
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
287 }
96d9cf3 Carl Mäsak [crypt.pl] achievements can be locked, too
authored
288
289 {
290 $game.move('right', 'middle');
291 is $game.move(my $source = 'right', my $target = 'left'), (
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
292 Hanoi::DiskMoved.new(:size<small>, :$source, :$target),
293 Hanoi::AchievementLocked.new(),
96d9cf3 Carl Mäsak [crypt.pl] achievements can be locked, too
authored
294 ), 'removing two disks from the right rod locks achievement';
295 }
b9caade Carl Mäsak [crypt.pl] all disks on the right rod => win
authored
296 }
efa9ba6 Carl Mäsak [crypt.pl] cannot move from a rod with no disks
authored
297
e2a3e5d Carl Mäsak [crypt.pl] allow move syntax specifying disks
authored
298 {
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
299 my $game = Hanoi::Game.new();
e2a3e5d Carl Mäsak [crypt.pl] allow move syntax specifying disks
authored
300
301 is $game.move('tiny disk', my $target = 'middle'),
df311c2 Carl Mäsak [crypt.pl] name refactor: Hanoi::
authored
302 Hanoi::DiskMoved.new(:size<tiny>, :source<left>, :$target),
e2a3e5d Carl Mäsak [crypt.pl] allow move syntax specifying disks
authored
303 'naming source disk instead of the rod (+)';
304 }
305
0a4ebe5 Carl Mäsak [crypt.pl] error when trying to move covered disk
authored
306 {
307 my $game = Hanoi::Game.new();
308
309 throws_exception
310 { $game.move('large disk', 'right') },
311 X::Hanoi::CoveredDisk,
312 'naming source disk instead of the rod (-)',
313 {
314 is .disk, 'large disk', '.disk attribute';
315 is .covered_by, ['medium disk', 'small disk', 'tiny disk'],
316 '.covered_by attribute';
317 is .message,
318 'Cannot move the large disk: it is covered by '
319 ~ 'the medium disk, the small disk, and the tiny disk',
320 '.message attribute';
321 };
322 }
323
a47664c Carl Mäsak [crypt.pl] can remove disks
authored
324 {
325 my $game = Hanoi::Game.new();
326
327 is $game.remove('tiny disk'),
328 Hanoi::DiskRemoved.new(:size<tiny>, :source<left>),
329 'removing a disk (+)';
330 }
331
35435dc Carl Mäsak [crypt.pl] hanoi game, legal move
authored
332 done;
333 }
Something went wrong with that request. Please try again.