Examples

--
-- 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_Object : access Occupant'Class) is
 begin
   if May_I_Drop(Direct_Object, Agent) then
     Place(T => Direct_Object, Into => Container(Agent));
   end if;
 end Drop;
 
 function  May_I_Drop(Direct_Object : access Occupant;
                      Agent : access Occupant'Class)
           return Boolean is
 begin
   return True;
 end May_I_Drop;
 
 
 procedure Inventory(Agent : access Occupant) is
 begin
  Put_Contents(Agent, Agent,
               "You're carrying:",
               "You aren't carrying anything.");
 end Inventory;
 
 procedure Go(Agent : access Occupant; Dir : in Direction) is
 begin
  if Container(Agent) = null then
    Put_Line("Sorry, you're not in a room!");
  else
    declare
      Destination : Thing_Access := What_Is(Container(Agent), Dir);
    begin
     if Destination = null then
       Put_Line("Sorry, you can't go that way.");
     else
       Place(Agent, Destination);
     end if;
    end;
  end if;
 end Go;
 
end Occupants;
 
--
-- 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 Things, Directions;
use  Things, Directions;
 
package Occupants is
 
 -- An "Occupant" is a Thing that can be inside a Room or another Occupant.
 
 type Occupant is abstract new Thing with private;
 type Occupant_Access   is access all Occupant'Class;
 
 -- Dispatching subprograms:
 
 procedure Look(T : access Occupant);      -- Ask Occupant T to "look".
 
 procedure Get(Agent : access Occupant; Direct_Object : access Occupant'Class);
           -- Ask Agent to get Direct_Object.  This assumes that Agent can
           -- somehow access Direct_Object (i.e. is in the same room).
           -- If the agent decides that it can get the object, it will
           -- call May_I_Get to ask the object if that's okay.
 
 procedure Drop(Agent : access Occupant; Direct_Object : access Occupant'Class);
           -- Ask Agent to drop Direct_Object.
 
 procedure Inventory(Agent : access Occupant);
           -- Ask Agent to print a list of what Agent is carrying.
 
 procedure Go(Agent : access Occupant; Dir : in Direction);
            -- Ask Agent to go the given Direction Dir (North, South, etc.)
 
 procedure Put_View(T : access Occupant; Agent : access Thing'Class);
            -- Override Thing's Put_View.
 
 function May_I_Get(Direct_Object : access Occupant;
                    Agent : access Occupant'Class) return Boolean;
           -- Ask Direct_Object if "Agent" can get this object.
           -- Returns True if it's okay, else False.
           -- If the object does something while being gotten (or an attempt
           -- to do so) it does it in this call.
 
 function  May_I_Drop(Direct_Object : access Occupant;
                      Agent         : access Occupant'Class) return Boolean;
           -- Ask Direct_Object if "Agent" can drop this object;
           -- returns True if it's okay.
 
private
 
 type Occupant is abstract new Thing with
  record
    null;  -- Nothing here for now.
  end record;
 
end Occupants;
 
--
-- 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.Maps.Constants, Ustrings, Things, Occupants, World;
use  Text_IO, Ada.Strings.Maps.Constants, Ustrings, Things, Occupants, World;
use  Ada.Strings, Ada.Strings.Maps;
 
with Directions;
use  Directions;
 
package body Parser is
 
 Spaces : constant Character_Set := To_Set(' ');
 
 procedure Split(Source     : in  Unbounded_String;
                 First_Word : out Unbounded_String;
                 Rest       : out Unbounded_String) is
  First : Positive; -- Index values of first word.
  Last  : Natural;
 -- Puts first word of Source into First_Word, the rest of the words in Rest
 -- (without leading spaces); words are separated by one or more spaces;
 -- if there are no spaces, Rest returns empty.
 begin
  Find_Token(Source, Spaces, Outside, First, Last);
  First_Word := U(Slice(Source, First, Last));
  Rest       := Trim(U(Slice(Source, Last + 1, Length(Source))), Left);
 end Split;
 
 
 
 procedure Execute(Command : in Unbounded_String; Quit : out Boolean) is
  Trimmed_Command : Unbounded_String := Trim(Command, Both);
  Verb, Arguments, First_Argument, Rest_Of_Arguments : Unbounded_String;
  Direct_Object : Occupant_Access;
 begin
  Quit := False; -- By default assume we won't quit.
  if (Empty(Trimmed_Command)) then
    return;      -- Ignore blank lines.
  end if;
 
  -- Extract Verb and First_Argument and force them to lower case.
  Split(Trimmed_Command, Verb, Arguments);
  Translate(Verb, Lower_Case_Map);
  Split(Arguments, First_Argument, Rest_Of_Arguments);
  Translate(First_Argument, Lower_Case_Map);
 
 
  -- Try to execute "Verb".
 
  if    Verb = "look" then
    Look(Me);
  elsif Verb = "get" then
    Direct_Object := Occupant_Access(Find(Me, First_Argument));
    if Direct_Object /= null then
      Get(Me, Direct_Object);
    end if;
  elsif Verb = "drop" then
    Direct_Object := Occupant_Access(Find_Inside(Me, First_Argument));
    if Direct_Object /= null then
      Drop(Me, Direct_Object);
    end if;
  elsif Verb = "inventory" or Verb = "inv" then
    Inventory(Me);
  elsif Verb = "quit" then
    Quit := True;
  elsif Verb = "go" and then Is_Direction(First_Argument) then
    Go(Me, To_Direction(First_Argument));
    Look(Me);
  elsif Is_Direction(Verb) then  -- Is the verb a direction (north, etc)?
    Go(Me, To_Direction(Verb));
    Look(Me);
  elsif Verb = "help" then
    Put_Line("Please type in one or two word commands, beginning with a verb");
    Put_Line("or direction. Directions are north, south, east, west, etc.");
    Put_Line("Here are some sample commands:");
    Put_Line("look, get box, drop box, inventory, go west, west, w, quit.");
  else
   Put_Line("Sorry, I don't recognize that verb. Try 'help'.");
  end if;
 
 end Execute;
end Parser;
 
--
-- 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 Parser is
 procedure Execute(Command : in Unbounded_String; Quit : out Boolean);
   -- Executes the given command.
   -- Sets Quit to False if the user may run additional commands.
end Parser;
 
--
-- 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 Players is
 type Player  is new Creature with private;
 type Player_Access     is access Player'Class;
private
 type Player  is new Creature with null record;
end Players;
 
--
-- 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, Ustrings;
use  Text_IO, Ustrings;
 
package body Rooms is
 
 procedure Connect(Source : access Room; Dir : in Direction;
                   Destination : access Thing'Class;
                   Bidirectional : in Boolean := True) is
 begin
   Source.Destinations(Dir) := Thing_Access(Destination);
   if Bidirectional then  -- Connect in reverse direction.
     Room_Access(Destination).Destinations(Reverse_Direction(Dir)) :=
              Thing_Access(Source);
   end if;
 end Connect;
 
 procedure Disconnect(Source : access Room; Dir : in Direction;
                      Bidirectional : in Boolean := True) is
 begin
   if Bidirectional then
     -- If it's bidirectional, remove the other direction. The following "if"
     -- statement, if uncommented, checks to make sure that
     -- disconnecting a bidirectional link only happens to a Room.
     -- if (Source.Destinations(Dir).all'Tag in Room'Class) then
       Room_Access(Source.Destinations(Dir)).
                   Destinations(Reverse_Direction(Dir)) := null;
     -- end if;
   end if;
   Source.Destinations(Dir) := null;
 end Disconnect;
 
 function What_Is(From : access Room; Dir : in Direction) return Thing_Access is
 begin
  return From.Destinations(Dir);
 end What_Is;
 
 procedure Put_View(T : access Room; Agent : access Thing'Class) is
 begin
  Put("You are ");
  Put(Long_Description(T));
  Put_Line(".");
  Put_Contents(T, Agent, "You see:");
 end Put_View;
 
end Rooms;
 
--
-- 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 Things, Directions;
use  Things, Directions;
 
package Rooms is
 type Room     is new Thing with private;
 type Room_Access       is access all Room'Class;
 
 procedure Put_View(T : access Room; Agent : access Thing'Class);
 
 procedure Connect(Source : access Room; Dir : in Direction;
                   Destination : access Thing'Class;
                   Bidirectional : in Boolean := True);
  -- Create a connection from Source to Destination in Direction Dir.
  -- If it's bidirectional, create another connection the reverse way.
 
 procedure Disconnect(Source : access Room; Dir : in Direction;
                      Bidirectional : in Boolean := True);
 -- Reverse of connect; disconnects an existing connection, if any.
 
 function What_Is(From : access Room; Dir : in Direction) return Thing_Access;
 -- Returns what is at direction "Dir" from "From".
 -- Returns null if nothing connected in that direction.
 
private
 
 type Destination_Array is array(Direction) of Thing_Access;
 
 type Room     is new Thing with
  record
    Destinations : Destination_Array;
  end record;
 
end Rooms;
 
--
-- 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.
--
 
-- Main routine to start up "Small", a small text adventure game to
-- demonstrate Ada 95.
 
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--
 
-- For documentation see the following URL:
--   http://www.adahome.com//Tutorials/Lovelace/small.htm
 
with Text_IO, Ada.Strings.Unbounded, Ustrings, World;
use  Text_IO, Ada.Strings.Unbounded, Ustrings;
 
with Parser;
 
procedure Small is
  Command : Unbounded_String; -- Contains user's current command.
  Quit    : Boolean := False;
begin
 Put_Line("Welcome to a Small World!");
 
 World.Setup;
 
 while not Quit loop
  New_Line;
  Put_Line("Your Command?");
  Get_Line(Command);
  Parser.Execute(Command, Quit);
 end loop;
 
 Put_Line("Bye!");
end Small;
 
--
-- 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, Ustrings;
use  Text_IO, Ustrings;
 
 
package body Things is
 
 -- Define basic types for the world and their operations.
 
 
 -- Supporting Subprograms:
 
 procedure Sorry(Prohibited_Operation : String;
                 Prohibited_Direct_Object : Unbounded_String) is
 begin
  Put_Line("Sorry, you may not " & Prohibited_Operation & " the " &
           S(Prohibited_Direct_Object));
 end Sorry;
 
 
 -- Routines to manipulate First_Containee, Next_Sibling, Container:
 
 function Previous_Sibling(Containee : access Thing'Class)
          return Thing_Access is
  -- Find the previous sibling of containee.  It's an error to call
  -- this if Containee has no previous sibling.
    Current : Thing_Access := Containee.Container.First_Containee;
 begin
    while Current.Next_Sibling /= Thing_Access(Containee) loop
      Current := Current.Next_Sibling;
    end loop;
    return Current;
 end Previous_Sibling;
 
 function Last_Containee(Container : access Thing'Class)
          return Thing_Access is
   -- Return an access value of the last contained Thing in container.
   -- It's an error to call this routine if there are no containees.
    Current : Thing_Access := Container.First_Containee;
 begin
    while Current.Next_Sibling /= null loop
      Current := Current.Next_Sibling;
    end loop;
    return Current;
 end Last_Containee;
 
 procedure Remove(Containee : access Thing'Class) is
 -- Remove Containee from its current Container.
  Previous_Thing : Thing_Access;
 begin
  if Containee.Container /= null then
    if Containee.Container.First_Containee = Thing_Access(Containee) then
       -- Containee is the first Thing in its container.
       Containee.Container.First_Containee := Containee.Next_Sibling;
    else
       Previous_Thing := Previous_Sibling(Containee);
       Previous_Thing.Next_Sibling := Containee.Next_Sibling;
    end if;
    Containee.Next_Sibling := null;
    Containee.Container    := null;
  end if;
 end Remove;
 
 
 procedure Place(T : access Thing'Class; Into : Thing_Access) is
 -- Place "T" inside "Into".
  Last : Thing_Access;
 begin
  if (Thing_Access(T) = Into) then
    Put_Line("Sorry, that can't be done.");
    return;
  end if;
  Remove(T); -- Remove Thing from where it is now.
  if Into /= null then
    if Into.First_Containee = null then
      Into.First_Containee := Thing_Access(T);
    else
      Last := Last_Containee(Into);
      Last.all.Next_Sibling := Thing_Access(T);
    end if;
  end if;
  T.Container := Into;
 end Place;
 
 procedure Put_Contents(T : access Thing'Class;
                        Ignore : access Thing'Class;
                        Heading_With_Contents : in String;
                        Heading_Without_Contents : in String := "") is
   -- Put a description of the contents of T.
   -- If there is something, print Heading_With_Contents;
   -- If there isn't something, print Heading_Without_Contents.
   -- Ignore The_Player, since presumably the player already knows about
   -- him/herself.
   Current : Thing_Access := T.First_Containee;
   Have_Put_Something : Boolean := False;
 begin
  while Current /= null loop
    if Current /= Thing_Access(Ignore) then
      -- This what we're to ignore, print it out.
      if Have_Put_Something then
        Put(", ");
      else
        -- We're about to print the first item; print the heading.
        Put_Line(Heading_With_Contents);
      end if;
      Put(Short_Description(Current));
      Have_Put_Something := True;
    end if;
    Current := Current.Next_Sibling;
  end loop;
  if Have_Put_Something then
    Put_Line(".");
  elsif Heading_With_Contents'Length > 0 then
    Put_Line(Heading_Without_Contents);
  end if;
 end Put_Contents;
 
 
 -- Dispatching Operations:
 
 function What_Is(From : access Thing; Dir : in Direction)
          return Thing_Access is
 begin
   return null; -- As a default, you can't go ANY direction from "here".
 end What_Is;
 
 
 -- Non-dispatching public operations:
 
 procedure Set_Name(T : access Thing'Class; Article : in Article_Type;
                    Name : in Unbounded_String) is
 begin
   T.Article := Article;
   T.Name    := Name;
 end Set_Name;
 
 procedure Set_Name(T : access Thing'Class; Article : in Article_Type;
                    Name : in String) is
 begin
   T.Article := Article;
   T.Name    := To_Unbounded_String(Name);
 end Set_Name;
 
 function Name(T : access Thing'Class) return Unbounded_String is
 begin
  return T.Name;
 end Name;
 
 procedure Set_Description(T : access Thing'Class;
                           Description : in Unbounded_String) is
 begin
  T.Description := Description;
 end Set_Description;
 
 procedure Set_Description(T : access Thing'Class;
                           Description : in String) is
 begin
  T.Description := To_Unbounded_String(Description);
 end Set_Description;
 
 function Long_Description(T : access Thing'Class) return Unbounded_String is
 begin
   return T.Description;
 end Long_Description;
 
 
 -- Eventually we'll use an array for the article, but a minor GNAT 2.7.0 bug
 -- will cause this to raise a Segmentation Fault when the program quits:
 -- Article_Text : constant array(Article_Type) of Unbounded_String :=
 --     (A => U("a "), An => U("an "), The => U("the "), Some => U("some "),
 --      None => U(""));
 
 function Short_Description(T : access Thing'Class) return Unbounded_String is
 begin
  case T.Article is
   when A    => return "a "    & T.Name;
   when An   => return "an "   & T.Name;
   when The  => return "the "  & T.Name;
   when Some => return "some " & T.Name;
   when None => return           T.Name;
  end case;
  -- Should become return Article_Text(T.Article) & T.Name;
 end Short_Description;
 
 function Find(Agent : access Thing'Class;
               Object_Name : in Unbounded_String) return Thing_Access is
 begin
   if Agent.Container = null then
     Put_Line("You aren't in anything.");
     return null;
   else
     return Find_Inside(Agent.Container, Object_Name);
   end if;
 end Find;
 
 function Find_Inside(Agent : access Thing'Class;
                      Object_Name : in Unbounded_String)
          return Thing_Access is
   Current : Thing_Access := Agent.First_Containee;
 begin
   if Empty(Object_Name) then
     Put_Line("Sorry, you need to name an object.");
     return null;
   end if;
   while Current /= null loop
     if Current.Name = Object_Name then
       return Current;
     end if;
     Current := Current.Next_Sibling;
   end loop;
   Put("Sorry, I don't see a ");
   Put_Line(Object_Name);
   return null;
 end Find_Inside;
 
 function Container(T : access Thing'Class) return Thing_Access is
 begin
   return T.Container;
 end Container;
 
 function Has_Contents(T : access Thing'Class) return Boolean is
 begin
   if T.First_Containee = null then
     return False;
   else
     return True;
   end if;
 end Has_Contents;
 
end Things;
 
--
-- 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, Ada.Finalization, Directions;
use  Ada.Strings.Unbounded, Ada.Finalization, Directions;
 
package Things is
 
 -- "Thing" is the root class for all things in this small world.
 -- Rooms, Players, Items, and Monsters are derived from Thing.
 
 
 type Thing is abstract new Limited_Controlled with private;
 type Thing_Access is access all Thing'Class;
 
 type Article_Type is (A, An, The, Some, None);
 
 -- Public Dispatching operations.
 
 procedure Put_View(T : access Thing; Agent : access Thing'Class) is abstract;
  -- Put what Agents sees inside T.
 
 function What_Is(From : access Thing; Dir : in Direction) return Thing_Access;
 -- Returns what is at direction "Dir" from "From".
 -- Returns null if nothing connected in that direction.
 
 -- Public non-Dispatching operations:
 
 procedure Set_Name(T : access Thing'Class; Article : in Article_Type;
                    Name : in Unbounded_String);
 procedure Set_Name(T : access Thing'Class; Article : in Article_Type;
                    Name : in String);
 function Name(T : access Thing'Class) return Unbounded_String;
 pragma Inline(Name);
 
 function Short_Description(T : access Thing'Class) return Unbounded_String;
 -- Returns Article + Name, i.e. "the box", "a car", "some horses".
 
 procedure Set_Description(T : access Thing'Class;
                           Description : in Unbounded_String);
 procedure Set_Description(T : access Thing'Class;
                           Description : in String);
 function Long_Description(T : access Thing'Class) return Unbounded_String;
 
 procedure Place(T : access Thing'Class; Into : Thing_Access);
   -- Place T inside "Into" (removing it from wherever it was).
   -- Attempting to place T into itself will print an error message
   -- and fail.
   -- The second parameter is Thing_Access, not Thing'Class, because
   -- "null" is a valid value for "Into".
 function Container(T : access Thing'Class) return Thing_Access;
   -- Return access value to the container of T.
 function Has_Contents(T : access Thing'Class) return Boolean;
   -- Does T have anything in it?
 
 function Find(Agent : access Thing'Class;
               Object_Name : in Unbounded_String) return Thing_Access;
          -- Find the given Object_Name in the same container as the agent.
          -- Prints and error message and returns null if not found.
 
 function Find_Inside(Agent       : access Thing'Class;
                      Object_Name : in Unbounded_String)
          return Thing_Access;
          -- Find the given Object_Name inside the agent.
          -- Prints and error message and returns null if not found.
 
 procedure Put_Contents(T : access Thing'Class;
                        Ignore : access Thing'Class;
                        Heading_With_Contents : in String;
                        Heading_Without_Contents : in String := "");
   -- Put a description of the contents of T.
   -- Act as though "Ignore" isn't there.
   -- If there is something, print Heading_With_Contents;
   -- If there isn't something, print Heading_Without_Contents.
 
 procedure Sorry(Prohibited_Operation : String;
                 Prohibited_Direct_Object : Unbounded_String);
   -- Put "Sorry, you may not XXX the YYY".
 
 
private
 
 type Thing is abstract new Limited_Controlled with
  record
   Name, Description : Unbounded_String;
   Article           : Article_Type := A;
   Container         : Thing_Access; -- what Thing contains me?
   Next_Sibling      : Thing_Access; -- next Thing in my container.
   First_Containee   : Thing_Access; -- first Thing inside me.
  end record;
 
end Things;
 
--
-- 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 Ustrings is
 
  Input_Line_Buffer_Length : constant := 1024;
    -- If an input line is longer, Get_Line will recurse to read in the line.
 
 
  procedure Swap(Left, Right : in out Unbounded_String) is
    -- Implement Swap.  This is the portable but slow approach.
    Temporary : Unbounded_String;
  begin
    Temporary := Left;
    Left := Right;
    Right := Temporary;
  end Swap;
 
  function Empty(S : Unbounded_String) return Boolean is
   -- returns True if Length(S)=0.
  begin
   return (Length(S) = 0);
  end Empty;
 
 
  -- Implement Unbounded_String I/O by calling Text_IO String routines.
 
 
  -- Get_Line gets a line of text, limited only by the maximum number of
  -- characters in an Unbounded_String.  It reads characters into a buffer
  -- and if that isn't enough, recurses to read the rest.
 
  procedure Get_Line (File : in File_Type; Item : out Unbounded_String) is
 
    function More_Input return Unbounded_String is
       Input : String (1 .. Input_Line_Buffer_Length);
       Last  : Natural;
    begin
       Get_Line (File, Input, Last);
       if Last < Input'Last then
          return   To_Unbounded_String (Input(1..Last));
       else
          return   To_Unbounded_String (Input(1..Last)) & More_Input;
       end if;
    end More_Input;
 
  begin
      Item := More_Input;
  end Get_Line;
 
 
  procedure Get_Line(Item : out Unbounded_String) is
  begin
    Get_Line(Current_Input, Item);
  end Get_Line;
 
  procedure Put(File : in File_Type; Item : in Unbounded_String) is
  begin
    Put(File, To_String(Item));
  end Put;
 
  procedure Put(Item : in Unbounded_String) is
  begin
    Put(Current_Output, To_String(Item));
  end Put;
 
  procedure Put_Line(File : in File_Type; Item : in Unbounded_String) is
  begin
    Put(File, Item);
    New_Line(File);
  end Put_Line;
 
  procedure Put_Line(Item : in Unbounded_String) is
  begin
    Put(Current_Output, Item);
    New_Line;
  end Put_Line;
 
end Ustrings;
 
--
-- 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;
use  Text_IO, Ada.Strings.Unbounded;
 
package Ustrings is
 
  -- This package provides a simpler way to work with type
  -- Unbounded_String, since this type will be used very often.
  -- Most users will want to ALSO with "Ada.Strings.Unbounded".
  -- Ideally this would be a child package of "Ada.Strings.Unbounded".
  --
 
  -- This package provides the following simplifications:
  --  + Shortens the type name from "Unbounded_String" to "Ustring".
  --  + Creates shorter function names for To_Unbounded_String, i.e.
  --    To_Ustring(U) and U(S).  "U" is not a very readable name, but
  --    it's such a common operation that a short name seems appropriate
  --    (this function is needed every time a String constant is used).
  --    It also creates S(U) as the reverse of U(S).
  --  + Adds other subprograms, currently just "Swap".
  --  + Other packages can use this package to provide other simplifications.
 
  subtype Ustring is Unbounded_String;
 
  function To_Ustring(Source : String)  return Unbounded_String
                                         renames To_Unbounded_String;
  function U(Source : String)           return Unbounded_String
                                         renames To_Unbounded_String;
  function S(Source : Unbounded_String) return String
                                         renames To_String;
 
  -- "Swap" is important for reuse in some other packages, so we'll define it.
 
  procedure Swap(Left, Right : in out Unbounded_String);
 
 
  function Empty(S : Unbounded_String) return Boolean;
   -- returns True if Length(S)=0.
  pragma Inline(Empty);
 
 
  -- I/O Routines.
  procedure Get_Line(File : in File_Type; Item : out Unbounded_String);
  procedure Get_Line(Item : out Unbounded_String);
 
  procedure Put(File : in File_Type; Item : in Unbounded_String);
  procedure Put(Item : in Unbounded_String);
 
  procedure Put_Line(File : in File_Type; Item : in Unbounded_String);
  procedure Put_Line(Item : in Unbounded_String);
 
end Ustrings;
 
--
-- 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;
use  Text_IO, Ada.Strings.Unbounded, Ustrings;
 
with Things, Players, Items, Rooms, Directions;
use  Things, Players, Items, Rooms, Directions;
 
package body World is
 
 The_Player : Player_Access;    -- This is the object representing the
                                -- current player.
 
 
 procedure Setup is
   Starting_Room : Room_Access := new Room;
   Box           : Item_Access := new Item;
   Knife         : Item_Access := new Item;
   Living_Room   : Room_Access := new Room;
 begin
   Set_Name(Starting_Room, The, "Hallway");
   Set_Description(Starting_Room, "in the hallway. There is a living room " &
                   "to the west");
 
   Set_Name(Box, A, "box");
   Set_Description(Box, "a red box");
   Place(T => Box, Into => Thing_Access(Starting_Room));
 
   Set_Name(Knife, A, "knife");
   Set_Description(Box, "a black knife");
   Place(T => Knife, Into => Thing_Access(Starting_Room));
 
   Set_Name(Living_Room, The, "Living Room");
   Set_Description(Living_Room, "in the living room. " &
                                "A hallway is to your east");
   Connect(Starting_Room, West, Living_Room);
 
   -- Setup player.
   The_Player := new Player;
   Set_Name(The_Player, None, "Fred");
   Set_Description(The_Player, Name(The_Player));
   Place(T => Me,  Into => Thing_Access(Starting_Room));
   Look(Me);
 
 end Setup;
 
 
 function Me return Occupant_Access is
  -- Return access value to current player.
 begin
  return Occupant_Access(The_Player);
 end Me;
 
end World;
 
--
-- 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 World is
 
 procedure Setup;
  -- Setup the World; initialize the contents of the world.
 
 
 function Me return Occupant_Access;
           -- Return an access variable pointing to the current player.
 
end World;
 
--
-- 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.
-- 

This category contains 3 examples, and has been viewed 41898 times.

• Multitasking - Using a rendezvous to ensure multi-threading under DOS (7771 views)
• Hello World! - A simple ADA example (7916 views)
• Small - A small text adventure game, written in ADA (9509 views)