BURKS 2/BURKS_AUG97.ISO/BURKS/LANGUAGE/ADA/LOVELACE/small.txt

Text File | 1997-04-10 | 42KB | 1,312 lines

--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--

with Occupants;
use  Occupants;

package Creatures is
 type Creature is abstract new Occupant with private;
 type Creature_Access   is access Creature'Class;
private
 type Creature is abstract new Occupant with null record;
end Creatures;

--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose.  It is provided "as is" without express
-- or implied warranty.
--
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--

with Ada.Characters.Handling;
use  Ada.Characters.Handling;

package body Directions is

 Abbreviations : constant String := "nsewud";

 procedure To_Direction(Text : in Unbounded_String;
                        Is_Direction : out Boolean;
                        Dir  : out Direction) is
  Lower_Text : String := To_Lower(To_String(Text));
  -- Attempt to turn "Text" into a direction.
  -- If successful, set "Is_Direction" True and "Dir" to the value.
  -- If not successful, set "Is_Direction" False and "Dir" to arbitrary value.
 begin
   if Length(Text) = 1 then
     -- Check if it's a one-letter abbreviation.
     for D in Direction'Range loop
       if Lower_Text(1) = Abbreviations(Direction'Pos(D) + 1) then
         Is_Direction := True;
         Dir := D;
         return;
       end if;
     end loop;
     Is_Direction := False;
     Dir := North;
     return;

   else
     -- Not a one-letter abbreviation, try a full name.
     for D in Direction'Range loop
       if Lower_Text = To_Lower(Direction'Image(D)) then
         Is_Direction := True;
         Dir := D;
         return;
       end if;
     end loop;
     Is_Direction := False;
     Dir := North;
     return;
   end if;
 end To_Direction;

 function To_Direction(Text : in Unbounded_String) return Direction is
   Is_Direction : Boolean;
   Dir          : Direction;
 begin
   To_Direction(Text, Is_Direction, Dir);
   if Is_Direction then
      return Dir;
   else
      raise Constraint_Error;
   end if;
 end To_Direction;

 function Is_Direction(Text : in Unbounded_String) return Boolean is
   Is_Direction : Boolean;
   Dir          : Direction;
 begin
   To_Direction(Text, Is_Direction, Dir);
   return Is_Direction;
 end Is_Direction;

end Directions;

--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose.  It is provided "as is" without express
-- or implied warranty.
--
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--

with Ada.Strings.Unbounded;
use  Ada.Strings.Unbounded;

package Directions is

 type Direction is (North, South, East, West, Up, Down);

 Reverse_Direction : constant array(Direction) of Direction :=
                    (North => South, South => North,
                     East =>West, West => East,
                     Up => Down, Down => Up);

 function To_Direction(Text : Unbounded_String) return Direction;
 -- Converts Text to Direction; raises Constraint_Error if it's not
 -- a legal direction.

 function Is_Direction(Text : Unbounded_String) return Boolean;
 -- Returns TRUE if Text is a direction, else false.

end Directions;

--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose.  It is provided "as is" without express
-- or implied warranty.
--
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--

package body Items is

 function May_I_Get(Direct_Object : access Item;
                    Agent : access Occupant'Class) return Boolean is
 begin
  return True;
 end May_I_Get;

end Items;

--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose.  It is provided "as is" without express
-- or implied warranty.
--
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--

with Occupants;
use  Occupants;

package Items is
 type Item     is new Occupant with private;
 type Item_Access       is access Item'Class;
 function May_I_Get(Direct_Object : access Item;
                    Agent : access Occupant'Class) return Boolean;

private
 type Item     is new Occupant with null record;

end Items;

--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose.  It is provided "as is" without express
-- or implied warranty.
--
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--

with Creatures;
use  Creatures;

package Monsters is
 type Monster is new Creature with private;
 type Monster_Access    is access Monster'Class;
private
 type Monster is new Creature with null record;
end Monsters;

--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose.  It is provided "as is" without express
-- or implied warranty.
--
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--

with Text_IO, Ada.Strings.Unbounded, Ustrings, Rooms;
use  Text_IO, Ada.Strings.Unbounded, Ustrings, Rooms;

package body Occupants is


 procedure Put_View(T : access Occupant; Agent : access Thing'Class) is
 begin
  Put("You are inside ");
  Put_Line(Short_Description(T));
  Put_Line(".");
  Put_Contents(T, Agent, "You see:");
 end Put_View;

 procedure Look(T : access Occupant) is
 -- T is running a "look" command; tell T what he views.
 begin
  if Container(T) = null then
    Put("You are inside nothing at all.");
  else
    Put_View(Container(T), T);
  end if;
 end Look;


 procedure Get(Agent : access Occupant; Direct_Object : access Occupant'Class)
 is
 begin
   if May_I_Get(Direct_Object, Agent) then
     Place(T => Direct_Object, Into => Thing_Access(Agent));
   end if;
 end Get;

 function May_I_Get(Direct_Object : access Occupant;
                    Agent : access Occupant'Class)
          return Boolean is
 begin
   Sorry("get", Name(Direct_Object));  -- Tell the getter sorry, can't get it
   return False;
 end May_I_Get;

 procedure Drop(Agent : access Occupant;
                Direct_