Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

I pulled together a small, working mini adevnture. I decided to split the definition of objects and rooms into two different hashes.

Objects can also be in a virtual room (like the "inventory" room i use here. But you can also send them into a non-existing room to make them go away or vice versa.

The anonymous subs also allow you to change objects and rooms as you wish. For example, a closed door might have an action "open" that rewrites it's own description as well as adding an exit to the room. Closing that door again can do the opposite (return original description, remove the rooms exit)

Here's the code:

#!/usr/bin/env perl use strict; use warnings; # Current location of player and a helper variable my $location = 'lounge'; my $oldlocation = ''; # define some rooms to have, uh, room to run around my %rooms = ( lounge => { name => 'The Lounge', description => 'You are in the lounge, a rather gloomy place.' +, exits => { 'west' => 'cavern1', 'east' => 'monastery', }, }, 'cavern1' => { name => 'Dark cavern', description => 'You are in a dark cavern. Bloodstains mare the + walls', exits => { east => 'lounge', west => 'cavern2', }, }, 'cavern2' => { name => 'Completly dark cavern', description => 'You are in a very dark cavern. You hear strang +e noises, but the only thing you can see is a glimmer from the easter +n entrance.', exits => { east => 'cavern1', west => sub {die "You get eaten by a grue!";}, north => sub { print "A hyperdimensional field wraps you in color +ed lights.\n"; sleep(10); print "You feel like you are beeing pulled into a +randomly selected room...\n"; sleep(10); if(rand(100) > 50) { $location = 'cavern1'; } else { $location = 'lounge'; } print "You materialize in...\n"; sleep(10); }, south => sub {die "NO-COFFEE-ERROR: Unimplemented room!" +;}, }, }, 'monastery' => { name => 'The Monastery', description => 'You are in the monastery. All around you, g +eeks are writing Perl code.', exits => { west => 'lounge', }, }, ); # Put some stuff in that room my %objects = ( 'table' => { location => 'lounge', short => 'a small wooden table', long => 'It\'s a small, wooden table. It looks cheap.', actions => { take => 'You put the wooden table in your magic pocket. +', drop => 'You carefully put down the table.', }, }, 'monk' => { location => 'monastery', short => 'a Perl monk', long => 'A scruffy guy with long hair and a T-Shirt that re +ads "touch() && die()"\n', actions => { touch => sub{ print "You touch the monk. He instantly send SIGNAL 11 + back to you\n"; die; }, }, }, 'book' => { location => 'inventory', short => 'a pocket book', long => 'It\'s the Perl regular expression reference guide +pocket book.', actions => { take => 'You jump up and down in joy!', drop => 'Your mood suddenly changes for the worse :-(', read => 'You suddenly feel much smarter.', }, }, 'sign' => { location => 'monastery', short => 'a sign', long => 'A big warning sign with big red letters!', actions => { read => 'It says: "TYE BROKE THE MONASTERY!"', }, }, ); while(1) { #print the room description if($location ne $oldlocation) { $oldlocation = $location; print "\n\n"; print $rooms{$location}->{name}, "\n"; print '=' x length($rooms{$location}->{name}), "\n\n"; if(!defined($rooms{$location}->{visited}) || !$rooms{$location +}->{visited}) { $rooms{$location}->{visited} = 1; print $rooms{$location}->{description}, "\n"; } print "You see:\n"; foreach my $key (sort keys %objects) { if($objects{$key}->{location} eq $location) { print " ", $objects{$key}->{short}, "\n"; } } print "There are exits in this direction(s): ", join(',', sort + keys %{$rooms{$location}->{exits}}), "\n"; } # Ask the player what to do print "What next: "; my $cmd = <>; # Primitively clean up the input chomp $cmd; $cmd = lc $cmd; $cmd =~ s/(\s+)/\ /g; $cmd =~ s/^\ //; $cmd =~ s/\ $//; next if($cmd eq ''); # allow the player to finish if($cmd =~ /(quit|exit)/i) { print "Goodbye.\n"; last; } # We don't like nice users. Just state what you want! if($cmd =~ /please/i) { print "I don't know how to please!\n"; next; } # Force re-displaying the room description if($cmd eq 'look') { $oldlocation = ''; $rooms{$location}->{visited} = 0; next; } # Wanna take us to another room? if(defined($rooms{$location}->{exits}->{$cmd})) { # Check to see if its a code section, else just move # the player to that room if(ref($rooms{$location}->{exits}->{$cmd}) eq 'CODE') { $rooms{$location}->{exits}->{$cmd}->(); } else { $location = $rooms{$location}->{exits}->{$cmd}; } next; } # The inventory command if($cmd eq 'inventory') { print "Your open pocket reveals:\n"; foreach my $key (sort keys %objects) { if($objects{$key}->{location} eq 'inventory') { print " ", $objects{$key}->{short}, "\n"; } } } # Look for a simple two-verb command if($cmd =~ /(\w+)\ (\w+)/) { my ($verb, $thing) = ($1, $2); # Check if the object exists if(!defined($objects{$thing})) { print "Sorry, the programmer never invented a $thing!\n"; next; } # Ok, next, let's see if the object is in reach if($objects{$thing}->{location} ne 'inventory' && $objects{$th +ing}->{location} ne $location) { print "You can't see $thing anywhere near you!\n"; next; } # Allow "describe" action if($verb eq "describe") { print $objects{$thing}->{long}, "\n"; next; } # Check if it is an allowed action for this object if(!defined($objects{$thing}->{actions}->{$verb})) { print "You can't do that to $thing\n"; next; } # First of all, if the action is a sub, execute it and be done + with it. if(ref($objects{$thing}->{actions}->{$verb}) eq 'CODE') { $objects{$thing}->{actions}->{$verb}->(); next; } # Inventory-related actions if($verb eq 'take') { if($objects{$thing}->{location} eq 'inventory') { print "You already have that in your magic pocket!\n"; next; } $objects{$thing}->{location} = 'inventory'; print $objects{$thing}->{actions}->{$verb}, "\n"; next; } if($verb eq 'drop') { if($objects{$thing}->{location} ne 'inventory') { print "You can't find that object anywhere within your + vast magic pocket!\n"; next; } $objects{$thing}->{location} = $location; print $objects{$thing}->{actions}->{$verb}, "\n"; next; } # Uhm, ok, this seems to be a text-printing-only action, like +reading a sign print $objects{$thing}->{actions}->{$verb}, "\n"; next; } # Scratch head and try again if(rand(100) > 50) { print "Sorry, could you state that more clearly?\n"; } else { print "I'll just stand around scratching my head instead...\n" +; } }

Of course, you might want to split all the room and object definitions into multiple files.

"You have reached the Monastery. All our helpdesk monks are busy at the moment. Please press "1" to instantly donate 10 currency units for a good cause or press "2" to hang up. Or you can dial "12" to get connected directly to second level support."

In reply to Re: Perl Moo. by cavac
in thread Perl Moo. by Dipseydoodle

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    [jedikaiti]: RonW++ #I have so much accumulated in my memory that finding the right item at a given moment often fails
    [LanX]: corion only > 800 lines
    [stevieb]: ahhh you're talking about the actual Makefile, not the PP Makefile.PL
    [Corion]: LanX: But most of that is just setup of variables to be used later, like CC , LIB etc.
    [LanX]: yes and some builders try to avoid it
    [RonW]: :)

    How do I use this? | Other CB clients
    Other Users?
    Others about the Monastery: (6)
    As of 2017-08-18 21:06 GMT
    Find Nodes?
      Voting Booth?
      Who is your favorite scientist and why?

      Results (310 votes). Check out past polls.