Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

initial commit

  • Loading branch information...
commit 77661b72aa6a0aa1985aa127af5b743885f259a5 0 parents
Carl Mäsak authored
201 LICENSE
... ... @@ -0,0 +1,201 @@
  1 + The Artistic License 2.0
  2 +
  3 + Copyright (c) 2000-2006, The Perl Foundation.
  4 +
  5 + Everyone is permitted to copy and distribute verbatim copies
  6 + of this license document, but changing it is not allowed.
  7 +
  8 +Preamble
  9 +
  10 +This license establishes the terms under which a given free software
  11 +Package may be copied, modified, distributed, and/or redistributed.
  12 +The intent is that the Copyright Holder maintains some artistic
  13 +control over the development of that Package while still keeping the
  14 +Package available as open source and free software.
  15 +
  16 +You are always permitted to make arrangements wholly outside of this
  17 +license directly with the Copyright Holder of a given Package. If the
  18 +terms of this license do not permit the full use that you propose to
  19 +make of the Package, you should contact the Copyright Holder and seek
  20 +a different licensing arrangement.
  21 +
  22 +Definitions
  23 +
  24 + "Copyright Holder" means the individual(s) or organization(s)
  25 + named in the copyright notice for the entire Package.
  26 +
  27 + "Contributor" means any party that has contributed code or other
  28 + material to the Package, in accordance with the Copyright Holder's
  29 + procedures.
  30 +
  31 + "You" and "your" means any person who would like to copy,
  32 + distribute, or modify the Package.
  33 +
  34 + "Package" means the collection of files distributed by the
  35 + Copyright Holder, and derivatives of that collection and/or of
  36 + those files. A given Package may consist of either the Standard
  37 + Version, or a Modified Version.
  38 +
  39 + "Distribute" means providing a copy of the Package or making it
  40 + accessible to anyone else, or in the case of a company or
  41 + organization, to others outside of your company or organization.
  42 +
  43 + "Distributor Fee" means any fee that you charge for Distributing
  44 + this Package or providing support for this Package to another
  45 + party. It does not mean licensing fees.
  46 +
  47 + "Standard Version" refers to the Package if it has not been
  48 + modified, or has been modified only in ways explicitly requested
  49 + by the Copyright Holder.
  50 +
  51 + "Modified Version" means the Package, if it has been changed, and
  52 + such changes were not explicitly requested by the Copyright
  53 + Holder.
  54 +
  55 + "Original License" means this Artistic License as Distributed with
  56 + the Standard Version of the Package, in its current version or as
  57 + it may be modified by The Perl Foundation in the future.
  58 +
  59 + "Source" form means the source code, documentation source, and
  60 + configuration files for the Package.
  61 +
  62 + "Compiled" form means the compiled bytecode, object code, binary,
  63 + or any other form resulting from mechanical transformation or
  64 + translation of the Source form.
  65 +
  66 +
  67 +Permission for Use and Modification Without Distribution
  68 +
  69 +(1) You are permitted to use the Standard Version and create and use
  70 +Modified Versions for any purpose without restriction, provided that
  71 +you do not Distribute the Modified Version.
  72 +
  73 +
  74 +Permissions for Redistribution of the Standard Version
  75 +
  76 +(2) You may Distribute verbatim copies of the Source form of the
  77 +Standard Version of this Package in any medium without restriction,
  78 +either gratis or for a Distributor Fee, provided that you duplicate
  79 +all of the original copyright notices and associated disclaimers. At
  80 +your discretion, such verbatim copies may or may not include a
  81 +Compiled form of the Package.
  82 +
  83 +(3) You may apply any bug fixes, portability changes, and other
  84 +modifications made available from the Copyright Holder. The resulting
  85 +Package will still be considered the Standard Version, and as such
  86 +will be subject to the Original License.
  87 +
  88 +
  89 +Distribution of Modified Versions of the Package as Source
  90 +
  91 +(4) You may Distribute your Modified Version as Source (either gratis
  92 +or for a Distributor Fee, and with or without a Compiled form of the
  93 +Modified Version) provided that you clearly document how it differs
  94 +from the Standard Version, including, but not limited to, documenting
  95 +any non-standard features, executables, or modules, and provided that
  96 +you do at least ONE of the following:
  97 +
  98 + (a) make the Modified Version available to the Copyright Holder
  99 + of the Standard Version, under the Original License, so that the
  100 + Copyright Holder may include your modifications in the Standard
  101 + Version.
  102 +
  103 + (b) ensure that installation of your Modified Version does not
  104 + prevent the user installing or running the Standard Version. In
  105 + addition, the Modified Version must bear a name that is different
  106 + from the name of the Standard Version.
  107 +
  108 + (c) allow anyone who receives a copy of the Modified Version to
  109 + make the Source form of the Modified Version available to others
  110 + under
  111 +
  112 + (i) the Original License or
  113 +
  114 + (ii) a license that permits the licensee to freely copy,
  115 + modify and redistribute the Modified Version using the same
  116 + licensing terms that apply to the copy that the licensee
  117 + received, and requires that the Source form of the Modified
  118 + Version, and of any works derived from it, be made freely
  119 + available in that license fees are prohibited but Distributor
  120 + Fees are allowed.
  121 +
  122 +
  123 +Distribution of Compiled Forms of the Standard Version
  124 +or Modified Versions without the Source
  125 +
  126 +(5) You may Distribute Compiled forms of the Standard Version without
  127 +the Source, provided that you include complete instructions on how to
  128 +get the Source of the Standard Version. Such instructions must be
  129 +valid at the time of your distribution. If these instructions, at any
  130 +time while you are carrying out such distribution, become invalid, you
  131 +must provide new instructions on demand or cease further distribution.
  132 +If you provide valid instructions or cease distribution within thirty
  133 +days after you become aware that the instructions are invalid, then
  134 +you do not forfeit any of your rights under this license.
  135 +
  136 +(6) You may Distribute a Modified Version in Compiled form without
  137 +the Source, provided that you comply with Section 4 with respect to
  138 +the Source of the Modified Version.
  139 +
  140 +
  141 +Aggregating or Linking the Package
  142 +
  143 +(7) You may aggregate the Package (either the Standard Version or
  144 +Modified Version) with other packages and Distribute the resulting
  145 +aggregation provided that you do not charge a licensing fee for the
  146 +Package. Distributor Fees are permitted, and licensing fees for other
  147 +components in the aggregation are permitted. The terms of this license
  148 +apply to the use and Distribution of the Standard or Modified Versions
  149 +as included in the aggregation.
  150 +
  151 +(8) You are permitted to link Modified and Standard Versions with
  152 +other works, to embed the Package in a larger work of your own, or to
  153 +build stand-alone binary or bytecode versions of applications that
  154 +include the Package, and Distribute the result without restriction,
  155 +provided the result does not expose a direct interface to the Package.
  156 +
  157 +
  158 +Items That are Not Considered Part of a Modified Version
  159 +
  160 +(9) Works (including, but not limited to, modules and scripts) that
  161 +merely extend or make use of the Package, do not, by themselves, cause
  162 +the Package to be a Modified Version. In addition, such works are not
  163 +considered parts of the Package itself, and are not subject to the
  164 +terms of this license.
  165 +
  166 +
  167 +General Provisions
  168 +
  169 +(10) Any use, modification, and distribution of the Standard or
  170 +Modified Versions is governed by this Artistic License. By using,
  171 +modifying or distributing the Package, you accept this license. Do not
  172 +use, modify, or distribute the Package, if you do not accept this
  173 +license.
  174 +
  175 +(11) If your Modified Version has been derived from a Modified
  176 +Version made by someone other than you, you are nevertheless required
  177 +to ensure that your Modified Version complies with the requirements of
  178 +this license.
  179 +
  180 +(12) This license does not grant you the right to use any trademark,
  181 +service mark, tradename, or logo of the Copyright Holder.
  182 +
  183 +(13) This license includes the non-exclusive, worldwide,
  184 +free-of-charge patent license to make, have made, use, offer to sell,
  185 +sell, import and otherwise transfer the Package with respect to any
  186 +patent claims licensable by the Copyright Holder that are necessarily
  187 +infringed by the Package. If you institute patent litigation
  188 +(including a cross-claim or counterclaim) against any party alleging
  189 +that the Package constitutes direct or contributory patent
  190 +infringement, then this Artistic License to you shall terminate on the
  191 +date that such litigation is filed.
  192 +
  193 +(14) Disclaimer of Warranty:
  194 +THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
  195 +IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
  196 +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
  197 +NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
  198 +LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
  199 +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
  200 +DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
  201 +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
8 META.info
... ... @@ -0,0 +1,8 @@
  1 +{
  2 + "name" : "Adventure::Engine",
  3 + "version" : "0.3.0",
  4 + "description" : "Helps build and run adventure games.",
  5 + "author" : "Carl Mäsak",
  6 + "depends" : [],
  7 + "source-url" : "git://github.com/masak/Adventure-Engine.git"
  8 +}
11 README.md
Source Rendered
... ... @@ -0,0 +1,11 @@
  1 +Adventure::Engine
  2 +=================
  3 +
  4 +Class that runs an interactive fiction adventure game.
  5 +
  6 +The class is meant to be wrapped by another class — see crypt for an
  7 +example — which then builds up the world using methods from this class.
  8 +It then exposes the common player commands, such as `walk` and `take` and
  9 +`use`.
  10 +
  11 +Actual illucidating example coming soon. Watch this spot.
938 lib/Adventure/Engine.pm
... ... @@ -0,0 +1,938 @@
  1 +use Event;
  2 +
  3 +class Adventure::PlayerWalked does Event {
  4 + has $.to;
  5 +}
  6 +
  7 +class Adventure::PlayerWasPlaced does Event {
  8 + has $.in;
  9 +}
  10 +
  11 +class Adventure::PlayerLooked does Event {
  12 + has $.room;
  13 + has @.exits;
  14 + has @.things;
  15 +}
  16 +
  17 +class Adventure::TwoRoomsConnected does Event {
  18 + has @.rooms;
  19 + has $.direction;
  20 +}
  21 +
  22 +class Adventure::TwoRoomsDisconnected does Event {
  23 + has @.rooms;
  24 + has $.direction;
  25 +}
  26 +
  27 +class Adventure::DirectionAliased does Event {
  28 + has $.room;
  29 + has $.direction;
  30 + has $.alias;
  31 +}
  32 +
  33 +class Adventure::PlayerExamined does Event {
  34 + has $.thing;
  35 +}
  36 +
  37 +class Adventure::ThingPlaced does Event {
  38 + has $.thing;
  39 + has $.room;
  40 +}
  41 +
  42 +class Adventure::PlayerOpened does Event {
  43 + has $.thing;
  44 +}
  45 +
  46 +class Adventure::PlayerPutIn does Event {
  47 + has $.thing;
  48 + has $.in;
  49 +}
  50 +
  51 +class Adventure::ThingMadeAContainer does Event {
  52 + has $.thing;
  53 +}
  54 +
  55 +class Adventure::PlayerPutOn does Event {
  56 + has $.thing;
  57 + has $.on;
  58 +}
  59 +
  60 +class Adventure::ThingMadeAPlatform does Event {
  61 + has $.thing;
  62 +}
  63 +
  64 +class Adventure::PlayerRead does Event {
  65 + has $.thing;
  66 +}
  67 +
  68 +class Adventure::ThingMadeReadable does Event {
  69 + has $.thing;
  70 +}
  71 +
  72 +class Adventure::ThingHidden does Event {
  73 + has $.thing;
  74 +}
  75 +
  76 +class Adventure::ThingUnhidden does Event {
  77 + has $.thing;
  78 +}
  79 +
  80 +class Adventure::PlayerTook does Event {
  81 + has $.thing;
  82 +}
  83 +
  84 +class Adventure::ThingMadeCarryable does Event {
  85 + has $.thing;
  86 +}
  87 +
  88 +class Adventure::PlayerDropped does Event {
  89 + has $.thing;
  90 +}
  91 +
  92 +class Adventure::ThingMadeImplicit does Event {
  93 + has $.thing;
  94 +}
  95 +
  96 +class Adventure::ContentsRevealed does Event {
  97 + has $.container;
  98 + has @.contents;
  99 +}
  100 +
  101 +class Adventure::GameRemarked does Event {
  102 + has $.remark;
  103 +}
  104 +
  105 +class Adventure::PlayerLookedAtDarkness does Event {
  106 +}
  107 +
  108 +class Adventure::RoomMadeDark does Event {
  109 + has $.room;
  110 +}
  111 +
  112 +class Adventure::PlayerUsed does Event {
  113 + has $.thing;
  114 +}
  115 +
  116 +class Adventure::ThingMadeALightSource does Event {
  117 + has $.thing;
  118 +}
  119 +
  120 +class Adventure::LightSourceSwitchedOn does Event {
  121 + has $.thing;
  122 +}
  123 +
  124 +class Adventure::GameFinished does Event {
  125 +}
  126 +
  127 +class Adventure::PlayerCheckedInventory does Event {
  128 + has @.things;
  129 +}
  130 +
  131 +class X::Adventure is Exception {
  132 +}
  133 +
  134 +class X::Adventure::NoSuchDirection is X::Adventure {
  135 + has $.action;
  136 + has $.direction;
  137 +
  138 + method message {
  139 + "Cannot $.action because direction '$.direction' does not exist"
  140 + }
  141 +}
  142 +
  143 +class X::Adventure::NoExitThere is X::Adventure {
  144 + has $.direction;
  145 +
  146 + method message {
  147 + "Cannot walk $.direction because there is no exit there"
  148 + }
  149 +}
  150 +
  151 +class X::Adventure::PlayerNowhere is X::Adventure {
  152 + method message {
  153 + "Cannot move because the player isn't anywhere"
  154 + }
  155 +}
  156 +
  157 +class X::Adventure::NoSuchThingHere is X::Adventure {
  158 + has $.thing;
  159 +
  160 + method message {
  161 + "You see no $.thing here"
  162 + }
  163 +}
  164 +
  165 +class X::Adventure::ThingNotOpenable is X::Adventure {
  166 + has $.thing;
  167 +
  168 + method message {
  169 + "You cannot open the $.thing"
  170 + }
  171 +}
  172 +
  173 +class X::Adventure::ThingAlreadyOpen is X::Adventure {
  174 + has $.thing;
  175 +
  176 + method message {
  177 + "The $.thing is open"
  178 + }
  179 +}
  180 +
  181 +class X::Adventure::CannotPutInNonContainer is X::Adventure {
  182 + has $.in;
  183 +
  184 + method message {
  185 + "You cannot put things in the $.in"
  186 + }
  187 +}
  188 +
  189 +class X::Adventure::YoDawg is X::Adventure {
  190 + has $.relation;
  191 + has $.thing;
  192 +
  193 + method message {
  194 + "Yo dawg, I know you like a $.thing so I put a $.thing $.relation your $.thing"
  195 + }
  196 +}
  197 +
  198 +class X::Adventure::CannotPutOnNonPlatform is X::Adventure {
  199 + has $.on;
  200 +
  201 + method message {
  202 + "You cannot put things on the $.on"
  203 + }
  204 +}
  205 +
  206 +class X::Adventure::ThingNotReadable is X::Adventure {
  207 + has $.thing;
  208 +
  209 + method message {
  210 + "There is nothing to read on the $.thing"
  211 + }
  212 +}
  213 +
  214 +class X::Adventure::ThingNotCarryable is X::Adventure {
  215 + has $.action;
  216 + has $.thing;
  217 +
  218 + method message {
  219 + "You cannot $.action the $.thing"
  220 + }
  221 +}
  222 +
  223 +class X::Adventure::PlayerAlreadyCarries is X::Adventure {
  224 + has $.thing;
  225 +
  226 + method message {
  227 + "You already have the $.thing"
  228 + }
  229 +}
  230 +
  231 +class X::Adventure::PlayerDoesNotHave is X::Adventure {
  232 + has $.thing;
  233 +
  234 + method message {
  235 + "You are not carrying the $.thing"
  236 + }
  237 +}
  238 +
  239 +class X::Adventure::PitchBlack is X::Adventure {
  240 + has $.action;
  241 +
  242 + method message {
  243 + "You cannot $.action anything, because it is pitch black"
  244 + }
  245 +}
  246 +
  247 +class X::Adventure::GameOver is X::Adventure {
  248 + method message {
  249 + "The game has already ended"
  250 + }
  251 +}
  252 +
  253 +class Adventure::Engine {
  254 + my @possible_directions = <
  255 + north south east west
  256 + northeast northwest southeast southwest
  257 + up down
  258 + >;
  259 +
  260 + has @!events;
  261 + has $!player_location;
  262 + has %!exits;
  263 + has %!exit_aliases;
  264 + has %!seen_room;
  265 + has %!try_exit_hooks;
  266 + has %!thing_rooms;
  267 + has %!openable_things;
  268 + has %!open_things;
  269 + has %!containers;
  270 + has %!platforms;
  271 + has %!readable_things;
  272 + has %!hidden_things;
  273 + has %!examine_hooks;
  274 + has %!carryable_things;
  275 + has %!implicit_things;
  276 + has %!open_hooks;
  277 + has %!put_hooks;
  278 + has %!dark_rooms;
  279 + has %!light_sources;
  280 + has %!things_shining;
  281 + has %!remove_from_hooks;
  282 + has %!take_hooks;
  283 + has $!game_finished;
  284 + has %!tick_hooks;
  285 +
  286 + method connect(@rooms, $direction) {
  287 + die X::Adventure::NoSuchDirection.new(:action('connect rooms'), :$direction)
  288 + unless $direction eq any(@possible_directions);
  289 +
  290 + my @events = Adventure::TwoRoomsConnected.new(:@rooms, :$direction);
  291 + self!apply_and_return: @events;
  292 + }
  293 +
  294 + method disconnect(@rooms, $direction) {
  295 + die X::Adventure::NoSuchDirection.new(:action('disconnect rooms'), :$direction)
  296 + unless $direction eq any(@possible_directions);
  297 +
  298 + my @events = Adventure::TwoRoomsDisconnected.new(:@rooms, :$direction);
  299 + self!apply_and_return: @events;
  300 + }
  301 +
  302 + method !contents_of($thing) {
  303 + return %!thing_rooms.grep({.value eq "contents:$thing"})>>.key;
  304 + }
  305 +
  306 + method !explicit_things_at($location) {
  307 + sub here_visible_and_explicit($_) {
  308 + %!thing_rooms{$_} eq $location
  309 + && !%!hidden_things{$_}
  310 + && ($location ~~ /^contents':'/ || !%!implicit_things{$_})
  311 + }
  312 +
  313 + return unless $location;
  314 + return gather for %!thing_rooms.keys -> $thing {
  315 + next unless here_visible_and_explicit($thing);
  316 + if (!%!openable_things{$thing} || %!open_things{$thing})
  317 + && self!contents_of($thing) {
  318 + take $thing => self!explicit_things_at("contents:$thing");
  319 + }
  320 + else {
  321 + take $thing;
  322 + }
  323 + }
  324 + }
  325 +
  326 + method thing_is_in($sought, $location) {
  327 + return unless $location;
  328 + return False
  329 + if %!hidden_things{$sought};
  330 + for %!thing_rooms.keys -> $thing {
  331 + next unless %!thing_rooms{$thing} eq $location;
  332 + return True
  333 + if $thing eq $sought;
  334 + return True
  335 + if %!containers{$thing}
  336 + && (!%!openable_things{$thing} || %!open_things{$thing})
  337 + && self.thing_is_in($sought, "contents:$thing");
  338 + return True
  339 + if %!platforms{$thing}
  340 + && self.thing_is_in($sought, "contents:$thing");
  341 + }
  342 + return False;
  343 + }
  344 +
  345 + method thing_in_room_or_inventory($thing, $room) {
  346 + self.thing_is_in($thing, $room)
  347 + || self.thing_is_in($thing, 'player inventory');
  348 + }
  349 +
  350 + method !shining_thing_here($room) {
  351 + for %!things_shining.kv -> $thing, $shining {
  352 + next unless $shining;
  353 + return True if self.thing_in_room_or_inventory($thing, $room);
  354 + }
  355 + return False;
  356 + }
  357 +
  358 + method !tick() {
  359 + my @events;
  360 + for %!tick_hooks.kv -> $name, %props {
  361 + if --%props<ticks> == 0 {
  362 + @events.push(%props<hook>());
  363 + }
  364 + }
  365 + return @events;
  366 + }
  367 +
  368 + my %abbr_directions = <
  369 + n north
  370 + s south
  371 + e east
  372 + w west
  373 + ne northeast
  374 + nw northwest
  375 + se southeast
  376 + sw southwest
  377 + u up
  378 + d down
  379 + >;
  380 +
  381 + method walk($direction) {
  382 + die X::Adventure::GameOver.new()
  383 + if $!game_finished;
  384 +
  385 + die X::Adventure::PlayerNowhere.new()
  386 + unless defined $!player_location;
  387 +
  388 + my $actual_direction =
  389 + %!exit_aliases{$!player_location}{$direction}
  390 + // %abbr_directions{$direction}
  391 + // $direction;
  392 +
  393 + die X::Adventure::NoSuchDirection.new(:action('walk that way'), :$direction)
  394 + unless $actual_direction eq any(@possible_directions);
  395 +
  396 + my $to = %!exits{$!player_location}{$actual_direction};
  397 +
  398 + die X::Adventure::NoExitThere.new(:$direction)
  399 + unless defined $to;
  400 +
  401 + my @events;
  402 + my $walk = True;
  403 + if %!try_exit_hooks{$!player_location}{$actual_direction} -> &hook {
  404 + @events.push(&hook());
  405 + $walk = @events.pop;
  406 + }
  407 +
  408 + if $walk {
  409 + @events.push(Adventure::PlayerWalked.new(:$to));
  410 + unless %!seen_room{$to}++ {
  411 + my $pitch_black = %!dark_rooms{$to}
  412 + && !self!shining_thing_here($to);
  413 +
  414 + if $pitch_black {
  415 + @events.push(Adventure::PlayerLookedAtDarkness.new());
  416 + }
  417 + else {
  418 + @events.push(Adventure::PlayerLooked.new(
  419 + :room($to),
  420 + :exits((%!exits{$to} // ()).keys),
  421 + :things(self!explicit_things_at($to)),
  422 + ));
  423 + }
  424 + }
  425 + @events.push(self!tick);
  426 + }
  427 + self!apply_and_return: @events;
  428 + }
  429 +
  430 + method look() {
  431 + die X::Adventure::GameOver.new()
  432 + if $!game_finished;
  433 +
  434 + die X::Adventure::PlayerNowhere.new()
  435 + unless defined $!player_location;
  436 +
  437 + my $pitch_black = %!dark_rooms{$!player_location}
  438 + && !self!shining_thing_here($!player_location);
  439 +
  440 + my @events = $pitch_black
  441 + ?? Adventure::PlayerLookedAtDarkness.new()
  442 + !! Adventure::PlayerLooked.new(
  443 + :room($!player_location),
  444 + :exits((%!exits{$!player_location} // ()).keys),
  445 + :things(self!explicit_things_at($!player_location)),
  446 + );
  447 + self!apply_and_return: @events;
  448 + }
  449 +
  450 + method place_player($in) {
  451 + my @events = Adventure::PlayerWasPlaced.new(:$in);
  452 + unless %!seen_room{$in}++ {
  453 + @events.push(Adventure::PlayerLooked.new(
  454 + :room($in),
  455 + :exits((%!exits{$in} // ()).keys),
  456 + :things(self!explicit_things_at($in)),
  457 + ));
  458 + }
  459 + self!apply_and_return: @events;
  460 + }
  461 +
  462 + method alias_direction($room, $alias, $direction) {
  463 + my @events = Adventure::DirectionAliased.new(
  464 + :$room, :$alias, :$direction
  465 + );
  466 + self!apply_and_return: @events;
  467 + }
  468 +
  469 + method place_thing($thing, $room) {
  470 + my @events = Adventure::ThingPlaced.new(
  471 + :$thing, :$room
  472 + );
  473 + self!apply_and_return: @events;
  474 + }
  475 +
  476 + method examine($thing) {
  477 + die X::Adventure::GameOver.new()
  478 + if $!game_finished;
  479 +
  480 + die X::Adventure::PlayerNowhere.new()
  481 + unless defined $!player_location;
  482 +
  483 + my $pitch_black = %!dark_rooms{$!player_location}
  484 + && !self!shining_thing_here($!player_location);
  485 +
  486 + die X::Adventure::PitchBlack.new(:action<see>)
  487 + if $pitch_black;
  488 +
  489 + die X::Adventure::NoSuchThingHere.new(:$thing)
  490 + unless self.thing_in_room_or_inventory($thing, $!player_location);
  491 +
  492 + die X::Adventure::NoSuchThingHere.new(:$thing)
  493 + if %!hidden_things{$thing};
  494 +
  495 + my @events = Adventure::PlayerExamined.new(
  496 + :$thing
  497 + );
  498 + if %!examine_hooks{$thing} -> &hook {
  499 + @events.push(&hook());
  500 + }
  501 +
  502 + self!apply_and_return: @events;
  503 + }
  504 +
  505 + method inventory() {
  506 + die X::Adventure::GameOver.new()
  507 + if $!game_finished;
  508 +
  509 + die X::Adventure::PlayerNowhere.new()
  510 + unless defined $!player_location;
  511 +
  512 + my $thing = 'player inventory';
  513 + my @events = Adventure::PlayerCheckedInventory.new(
  514 + :things(self!explicit_things_at('player inventory'))
  515 + );
  516 + if %!examine_hooks{$thing} -> &hook {
  517 + @events.push(&hook());
  518 + }
  519 +
  520 + self!apply_and_return: @events;
  521 + }
  522 +
  523 + method make_thing_openable($thing) {
  524 + %!openable_things{$thing} = True;
  525 + }
  526 +
  527 + method open($thing) {
  528 + die X::Adventure::GameOver.new()
  529 + if $!game_finished;
  530 +
  531 + die X::Adventure::PlayerNowhere.new()
  532 + unless defined $!player_location;
  533 +
  534 + die X::Adventure::NoSuchThingHere.new(:$thing)
  535 + unless self.thing_in_room_or_inventory($thing, $!player_location);
  536 +
  537 + die X::Adventure::NoSuchThingHere.new(:$thing)
  538 + if %!hidden_things{$thing};
  539 +
  540 + die X::Adventure::ThingNotOpenable.new(:$thing)
  541 + unless %!openable_things{$thing};
  542 +
  543 + die X::Adventure::ThingAlreadyOpen.new(:$thing)
  544 + if %!open_things{$thing};
  545 +
  546 + my @events = Adventure::PlayerOpened.new(:$thing);
  547 + my @contents = self!contents_of($thing);
  548 + if @contents {
  549 + @events.push(
  550 + Adventure::ContentsRevealed.new(
  551 + :container($thing), :@contents
  552 + )
  553 + );
  554 + }
  555 + if %!open_hooks{$thing} -> &hook {
  556 + @events.push(&hook());
  557 + }
  558 + @events.push(self!tick);
  559 + self!apply_and_return: @events;
  560 + }
  561 +
  562 + method make_thing_a_container($thing) {
  563 + my @events = Adventure::ThingMadeAContainer.new(:$thing);
  564 + self!apply_and_return: @events;
  565 + }
  566 +
  567 + method put_thing_in($thing, $in) {
  568 + die X::Adventure::GameOver.new()
  569 + if $!game_finished;
  570 +
  571 + die X::Adventure::PlayerNowhere.new()
  572 + unless defined $!player_location;
  573 +
  574 + die X::Adventure::NoSuchThingHere.new(:$thing)
  575 + unless self.thing_in_room_or_inventory($thing, $!player_location);
  576 +
  577 + die X::Adventure::NoSuchThingHere.new(:$thing)
  578 + if %!hidden_things{$thing};
  579 +
  580 + die X::Adventure::NoSuchThingHere.new(:thing($in))
  581 + unless self.thing_in_room_or_inventory($in, $!player_location);
  582 +
  583 + die X::Adventure::NoSuchThingHere.new(:$thing)
  584 + if %!hidden_things{$in};
  585 +
  586 + die X::Adventure::ThingNotCarryable.new(:action<put>, :$thing)
  587 + unless %!carryable_things{$thing};
  588 +
  589 + die X::Adventure::CannotPutInNonContainer.new(:$in)
  590 + unless %!containers{$in};
  591 +
  592 + die X::Adventure::YoDawg.new(:relation<in>, :thing($in))
  593 + if $thing eq $in;
  594 +
  595 + my @events;
  596 +
  597 + if %!openable_things{$in} && !%!open_things{$in} {
  598 + @events.push(Adventure::PlayerOpened.new(:thing($in)));
  599 + }
  600 + @events.push(Adventure::PlayerPutIn.new(:$thing, :$in));
  601 + if %!put_hooks{$in} -> &hook {
  602 + @events.push($_) when Event for &hook($thing);
  603 + }
  604 + @events.push(self!tick);
  605 +
  606 + self!apply_and_return: @events;
  607 + }
  608 +
  609 + method make_thing_a_platform($thing) {
  610 + my @events = Adventure::ThingMadeAPlatform.new(:$thing);
  611 + self!apply_and_return: @events;
  612 + }
  613 +
  614 + method put_thing_on($thing, $on) {
  615 + die X::Adventure::GameOver.new()
  616 + if $!game_finished;
  617 +
  618 + die X::Adventure::PlayerNowhere.new()
  619 + unless defined $!player_location;
  620 +
  621 + die X::Adventure::NoSuchThingHere.new(:$thing)
  622 + unless self.thing_in_room_or_inventory($thing, $!player_location);
  623 +
  624 + die X::Adventure::NoSuchThingHere.new(:$thing)
  625 + if %!hidden_things{$thing};
  626 +
  627 + die X::Adventure::NoSuchThingHere.new(:thing($on))
  628 + unless self.thing_in_room_or_inventory($on, $!player_location);
  629 +
  630 + die X::Adventure::NoSuchThingHere.new(:$thing)
  631 + if %!hidden_things{$on};
  632 +
  633 + die X::Adventure::ThingNotCarryable.new(:action<put>, :$thing)
  634 + unless %!carryable_things{$thing};
  635 +
  636 + die X::Adventure::CannotPutOnNonPlatform.new(:$on)
  637 + unless %!platforms{$on};
  638 +
  639 + die X::Adventure::YoDawg.new(:relation<on>, :thing($on))
  640 + if $thing eq $on;
  641 +
  642 + my @events = Adventure::PlayerPutOn.new(:$thing, :$on);
  643 + if %!put_hooks{$on} -> &hook {
  644 + @events.push($_) when Event for &hook($thing);
  645 + }
  646 + @events.push(self!tick);
  647 + self!apply_and_return: @events;
  648 + }
  649 +
  650 + method make_thing_readable($thing) {
  651 + my @events = Adventure::ThingMadeReadable.new(:$thing);
  652 + self!apply_and_return: @events;
  653 + }
  654 +
  655 + method read($thing) {
  656 + die X::Adventure::GameOver.new()
  657 + if $!game_finished;
  658 +
  659 + die X::Adventure::PlayerNowhere.new()
  660 + unless defined $!player_location;
  661 +
  662 + die X::Adventure::NoSuchThingHere.new(:$thing)
  663 + unless self.thing_in_room_or_inventory($thing, $!player_location);
  664 +
  665 + die X::Adventure::NoSuchThingHere.new(:$thing)
  666 + if %!hidden_things{$thing};
  667 +
  668 + die X::Adventure::ThingNotReadable.new(:$thing)
  669 + unless %!readable_things{$thing};
  670 +
  671 + Adventure::PlayerRead.new(:$thing), self!tick;
  672 + }
  673 +
  674 + method hide_thing($thing) {
  675 + my @events = Adventure::ThingHidden.new(:$thing);
  676 + self!apply_and_return: @events;
  677 + }
  678 +
  679 + method unhide_thing($thing) {
  680 + my @events = Adventure::ThingUnhidden.new(:$thing);
  681 + self!apply_and_return: @events;
  682 + }
  683 +
  684 + method make_thing_carryable($thing) {
  685 + my @events = Adventure::ThingMadeCarryable.new(:$thing);
  686 + self!apply_and_return: @events;
  687 + }
  688 +
  689 + method take($thing) {
  690 + die X::Adventure::GameOver.new()
  691 + if $!game_finished;
  692 +
  693 + die X::Adventure::PlayerNowhere.new()
  694 + unless defined $!player_location;
  695 +
  696 + die X::Adventure::PlayerAlreadyCarries.new(:$thing)
  697 + if (%!thing_rooms{$thing} // '') eq 'player inventory';
  698 +
  699 + my $pitch_black = %!dark_rooms{$!player_location}
  700 + && !self!shining_thing_here($!player_location);
  701 +
  702 + die X::Adventure::PitchBlack.new(:action<take>)
  703 + if $pitch_black;
  704 +
  705 + die X::Adventure::NoSuchThingHere.new(:$thing)
  706 + unless self.thing_is_in($thing, $!player_location);
  707 +
  708 + die X::Adventure::NoSuchThingHere.new(:$thing)
  709 + if %!hidden_things{$thing};
  710 +
  711 + die X::Adventure::ThingNotCarryable.new(:action<take>, :$thing)
  712 + unless %!carryable_things{$thing};
  713 +
  714 + my @events;
  715 + for %!remove_from_hooks.kv -> $container, &hook {
  716 + if self.thing_is_in($thing, "contents:$container") {
  717 + @events.push($_) when Event for &hook($thing);
  718 + }
  719 + }
  720 + # XXX: Need to apply this event early so that hooks can drop the thing.
  721 + self!apply(Adventure::PlayerTook.new(:$thing));
  722 + if %!take_hooks{$thing} -> &hook {
  723 + @events.push($_) when Event for &hook();
  724 + }
  725 + @events.push(self!tick);
  726 + self!apply($_) for @events;
  727 + return Adventure::PlayerTook.new(:$thing), @events;
  728 + }
  729 +
  730 + method drop($thing) {
  731 + die X::Adventure::GameOver.new()
  732 + if $!game_finished;
  733 +
  734 + die X::Adventure::PlayerNowhere.new()
  735 + unless defined $!player_location;
  736 +
  737 + die X::Adventure::PlayerDoesNotHave.new(:$thing)
  738 + unless self.thing_is_in($thing, 'player inventory');
  739 +
  740 + die X::Adventure::PlayerDoesNotHave.new(:$thing)
  741 + if %!hidden_things{$thing};
  742 +
  743 + my @events = Adventure::PlayerDropped.new(:$thing);
  744 + @events.push(self!tick);
  745 + self!apply_and_return: @events;
  746 + }
  747 +
  748 + method remark($remark) {
  749 + my @events = Adventure::GameRemarked.new(:$remark);
  750 + self!apply_and_return: @events;
  751 + }
  752 +
  753 + method make_thing_implicit($thing) {
  754 + my @events = Adventure::ThingMadeImplicit.new(:$thing);
  755 + self!apply_and_return: @events;
  756 + }
  757 +
  758 + method make_room_dark($room) {
  759 + my @events = Adventure::RoomMadeDark.new(:$room);
  760 + self!apply_and_return: @events;
  761 + }
  762 +
  763 + method use($thing) {
  764 + die X::Adventure::GameOver.new()
  765 + if $!game_finished;
  766 +
  767 + die X::Adventure::PlayerNowhere.new()
  768 + unless defined $!player_location;
  769 +
  770 + die X::Adventure::NoSuchThingHere.new(:$thing)
  771 + unless self.thing_in_room_or_inventory($thing, $!player_location);
  772 +
  773 + die X::Adventure::NoSuchThingHere.new(:$thing)
  774 + if %!hidden_things{$thing};
  775 +
  776 + my @events = Adventure::PlayerUsed.new(:$thing);
  777 + if %!light_sources{$thing} {
  778 + @events.push(Adventure::LightSourceSwitchedOn.new(:$thing));
  779 + }
  780 + @events.push(self!tick);
  781 + self!apply_and_return: @events;
  782 + }
  783 +
  784 + method make_thing_a_light_source($thing) {
  785 + my @events = Adventure::ThingMadeALightSource.new(:$thing);
  786 + self!apply_and_return: @events;
  787 + }
  788 +
  789 + method finish() {
  790 + die X::Adventure::GameOver.new()
  791 + if $!game_finished;
  792 +
  793 + my @events = Adventure::GameFinished.new();
  794 + self!apply_and_return: @events;
  795 + }
  796 +
  797 + method on_try_exit($room, $direction, &hook) {
  798 + %!try_exit_hooks{$room}{$direction} = &hook;
  799 + }
  800 +
  801 + method on_examine($thing, &hook) {
  802 + %!examine_hooks{$thing} = &hook;
  803 + }
  804 +
  805 + method on_open($thing, &hook) {
  806 + %!open_hooks{$thing} = &hook;
  807 + }
  808 +
  809 + method on_put($thing, &hook) {
  810 + %!put_hooks{$thing} = &hook;
  811 + }
  812 +
  813 + method on_remove_from($thing, &hook) {
  814 + %!remove_from_hooks{$thing} = &hook;
  815 + }
  816 +
  817 + method on_take($thing, &hook) {
  818 + %!take_hooks{$thing} = &hook;
  819 + }
  820 +
  821 + method light_fuse($n, $name, &hook) {
  822 + %!tick_hooks{$name} = { :ticks($n), :&hook };
  823 + }
  824 +
  825 + method put_out_fuse($name) {
  826 + %!tick_hooks.delete($name);
  827 + }
  828 +
  829 + my class Save {
  830 + has @.events;
  831 + }
  832 +
  833 + method save {
  834 + return Save.new(:@!events);
  835 + }
  836 +
  837 + method restore(Save $save) {
  838 + my $new-engine = Adventure::Engine.new();
  839 + $new-engine!apply($_) for $save.events.list;
  840 + return $new-engine;
  841 + }
  842 +
  843 + sub opposite($direction) {
  844 + my %opposites =
  845 + 'north' => 'south',
  846 + 'east' => 'west',
  847 + 'northeast' => 'southwest',
  848 + 'northwest' => 'southeast',
  849 + 'up' => 'down',
  850 + ;
  851 +
  852 + %opposites.push( %opposites.invert );
  853 +
  854 + %opposites{$direction};
  855 + }
  856 +
  857 + method !apply_and_return(@events) {
  858 + self!apply($_) for @events;
  859 + return @events;
  860 + }
  861 +
  862 + # RAKUDO: private multimethods NYI
  863 + method !apply(Event $_) {
  864 + push @!events, $_;
  865 + when Adventure::TwoRoomsConnected {
  866 + my ($room1, $room2) = .rooms.list;
  867 + my $direction = .direction;
  868 + %!exits{$room1}{$direction} = $room2;
  869 + %!exits{$room2}{opposite $direction} = $room1;
  870 + }
  871 + when Adventure::TwoRoomsDisconnected {
  872 + my ($room1, $room2) = .rooms.list;
  873 + my $direction = .direction;
  874 + %!exits{$room1}.delete($direction);
  875 + %!exits{$room2}.delete(opposite $direction);
  876 + }
  877 + when Adventure::PlayerWalked {
  878 + $!player_location = .to;
  879 + }
  880 + when Adventure::PlayerWasPlaced {
  881 + $!player_location = .in;
  882 + }
  883 + when Adventure::DirectionAliased {
  884 + %!exit_aliases{.room}{.alias} = .direction;
  885 + }
  886 + when Adventure::ThingPlaced {
  887 + %!thing_rooms{.thing} = .room;
  888 + }
  889 + when Adventure::PlayerOpened {
  890 + %!open_things{.thing} = True;
  891 + }
  892 + when Adventure::ThingMadeAContainer {
  893 + %!containers{.thing} = True;
  894 + }
  895 + when Adventure::ThingMadeAPlatform {
  896 + %!platforms{.thing} = True;
  897 + }
  898 + when Adventure::ThingMadeReadable {
  899 + %!readable_things{.thing} = True;
  900 + }
  901 + when Adventure::ThingHidden {
  902 + %!hidden_things{.thing} = True;
  903 + }
  904 + when Adventure::ThingUnhidden {
  905 + %!hidden_things{.thing} = False;
  906 + }
  907 + when Adventure::ThingMadeCarryable {
  908 + %!carryable_things{.thing} = True;
  909 + }
  910 + when Adventure::PlayerTook {
  911 + %!thing_rooms{.thing} = 'player inventory';
  912 + }
  913 + when Adventure::PlayerDropped {
  914 + %!thing_rooms{.thing} = $!player_location;
  915 + }
  916 + when Adventure::ThingMadeImplicit {
  917 + %!implicit_things{.thing} = True;
  918 + }
  919 + when Adventure::RoomMadeDark {
  920 + %!dark_rooms{.room} = True;
  921 + }
  922 + when Adventure::ThingMadeALightSource {
  923 + %!light_sources{.thing} = True;
  924 + }
  925 + when Adventure::LightSourceSwitchedOn {
  926 + %!things_shining{.thing} = True;
  927 + }
  928 + when Adventure::PlayerPutIn {
  929 + %!thing_rooms{.thing} = "contents:{.in}";
  930 + }
  931 + when Adventure::PlayerPutOn {
  932 + %!thing_rooms{.thing} = "contents:{.on}";
  933 + }
  934 + when Adventure::GameFinished {
  935 + $!game_finished = True;
  936 + }
  937 + }
  938 +}
9 lib/Event.pm
... ... @@ -0,0 +1,9 @@
  1 +role Event {
  2 + method Str {
  3 + sub name($attr) { $attr.name.substr(2) }
  4 + sub value($attr) { $attr.get_value(self) }
  5 + sub attrpair($attr) { ":{name $attr}<{value $attr}>" }
  6 +
  7 + sprintf '%s[%s]', self.^name, ~map &attrpair, self.^attributes;
  8 + }
  9 +}
633 t/adventure-engine.t
... ... @@ -0,0 +1,633 @@
  1 +use v6;
  2 +use Test;
  3 +use Adventure::Engine;
  4 +
  5 +sub throws_exception(&code, $ex_type, $message, &followup = {;}) {
  6 + &code();
  7 + ok 0, $message;
  8 + if &followup {
  9 + diag 'Not running followup because an exception was not triggered';
  10 + }
  11 + CATCH {
  12 + default {
  13 + ok 1, $message;
  14 + my $type_ok = $_.WHAT === $ex_type;
  15 + ok $type_ok , "right exception type ({$ex_type.^name})";
  16 + if $type_ok {
  17 + &followup($_);
  18 + } else {
  19 + diag "Got: {$_.WHAT.gist}\n"
  20 + ~"Expected: {$ex_type.gist}";
  21 + diag "Exception message: $_.message()";
  22 + diag 'Not running followup because type check failed';
  23 + }
  24 + }
  25 + }
  26 +}
  27 +
  28 +{
  29 + my $engine = Adventure::Engine.new();
  30 +
  31 + my @rooms = <kitchen veranda>;
  32 + is $engine.connect(@rooms, my $direction = 'south'),
  33 + Adventure::TwoRoomsConnected.new(
  34 + :@rooms,
  35 + :$direction,
  36 + ),
  37 + 'connecting two rooms (+)';
  38 +}
  39 +
  40 +{
  41 + my $engine = Adventure::Engine.new();
  42 +
  43 + my $direction = 'oops';
  44 + throws_exception