Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 1138 lines (956 sloc) 30.556 kb
489c0bc @masak big reorganization
authored
1 ## Predeclarations
2
3 role Thing { ... }
4
5 role Container { ... }
6 role Darkness { ... }
7 role Heavy { ... }
8 role Implicit { ... }
9 role Openable { ... }
10 role Platform { ... }
11 role Readable { ... }
12 role Showable { ... }
13 role Takable { ... }
14
15 class Basket { ... }
16 class Brook { ... }
17 class Bushes { ... }
18 class Butterfly { ... }
19 class Car { ... }
20 class Disk { ... }
21 class Doom { ... }
22 class Door { ... }
23 class Fire { ... }
24 class Flashlight { ... }
25 class Grass { ... }
26 class Helmet { ... }
27 class Inventory { ... }
28 class Leaves { ... }
29 class Pedestal { ... }
30 class Rope { ... }
31 class Sarcophagi { ... }
32 class Sign { ... }
33 class Trees { ... }
34 class Walls { ... }
35 class Water { ... }
36
37 role Room { ... }
38
39 class Cave { ... }
40 class Crypt { ... }
41 class Hall { ... }
42 class Hill { ... }
43
44 ## Global variables
5675bb8 @masak initial commit
authored
45
489c0bc @masak big reorganization
authored
46 my %descriptions;
47 for slurp("descriptions").split(/\n\n/) {
48 /^^ '== ' (\N+) \n (.*)/
49 or die "Could not parse 'descriptions' file: $_";
50 %descriptions{$0} = ~$1;
51 }
52
53 my $room;
54 my $inventory = Inventory.new();
55 my $used_abbreviated_syntax = False;
56
57 my %things =
58 car => Car.new(:name<car>, :contents<flashlight rope>,
59 :herephrase("Your %s is parked here.")),
60 flashlight => Flashlight.new(:name<flashlight>),
61 rope => Rope.new(:name<rope>),
62 grass => Grass.new(:name<grass>),
63 bushes => Bushes.new(:name<bushes>),
64 door => Door.new(:name<door>),
65 trees => Trees.new(:name<trees>),
66 leaves => Leaves.new(:name<leaves>,
67 :containphrase("69,105 %s.")),
68 brook => Brook.new(:name<brook>,
69 :herephrase("A small brook runs through the forest.")),
70 water => Water.new(:name<water>, :containphrase("Some %s.")),
71 sign => Sign.new(:name<sign>),
72 basket => Basket.new(:name<basket>),
4399b6d @masak don't need those :size ctor attrs
authored
73 "tiny disk" => Disk.new(:name("tiny disk")),
74 "small disk" => Disk.new(:name("small disk")),
75 "medium disk" => Disk.new(:name("medium disk")),
76 "large disk" => Disk.new(:name("large disk")),
77 "huge disk" => Disk.new(:name("huge disk")),
489c0bc @masak big reorganization
authored
78 fire => Fire.new(:name<fire>),
79 helmet => Helmet.new(:name<helmet>),
80 pedestal => Pedestal.new(:name<pedestal>, :supports<butterfly>),
81 butterfly => Butterfly.new(:name<butterfly>),
82 doom => Doom.new(),
83 sarcophagi => Sarcophagi.new(:name<sarcophagi>),
84 walls => Walls.new(:name<walls>),
85 ;
86
87 my %rooms =
88 clearing => Room.new( :name<clearing>, :contents<car> ),
89 hill => Hill.new( :name<hill>,
90 :contents<door trees leaves grass bushes brook
91 water>,
92 :in<south> ),
93 chamber => Room.new( :name(<chamber>), :contents<sign basket walls>,
94 :out<north> ),
95 hall => Hall.new( :name(<hall>),
96 :contents(<helmet walls>, map { "$_ disk" },
97 <tiny small medium large huge>)),
98 cave => Cave.new( :name(<cave>), :contents<fire walls> ),
99 crypt => Crypt.new( :name(<crypt>), :contents<pedestal walls> ),
100 ;
101 %things.push(%rooms);
102
103 %rooms<clearing>.connect('east', %rooms<hill>);
104 %rooms<cave>.connect('northwest', %rooms<crypt>);
105
106 my @base_verbs = <examine open close take drop read go use put>;
107 my %verb_synonyms =
108 "x" => "examine",
109 "look" => "examine",
110 "pick" => "take",
111 "pick up" => "take",
112 "get" => "take",
113 "retrieve" => "take",
114 "retreive" => "take", # might as well
115 "turn on" => "use",
116 "switch on" => "use",
117 ;
118 my @verbs = @base_verbs, %verb_synonyms.keys;
119
120 ## Utility subroutines
121
122 sub exclude(@l, $e) { grep { $_ !=== $e }, @l }
123
124 sub inverse_index(@array, $value) {
125 my $index = @array.keys.first({ @array[$_] eq $value });
126 return $index;
127 }
128
129 sub current_container_of(Str $name) {
130 return $room if $name eq $room.name.lc;
131 return $room if $name eq any $room.contents;
132 return $inventory if $name eq any $inventory.contents;
133 for %things{$room.contents, $inventory.contents} -> $thing {
134 return $thing if $name eq any $thing.?contents;
135 return $thing if $name eq any $thing.?supports;
136 }
137 return Nil;
138 }
139
140 sub room_contains(Str $name) {
141 return current_container_of($name).?name eq any $room.name, $room.contents;
142 }
143
144 sub inventory_contains(Str $name) {
145 return True if $name eq any $inventory.contents;
146 return True if $name eq any map { .contents.flat },
147 grep { player_can_see_inside($_) },
148 %things{$inventory.contents};
149 return False;
150 }
151
152 sub player_can_see(Thing $thing) {
153 my $thing_is_visible = $thing !~~ Showable || $thing.is_visible;
154
155 return False unless $thing_is_visible;
156 return False unless room_contains($thing.name)
157 || inventory_contains($thing.name);
158
159 return True;
160 }
161
162 sub player_can_see_inside(Thing $thing) {
163 my $thing_is_open = $thing ~~ Container
164 && ($thing !~~ Openable || $thing.is_open);
165
166 return False unless $thing_is_open;
167 return False unless player_can_see($thing);
168
169 return True;
170 }
171
172 sub there_is_light() {
173 my $there_is_sun = $room !~~ Darkness;
174 return True if $there_is_sun;
175
176 my $flashlight = %things<flashlight>;
177 my $flashlight_is_here = player_can_see($flashlight);
178 return True if $flashlight_is_here && $flashlight.is_on;
179
180 my $fire = %things<fire>;
181 my $fire_is_here = player_can_see($fire);
182 return True if $fire_is_here;
183
184 return False;
185 }
186
187 ## Roles for things and rooms
188
189 role Thing {
190 has Str $.name;
191 has Str $!description = %descriptions{$.name};
192 has Str $.herephrase;
193 has Str $.containphrase;
194
195 method examine {
196 if there_is_light() {
197 say $!description;
198 self.?on_examine;
199 }
200 else {
201 say "You can't see anything, because it's pitch black.";
202 }
203 }
204 }
205
206 role Container does Thing {
207 has Thing @.contents is rw;
208
209 method add(Str $name) {
210 @.contents.push($name);
211 }
212
213 method remove(Str $name) {
214 @.contents = exclude(@.contents, $name);
215 }
216
217 method list_contents($herephrase) {
218 for %things{@.contents} -> Thing $thing {
219 if player_can_see($thing) {
220 next if $thing ~~ Implicit;
221 say sprintf $thing.herephrase // $herephrase, $thing.name;
222 if player_can_see_inside($thing) && $thing.contents {
223 say "The $thing.name() contains:";
224 $thing.list_container_contents("A %s.");
225 }
226 if $thing ~~ Platform && $thing.supports {
227 say "On the $thing.name() you see:";
228 $thing.list_platform_supports("A %s.");
229 }
230 }
231 }
232 }
233
234 method list_container_contents($containphrase, $indent = 1) {
235 for %things{@.contents} -> Thing $thing {
236 say ' ' x $indent,
237 sprintf $thing.containphrase // $containphrase, $thing.name;
238 if player_can_see_inside($thing) && $thing.contents {
239 say ' ' x $indent, "The $thing.name() contains:";
240 $thing.list_container_contents("A %s.", $indent + 1);
241 }
242 }
243 }
244
245 method on_open {
e0c0275 @masak don't show contents if there isn't any
authored
246 if @.contents {
247 say "Opening the $.name reveals a {join " and a ", @.contents}.";
248 }
489c0bc @masak big reorganization
authored
249 }
250 }
251
252 role Darkness does Room {
253 }
254
255 role Heavy does Thing {
256 method on_remove_from($_) {
257 when Platform {
258 unless grep Heavy, %things<pedestal>.supports {
259 say "An alarm starts sounding in the whole cavern.";
260 %things<doom>.activate;
261 }
262 }
263 }
264
265 method on_put($_) {
266 when Platform {
267 say "The alarm stops.";
268 %things<doom>.inactivate;
269 }
270 }
271 }
272
273 role Implicit does Thing {
274 }
275
276 role Openable does Thing {
277 has Bool $.is_open;
278
279 method open {
280 if $.is_open {
281 say "The $.name is open.";
282 return;
283 }
284 say "You open the $.name.";
285 $!is_open = True;
286 self.?on_open;
287 }
288
289 method close {
290 unless $.is_open {
291 say "The $.name is closed.";
292 return;
293 }
294 say "You close the $.name.";
295 $!is_open = False;
296 self.?on_close;
297 }
298 }
299
300 role Platform does Thing {
301 has Thing @.supports is rw;
302
303 method add(Str $name) {
304 @.supports.push($name);
305 }
306
307 method remove(Str $name) {
308 @.supports = exclude(@.supports, $name);
309 }
310
311 method list_platform_supports($containphrase, $indent = 1) {
312 for %things{@.supports} -> Thing $thing {
313 say ' ' x $indent,
314 sprintf $thing.containphrase // $containphrase, $thing.name;
315 if player_can_see_inside($thing) && $thing.contents {
316 say ' ' x $indent, "The $thing.name() contains:";
317 $thing.list_container_contents("A %s.", $indent + 1);
318 }
319 }
320 }
321 }
322
323 role Readable does Thing {
324 method read {
325 self.examine;
326 }
327 }
328
329 role Showable does Thing {
330 has Bool $.is_visible = False;
331
332 method show {
333 unless $.is_visible {
334 $!is_visible = True;
335 self.?on_show;
336 }
337 }
338 }
339
340 role Takable does Thing {
341 method put($new_receiver) {
342 my $old_receiver = current_container_of($.name);
343 $old_receiver.remove($.name);
344 self.?on_remove_from($old_receiver);
345
346 $new_receiver.add($.name);
347 self.?on_put($new_receiver);
348 }
349
350 method take {
351 if inventory_contains($.name) {
352 say "You are already holding the $.name";
353 return;
354 }
355 say "You take the $.name.";
356 self.put($inventory);
357 }
358
359 method drop {
360 unless inventory_contains($.name) {
361 say "You are not holding the $.name";
362 return;
363 }
364 say "You drop the $.name on the ground.";
365 self.put($room);
366 }
367 }
368
369 ## Things
370
371 class Basket does Container {
372 }
373
374 class Brook does Container {
375 }
376
377 class Bushes does Implicit {
378 method on_examine {
379 %things<door>.show;
380 }
381 }
382
383 class Butterfly does Takable does Heavy {
384 }
385
386 class Car does Openable does Container {
387 method go {
388 say "You get in the car, but then remember that you haven't found";
389 say "the treasure yet, so you get out again.";
390 }
391 }
392
393 class Disk does Takable does Heavy {
394 }
395
396 class Doom {
397 has Bool $.activated = False;
398 has Int $!time_left;
399
400 method activate {
401 $!activated = True;
402 $!time_left = 4;
403 }
404
405 method inactivate {
406 $!activated = False;
407 }
408
409 method tick {
410 if $!activated {
411 $!time_left--;
412 unless $!time_left {
413 say "The alarm starts sounding louder.";
414 say "The whole cavern shakes, and falls in on itself.";
415 say "You die.";
416 last;
417 }
418 }
419 }
420 }
421
422 class Door does Showable does Openable {
423 method on_show {
424 say "You discover a door in the hill, under the thick grass!";
425 }
426
427 method on_open {
428 say "You can see into the hill now!";
429 %rooms<hill>.connect('south', %rooms<chamber>);
430 }
431
432 method on_close {
433 %rooms<hill>.disconnect('south');
434 }
435 }
436
437 class Fire does Container {
438 }
439
440 class Flashlight does Takable {
441 has Bool $.is_on = False;
442
443 method use {
444 if $.is_on {
445 say "It's already switched on.";
446 }
447 my $was_dark = !there_is_light;
448 $!is_on = True;
449 say "You switch on the flashlight.";
450 if $was_dark {
451 say "";
452 $room.look;
453 }
454 }
455
456 method examine {
457 self.Thing::examine;
458 say "";
459 say "The $.name is switched {$.is_on ?? "on" !! "off"}.";
460 }
461 }
462
463 class Grass does Implicit {
464 method on_examine {
465 %things<door>.show;
466 }
467 }
468
95dba59 @masak make 'walls' not show in Hall
authored
469 class Helmet does Container does Takable {
489c0bc @masak big reorganization
authored
470 method on_remove_from(Container $_) {
471 when Brook {
472 %things<water>.put(self);
473 }
474 }
475 }
476
477 class Inventory does Container {
478 }
479
480 class Leaves does Implicit does Takable {
481 method on_put(Container $_) {
482 when Car {
483 say "Great. Now your car is full of leaves.";
484 }
485 when Basket {
486 say "The ground rumbles and shakes a bit.";
487 say "A passageway opens up to the south, into the caverns.";
488 %rooms<chamber>.connect('south', %rooms<hall>);
489 }
490 when Fire {
491 say "The leaves burn up within seconds.";
492 }
493 }
494 }
495
496 class Pedestal does Platform {
497 }
498
499 class Rope does Takable {
500 }
5675bb8 @masak initial commit
authored
501
489c0bc @masak big reorganization
authored
502 class Sarcophagi does Implicit {
503 }
5675bb8 @masak initial commit
authored
504
489c0bc @masak big reorganization
authored
505 class Sign does Readable {
506 }
507
508 class Trees does Implicit {
509 }
510
511 class Walls does Implicit does Readable {
512 method examine {
513 say %descriptions{"walls:$room.name()"}.lines.pick;
514 self.?on_examine;
515 }
516 }
517
518 class Water does Implicit does Takable {
519 method on_put($_) {
520 when Inventory {
521 say "Your bare hands aren't very good at carrying water.";
522 self.drop;
523 }
524 when Fire {
525 say "The fire wanes and dies.";
526 $room.remove("fire");
527 }
528 }
00d76ac @masak added descriptions of rooms
authored
529 }
530
489c0bc @masak big reorganization
authored
531 ## Directions
532
5675bb8 @masak initial commit
authored
533 my @directions = <
534 north south east west
535 northeast northwest southeast southwest
536 up down in out
537 >;
538
539 my %abbr_directions = <
540 n north
541 s south
542 e east
543 w west
544 ne northeast
545 nw northwest
546 se southeast
547 sw southwest
548 u up
549 d down
550 >;
551
a4c71b8 @masak used the Direction subtype more
authored
552 # RAKUDO: Have to repeat the list here because of a scoping bug [perl #95500]
553 subset Direction of Str where any(<
554 north south east west
555 northeast northwest southeast southwest
556 up down in out
557 >);
5675bb8 @masak initial commit
authored
558
559 sub opposite_direction(Direction $d) {
560 my %opposites =
561 'north' => 'south',
562 'east' => 'west',
563 'northeast' => 'southwest',
564 'northwest' => 'southeast',
565 'up' => 'down',
566 'in' => 'out',
567 ;
568
569 %opposites.push( %opposites.invert );
570
571 %opposites{$d};
572 }
573
489c0bc @masak big reorganization
authored
574 ## Rooms
00cfea1 @masak and there was light
authored
575
489c0bc @masak big reorganization
authored
576 role Room does Container {
7008360 @masak [crypt.pl] much more hacking
authored
577 has Direction %.exits is rw;
578 has Direction $.in;
579 has Direction $.out;
580 has Bool $!visited = False;
581
582 method connect(Direction $direction, Room $other_room) {
583 my $opposite = opposite_direction($direction);
584 self.exits{$direction} = $other_room;
585 $other_room.exits{$opposite} = self;
586 }
5675bb8 @masak initial commit
authored
587
7008360 @masak [crypt.pl] much more hacking
authored
588 method disconnect(Direction $direction) {
5675bb8 @masak initial commit
authored
589 my $opposite = opposite_direction($direction);
7008360 @masak [crypt.pl] much more hacking
authored
590 my $other_room = self.exits.delete($direction);
4ed88ad @masak fix disconnect unconnected room bug
authored
591 if $other_room {
592 $other_room.exits.delete($opposite);
593 }
5675bb8 @masak initial commit
authored
594 }
595
00cfea1 @masak and there was light
authored
596 method list_exits {
7008360 @masak [crypt.pl] much more hacking
authored
597 given %.exits {
2a0cae0 @masak diverse refactors
authored
598 when 0 {
599 say "There are no obvious exits from here.";
600 }
7008360 @masak [crypt.pl] much more hacking
authored
601 when 1 {
2a0cae0 @masak diverse refactors
authored
602 say "You can go {.keys}.";
7008360 @masak [crypt.pl] much more hacking
authored
603 }
604 when 2 {
2a0cae0 @masak diverse refactors
authored
605 say "You can go {.keys.join(" and ")}.";
7008360 @masak [crypt.pl] much more hacking
authored
606 }
2a0cae0 @masak diverse refactors
authored
607 default {
608 say "You can go {.keys[0..*-2].join(", ")} and {.keys[*-1]}.";
7008360 @masak [crypt.pl] much more hacking
authored
609 }
610 }
5675bb8 @masak initial commit
authored
611 }
612
00cfea1 @masak and there was light
authored
613 method look {
614 if there_is_light() {
00d76ac @masak added descriptions of rooms
authored
615 self.examine;
00cfea1 @masak and there was light
authored
616 self.list_contents("There is a %s here.");
617 self.list_exits;
618 }
619 else {
620 say "It is pitch black.";
621 }
622 }
623
5675bb8 @masak initial commit
authored
624 method enter {
489c0bc @masak big reorganization
authored
625 say $!name.ucfirst;
c260ea3 @masak changes and refactors
authored
626 $room = self;
489c0bc @masak big reorganization
authored
627
628 unless $!visited {
629 say "";
630 self.look;
f9135fe @masak implemented doom and ultimate rescue
authored
631 }
632
489c0bc @masak big reorganization
authored
633 $!visited = True;
634 self.?on_enter;
635 if %things<doom>.activated {
636 say "An alarm is sounding.";
f9135fe @masak implemented doom and ultimate rescue
authored
637 }
3f699c4 @masak many additions
authored
638 }
639 }
640
489c0bc @masak big reorganization
authored
641 class Hill does Room {
642 method on_enter {
643 if inventory_contains 'butterfly' {
644 say "Congratulations! You found the treasure and got out with it ",
645 "alive!";
646 last;
c42de50 @masak object description
authored
647 }
648 }
649 }
650
489c0bc @masak big reorganization
authored
651 class Cave does Room does Darkness {
652 method on_try_exit($direction) {
653 if $direction eq "northwest" && player_can_see(%things<fire>) {
654 say "You try to walk past the fire, but it's too hot!";
655 return False;
656 }
657 return True;
658 }
95e6379 @masak introduced Towers of Hanoi game
authored
659 }
660
489c0bc @masak big reorganization
authored
661 class Crypt does Room does Darkness {
7e77250 @masak supported 'put left disk on right rod' syntax
authored
662 }
663
95e6379 @masak introduced Towers of Hanoi game
authored
664 class Hall does Room does Darkness {
665 has @!disks =
666 [5, 4, 3, 2, 1],
667 [],
668 [],
669 ;
7e77250 @masak supported 'put left disk on right rod' syntax
authored
670 has $!moves_made = 0;
671 my @sizes = <. tiny small medium large huge>;
95e6379 @masak introduced Towers of Hanoi game
authored
672 my @rods = <left middle right>;
673
674 method list_contents($herephrase) {
f9135fe @masak implemented doom and ultimate rescue
authored
675 say "There are rods stuck in the floor with disks on them, ",
676 "like this:";
677 self.show_disks;
678 say "";
95e6379 @masak introduced Towers of Hanoi game
authored
679 for %things{@.contents} -> Thing $thing {
680 next if $thing ~~ Disk;
95dba59 @masak make 'walls' not show in Hall
authored
681 next if $thing ~~ Implicit;
95e6379 @masak introduced Towers of Hanoi game
authored
682 if player_can_see($thing) {
683 say sprintf $thing.herephrase // $herephrase, $thing.name;
684 }
685 }
686 }
687
688 method show_disks {
689 say "";
690 my $indent = " ";
691 my @c =
692 " | ",
693 " === ",
694 " ===== ",
695 " ======= ",
696 " ========= ",
697 "===========",
698 ;
699 for reverse 0..5 -> $row {
700 say $indent, join " ", map { @c[@!disks[$_][$row] // 0] }, 0..2;
701 }
702 say $indent, "-" x 37;
703 say $indent, join " ", map { " $_ " }, <A B C>;
704 }
705
706 method take_disk(Str $adjective) {
707 my $size = inverse_index(@sizes, $adjective);
708 my $old_rod = first { $size == any @!disks[$_].list }, 0..2;
709
710 if defined $old_rod {
711 if @!disks[$old_rod][*-1] != $size {
712 say "You can't take the $adjective disk, because it is under ",
713 (join " and ", map { "the @sizes[$_] disk" },
714 grep { $_ < $size }, @!disks[$old_rod].list), ".";
715 return;
716 }
2d63d8b @masak player no longer allowed to take (heavy) disks
authored
717 }
718 unless $adjective eq "tiny" {
719 say "The $adjective disk is too heavy to carry!";
720 return;
95e6379 @masak introduced Towers of Hanoi game
authored
721 }
722
723 %things{"$adjective disk"}.take;
724
725 if defined $old_rod {
2d63d8b @masak player no longer allowed to take (heavy) disks
authored
726 pop @!disks[$old_rod];
95e6379 @masak introduced Towers of Hanoi game
authored
727 self.?on_move_disk($old_rod);
728 }
729 }
730
731 method move_disk_to_rod(Str $adjective, Str $position) {
732 my $size = inverse_index(@sizes, $adjective);
733 my $old_rod = first { $size == any @!disks[$_].list }, 0..2;
734
735 if defined $old_rod && @!disks[$old_rod][*-1] != $size {
736 say "You can't take the $adjective disk, because it is under ",
737 (join " and ", map { "the @sizes[$_] disk" },
738 grep { $_ < $size }, @!disks[$old_rod].list), ".";
739 return;
740 }
741
742 my $new_rod = inverse_index(@rods, $position);
743 if @!disks[$new_rod] {
744 if @!disks[$new_rod][*-1] == $size {
745 say "The $adjective disk is already on the $position rod.";
746 return;
747 }
748 elsif @!disks[$new_rod][*-1] < $size {
749 say "A sense of dread fills you as you attempt to put a ",
750 "bigger disk on a smaller one.";
751 return;
752 }
753 }
754
755 if defined $old_rod {
756 pop @!disks[$old_rod];
757 }
758
f9135fe @masak implemented doom and ultimate rescue
authored
759 %things{"$adjective disk"}.put($room);
95e6379 @masak introduced Towers of Hanoi game
authored
760 push @!disks[$new_rod], $size;
761
762 say "You put the $adjective disk on the $position rod.";
763 self.show_disks;
764
765 if defined $old_rod {
7e77250 @masak supported 'put left disk on right rod' syntax
authored
766 $!moves_made++;
767 self.suggest_short_syntax($old_rod, $new_rod);
95e6379 @masak introduced Towers of Hanoi game
authored
768 }
769
770 self.?on_move_disk($old_rod);
771 }
772
773 method move_rod_to_rod(Int $old_rod, Int $new_rod) {
774 unless @!disks[$old_rod] {
775 say "The {@rods[$old_rod]} rod is empty.";
776 return;
777 }
778
779 my $size = @!disks[$old_rod][*-1];
780 if @!disks[$new_rod] {
781 if @!disks[$new_rod][*-1] < $size {
782 say "A sense of dread fills you as you attempt to put a ",
783 "bigger disk on a smaller one.";
784 return;
785 }
786 }
787
788 pop @!disks[$old_rod];
789 push @!disks[$new_rod], $size;
790
791 my $adjective = @sizes[$size];
792 my $position = @rods[$new_rod];
793
794 say "You put the $adjective disk on the $position rod.";
795 self.show_disks;
796
7e77250 @masak supported 'put left disk on right rod' syntax
authored
797 $!moves_made++;
798 self.suggest_short_syntax($old_rod, $new_rod);
95e6379 @masak introduced Towers of Hanoi game
authored
799 self.?on_move_disk($old_rod);
800 }
801
7e77250 @masak supported 'put left disk on right rod' syntax
authored
802 method suggest_short_syntax($old_rod, $new_rod) {
803 if 3 <= $!moves_made < 5 && !$used_abbreviated_syntax {
804 my $abbr = chr(ord("A") + $old_rod) ~ chr(ord("A") + $new_rod);
805 say "(You can also write this move as $abbr)";
806 }
807 }
808
95e6379 @masak introduced Towers of Hanoi game
authored
809 method on_move_disk($old_rod) {
0703125 @masak it looks nicer like this
authored
810 sub hole_is_revealed { %rooms<hall>.exits.exists("down") }
811
95e6379 @masak introduced Towers of Hanoi game
authored
812 if @!disks[2] == 5 {
813 say "The whole floor tips, and reveals a hole beneath the wall.";
814 %rooms<hall>.connect('down', %rooms<cave>);
815 }
816
2b4fc52 @masak only tip floor back if exit exposed
authored
817 if defined $old_rod && $old_rod == 2 && @!disks[2] == 3
0703125 @masak it looks nicer like this
authored
818 && hole_is_revealed() {
819
95e6379 @masak introduced Towers of Hanoi game
authored
820 say "The whole floor tips back, hiding the hole again.";
821 %rooms<hall>.disconnect('down');
822 }
823 }
824 }
825
489c0bc @masak big reorganization
authored
826 ## The game itself
2a0cae0 @masak diverse refactors
authored
827
489c0bc @masak big reorganization
authored
828 say "CRYPT";
829 say "=====";
830 say "";
7008360 @masak [crypt.pl] much more hacking
authored
831
489c0bc @masak big reorganization
authored
832 say "You've heard there's supposed to be an ancient hidden crypt in these";
833 say "woods. One containing a priceless treasure. Well, there's only one way";
834 say "to find out...";
835 say "";
3f699c4 @masak many additions
authored
836
2a0cae0 @masak diverse refactors
authored
837 %rooms<clearing>.enter;
c260ea3 @masak changes and refactors
authored
838
5675bb8 @masak initial commit
authored
839 loop {
840 say "";
86b0919 @masak trim after checking for undef
authored
841 my $command = prompt("> ");
5675bb8 @masak initial commit
authored
842
843 given $command {
344c25a @masak small changes
authored
844 when !.defined || .lc eq "q" | "quit" {
7008360 @masak [crypt.pl] much more hacking
authored
845 say "";
b95c753 @masak handle double Ctrl+D
authored
846 my $really = prompt "Really quit (y/N)? ";
847 if !defined $really || "y"|"yes" eq lc $really {
489c0bc @masak big reorganization
authored
848 last;
7008360 @masak [crypt.pl] much more hacking
authored
849 }
850 }
851
86b0919 @masak trim after checking for undef
authored
852 $command .= trim;
853 $command .= lc;
854
5c009ad @masak trim user input before switch statement
authored
855 when "" {
5675bb8 @masak initial commit
authored
856 succeed;
857 }
858
7d92b48 @masak trigger help on /^help>>/, not "help"
authored
859 when /^help>>/|"h"|"?" {
c21617c @masak implemented some missing features
authored
860 say "Here are some (made-up) examples of commands you can use:";
861 say "";
862 say "look (l) | ",
863 "take banana";
864 say "examine banana (x banana) | ",
865 "drop banana";
866 say "[go] north/south/east/west (n/s/e/w) | ",
867 "put banana in bag";
e7c4ff3 @masak mentioned open/close in help
authored
868 say "open bag | ",
869 "close bag";
c21617c @masak implemented some missing features
authored
870 }
871
fe91bb0 @masak implemented "go east" etc
authored
872 when /^ :s go (\w+) $/
873 && $0 eq any @directions, %abbr_directions.keys, <in out> {
874
875 $command = ~$0;
876 proceed;
877 }
878
5675bb8 @masak initial commit
authored
879 when any(%abbr_directions.keys) {
880 $command = %abbr_directions{$command};
881 proceed;
882 }
883
7008360 @masak [crypt.pl] much more hacking
authored
884 when 'in' {
885 if $room.in -> $real_direction {
886 $command = $real_direction;
887 }
888 proceed;
889 }
890
891 when 'out' {
892 if $room.out -> $real_direction {
893 $command = $real_direction;
894 }
895 proceed;
896 }
897
a4c71b8 @masak used the Direction subtype more
authored
898 when Direction {
5675bb8 @masak initial commit
authored
899 my $direction = $command;
900 if $room.exits{$direction} -> $new_room {
4f0098f @masak introduced a fire
authored
901 my $succeeded = $room.?on_try_exit($direction) // True;
902 if $succeeded {
903 $new_room.enter;
904 }
f9135fe @masak implemented doom and ultimate rescue
authored
905 %things<doom>.tick;
5675bb8 @masak initial commit
authored
906 }
907 else {
908 say "Sorry, you can't go $direction from here.";
909 }
910 }
911
3f699c4 @masak many additions
authored
912 when "look"|"l" {
7008360 @masak [crypt.pl] much more hacking
authored
913 $room.look;
914 }
915
c21617c @masak implemented some missing features
authored
916 when /^ :s look in $<noun>=[\w+] $/ {
917 my $thing = %things{$<noun>};
918
919 unless $thing {
920 say "I am unfamiliar with the noun '$<noun>'.";
921 succeed;
922 }
923 unless player_can_see($thing) {
924 say "You see no $<noun> here.";
925 succeed;
926 }
927
928 unless player_can_see_inside($thing) {
929 say "You can't see inside the $<noun>.";
930 succeed;
931 }
932
933 say "The $thing.name() contains:";
934 $thing.list_container_contents("A %s.");
935 }
936
3f699c4 @masak many additions
authored
937 when "inventory"|"i" {
938 if $inventory.contents {
939 say "You are carrying:";
ccc4287 @masak implemented putting things in containers
authored
940 $inventory.list_container_contents("A %s.");
3f699c4 @masak many additions
authored
941 }
942 else {
943 say "You are empty-handed.";
944 }
945 }
946
6316bdf @masak better error for transitive verbs w/o object
authored
947 when /^ :s $<verb>=[\w+[ \w+]?] <?{ $<verb> eq any(@verbs) }> $/ {
948 say "What do you want to $<verb>?";
949 }
950
ca4aaf8 @masak work around lack of /@array/ interpolation
authored
951 # RAKUDO: Due to [perl #95504], we have to do the checking like
952 # this instead of just $<verb>=@verbs
953 when /^ :s $<verb>=[\w+[ \w+]?] <?{ $<verb> eq any(@verbs) }>
954 [the]? $<noun>=[\w+] $/ {
955
3f699c4 @masak many additions
authored
956 my $verb = $<verb>;
0b39279 @masak allowed multi-word verbs
authored
957 if %verb_synonyms{$verb} -> $synonym {
3f699c4 @masak many additions
authored
958 $verb = $synonym;
959 }
960
0b39279 @masak allowed multi-word verbs
authored
961 my $thing = %things{$<noun>};
c2ad81c @masak made fire extinguishable
authored
962 unless $thing {
963 say "I am unfamiliar with the noun '$<noun>'.";
964 succeed;
965 }
c260ea3 @masak changes and refactors
authored
966 unless player_can_see($thing) {
2a0cae0 @masak diverse refactors
authored
967 say "You see no $<noun> here.";
968 succeed;
9a9d2ed @masak more changes
authored
969 }
3f699c4 @masak many additions
authored
970
971 unless $thing.can($verb) {
2a0cae0 @masak diverse refactors
authored
972 say "You can't $<verb> the $<noun>.";
3f699c4 @masak many additions
authored
973 succeed;
7008360 @masak [crypt.pl] much more hacking
authored
974 }
3f699c4 @masak many additions
authored
975
976 $thing."$verb"();
f9135fe @masak implemented doom and ultimate rescue
authored
977 %things<doom>.tick;
7008360 @masak [crypt.pl] much more hacking
authored
978 }
979
ca4aaf8 @masak work around lack of /@array/ interpolation
authored
980 # RAKUDO: Due to [perl #95504], we have to do the checking like
981 # this instead of just $<verb>=@verbs
982 when /^ :s $<verb>=[\w+[ \w+]?] <?{ $<verb> eq any(@verbs) }>
983 [the]? $<noun1>=[\w+] $<prep>=[in||on]
984 [the]? $<noun2>=[\w+] $/ {
985
ccc4287 @masak implemented putting things in containers
authored
986 my $verb = $<verb>;
0b39279 @masak allowed multi-word verbs
authored
987 if %verb_synonyms{$verb} -> $synonym {
ccc4287 @masak implemented putting things in containers
authored
988 $verb = $synonym;
989 }
990
991 unless $verb eq 'put' {
992 say "Sorry, I did not understand that.";
c21617c @masak implemented some missing features
authored
993 say "Type 'help' for suggestions.";
ccc4287 @masak implemented putting things in containers
authored
994 succeed;
995 }
996
f9135fe @masak implemented doom and ultimate rescue
authored
997 if $<noun1> eq "disk" && $room ~~ Hall {
998 say "Which disk do you mean; the tiny disk, the small disk, ",
7e77250 @masak supported 'put left disk on right rod' syntax
authored
999 "the medium disk,";
f9135fe @masak implemented doom and ultimate rescue
authored
1000 say "the large disk, or the huge disk?";
1001 succeed;
1002 }
1003
1004 my $noun1 = $<noun1>;
1005 if $<noun1> eq "disk" && $room ~~ Crypt {
1006 $noun1 = "tiny disk";
1007 }
1008
0b39279 @masak allowed multi-word verbs
authored
1009 my $thing = %things{$noun1};
c2ad81c @masak made fire extinguishable
authored
1010 unless $thing {
f9135fe @masak implemented doom and ultimate rescue
authored
1011 say "I am unfamiliar with the noun '$noun1'.";
c2ad81c @masak made fire extinguishable
authored
1012 succeed;
1013 }
ccc4287 @masak implemented putting things in containers
authored
1014 unless player_can_see($thing) {
1015 say "You see no $<noun1> here.";
1016 succeed;
1017 }
1018
0b39279 @masak allowed multi-word verbs
authored
1019 my $receiver = %things{$<noun2>};
f9135fe @masak implemented doom and ultimate rescue
authored
1020 unless $receiver {
c2ad81c @masak made fire extinguishable
authored
1021 say "I am unfamiliar with the noun '$<noun2>'.";
1022 succeed;
1023 }
f9135fe @masak implemented doom and ultimate rescue
authored
1024 unless player_can_see($receiver) {
ccc4287 @masak implemented putting things in containers
authored
1025 say "You see no $<noun2> here.";
1026 succeed;
1027 }
1028
1029 unless $thing ~~ Takable {
f9135fe @masak implemented doom and ultimate rescue
authored
1030 say "You can't move the $noun1.";
ccc4287 @masak implemented putting things in containers
authored
1031 succeed;
1032 }
1033
f9135fe @masak implemented doom and ultimate rescue
authored
1034 if $<prep> eq "in" {
1035 unless $receiver ~~ Container {
1036 say "You can't put things in the $<noun2>.";
1037 succeed;
1038 }
1039 unless player_can_see_inside($receiver) {
1040 $receiver.open;
1041 }
1042 say "You put the $noun1 in the $<noun2>.";
ccc4287 @masak implemented putting things in containers
authored
1043 }
f9135fe @masak implemented doom and ultimate rescue
authored
1044 elsif $<prep> eq "on" {
1045 unless $receiver ~~ Platform {
1046 say "You can't put things on the $<noun2>.";
1047 succeed;
1048 }
1049 say "You put the $noun1 on the $<noun2>.";
1050 }
1051 $thing.put($receiver);
ccc4287 @masak implemented putting things in containers
authored
1052 }
1053
95e6379 @masak introduced Towers of Hanoi game
authored
1054 when /^ :s [move|put|take] [the]? disk / {
1055 say "Which disk do you mean; the tiny disk, the small disk, ",
7e77250 @masak supported 'put left disk on right rod' syntax
authored
1056 "the medium disk,";
95e6379 @masak introduced Towers of Hanoi game
authored
1057 say "the large disk, or the huge disk?";
1058 }
1059
1060 when /^ :s take [the]?
7e77250 @masak supported 'put left disk on right rod' syntax
authored
1061 $<adjective>=[tiny||small||medium||large||huge] disk / {
95e6379 @masak introduced Towers of Hanoi game
authored
1062
1063 unless player_can_see(%things{"$<adjective> disk"}) {
1064 say "You see no $<adjective> disk here.";
1065 succeed;
1066 }
1067 if $room ~~ Hall {
1068 $room.take_disk(~$<adjective>);
1069 }
1070 else {
1071 %things{"$<adjective> disk"}.take;
1072 }
1073 }
1074
1075 when /^ :s [move|put] [the]?
7e77250 @masak supported 'put left disk on right rod' syntax
authored
1076 $<adjective>=[tiny||small||medium||large||huge]
95e6379 @masak introduced Towers of Hanoi game
authored
1077 disk [on|to] [the]?
1078 $<position>=[left||middle||right]
1079 rod $/ {
1080
1081 unless player_can_see(%things{"$<adjective> disk"}) {
1082 say "You see no $<adjective> disk here.";
1083 succeed;
1084 }
1085 unless $room ~~ Hall {
1086 say "You see no rod here.";
1087 succeed;
1088 }
1089
1090 $room.move_disk_to_rod(~$<adjective>, ~$<position>);
1091 }
1092
7e77250 @masak supported 'put left disk on right rod' syntax
authored
1093 when /^ :s [move|put] [the]?
1094 $<adjective>=[left||middle||right]
1095 disk [on|to] [the]?
1096 $<position>=[left||middle||right]
1097 rod $/ {
1098
1099 unless $room ~~ Hall {
1100 say "You see no rod here.";
1101 succeed;
1102 }
1103
1104 my $old_rod = inverse_index <left middle right>, $<adjective>;
1105 my $new_rod = inverse_index <left middle right>, $<position>;
1106 if $old_rod == $new_rod {
1107 succeed;
1108 }
1109
1110 $room.move_rod_to_rod($old_rod, $new_rod);
1111 }
1112
1113 when /^ :s (<[abc]>)(<[abc]>) $/ {
95e6379 @masak introduced Towers of Hanoi game
authored
1114 $used_abbreviated_syntax = True;
1115
1116 unless $room ~~ Hall {
1117 say "That command only works in the Hall.";
1118 succeed;
1119 }
1120
7e77250 @masak supported 'put left disk on right rod' syntax
authored
1121 my $old_rod = inverse_index <a b c>, $0;
1122 my $new_rod = inverse_index <a b c>, $1;
95e6379 @masak introduced Towers of Hanoi game
authored
1123 if $old_rod == $new_rod {
1124 succeed;
1125 }
1126
1127 $room.move_rod_to_rod($old_rod, $new_rod);
1128 }
1129
5675bb8 @masak initial commit
authored
1130 default {
1131 say "Sorry, I did not understand that.";
c21617c @masak implemented some missing features
authored
1132 say "Type 'help' for suggestions.";
5675bb8 @masak initial commit
authored
1133 }
1134 }
1135 }
489c0bc @masak big reorganization
authored
1136
1137 say "Thanks for playing.";
Something went wrong with that request. Please try again.