Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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