Abstract Factories Revisited

In this article I discuss an alternate version of the abstract factory,
implemented using static polymorphism.

The example also uses the smart pointer pattern to take care of memory
management, and declares a singleton instance of an abstract data type.


Discussion

Way back when I showed how to implement the abstract factory pattern in
Ada95, using an example that more or less followed the one in the GoF
book.

In that version, the abstract factory is implemented as a class.  You
decide which kind of factory you want, and declare an instance of that
specific type, which gets elaborated during program initialization.

Ed Colbert gave me the idea that the abstract factory could be
implemented as a library-level renaming of another package.  What a
great idea!  Static polymorphism without it being a generic.

In this alternate version of the abstract factory pattern, I got rid of
the factory types, and just implemented factories as packages with an
identical interface.  The actual factory that is used as _the_ factory
is chosen by way of a library-level renaming.

If you recall, the example from the book was a maze game, in which you
enter rooms, doors, and walls.  Another version of the game features
"enchanted" maze items, and you select which version of the game you
want by choosing a different factory.

What we do here is first declare a family of maze item types, then
create a (singleton) maze object, using the factory to select the maze
items.  You get a maze whose behavior changes based on which factory you
use.


Implementation

When implementing a hierarchy of tagged types, I usually do the
following things:

o implement the root type as indefinite and limited

o have each derived type in the class export a constructor that returns
a (smart) pointer to that specific type

o have the primitive operations of the type take access parameters, so
that there's no need to explicitly dereference the return value of the
constructor (an access object)

o declare a primitive operation that's private (not visible to clients
outside of the package hierarchy), to deallocate instances of the type

Making the type limited and indefinite prevents clients from creating
instances themselves.  We want to force them to draw new instances from
a pool maintained by the package, by calling a constructor for the type.

The constructor returns a smart pointer, which relieves clients from the
burden of having to manually reclaim instances of the type.  This
eliminates memory leaks and dangling references.

We use this idiom for maze doors, walls, and rooms.  Package Mazes forms
the root of the subsystem, which is where we declare the root type:

package Mazes is

   type Maze_Item (<>) is abstract tagged limited private;
...
end Mazes;

There are two primitive operations for the type, and both take access
parameters (though for different reasons).  First, you can enter a maze
item:

   procedure Enter (Item : access Maze_Item) is abstract;

which in our example just prints out a message about what kind of maze
item you've entered.

Second, when there are no more references to an object, the smart
pointer automatically returns the item to storage by calling Free:

   procedure Free (Item : access Maze_Item);

In order to prevent clients from calling Free directly, we declare it in
the private part of the spec.  Note that we can't make it abstract,
because abstract operations must be publicly declared, so we provide a
default implementation that does nothing.

That last thing of interest in Mazes is the declaration of the smart
pointer:

   type Maze_Handle is private;

   function "+" (Handle : Maze_Handle) return Maze_Item_Access;

The identity operator "+" is used to convert from a handle to an access
object with only a small amount of syntactic overhead.  The conversion
is necessary because the primitive operations take Maze_Item as a
parameter, not Maze_Handle.

Note that there's nothing that prevents a client from making a copy of
the access object returned by the selector.  We just depend on Good Will
to always "dereference" a handle, never an access object:

  declare
    Wall : constant Maze_Handle := New_Wall;
  begin
    ... +Wall ...


(There is talk about extending the language to allow access types to be
limited, which would solve this potential problem.  For now, you're
going to have to promise me you'll be good, and only copy handles.)

We were lucky when we implemented Bool_Exps using smart pointers,
because the only interesting operations were operations that applied to
the entire class (were primitive for the root type).

Here, things get a little tricky, because Room and Door items declare
their own primitive operations.  In order to call a Room operation, we
need a Room view of the object, but "+" for Handle only returns a
Maze_Item view.  What do we do?

There are also times when we want the handle we've got to point to a
specific type.  For example, a Door can only be attached to Rooms.  If
we always manipulate Maze_Handles, we lose the ability to catch some
type mismatch errors statically.

Other times, we really don't care what kind of maze item we have.  A
Room, for example, doesn't care what it's attached to (it can be a door,
a wall, or even another room).  So we seem to be at an impasse.

However, I was able to solve these problems by declaring a different
handle type for each specific type in the hierarchy, and including an
operation to convert from the specific handle to the general handle.

The handle also provides a selector to return the specific view of the
maze item, allowing you to call primitive operations of the specific
type without any messy down-casts.

The Rooms package looks like this:

package Mazes.Rooms is

   type Maze_Room is new Maze_Item with private;

   


   type Room_Handle is private;

   function New_Room return Room_Handle;

   function "+"
     (Handle : Room_Handle) return Maze_Room_Access;

   function "+"
     (Handle : Room_Handle) return Maze_Handle;

   ...
end Mazes.Rooms;


The Room_Handle thus provides a static guarantee to a client (like Door)
that his handle is pointing at a Room, not some other kind of maze item:

  declare
     Room : constant Room_Handle := New_Room;
     Door : constant Door_Handle := New_Door;
  begin
     Set_Number (+Room, Number => 13);

     ... Get_Side (+Room, North) ...

     Set_Room (+Door, Front, Room);
  end;


Doors and Walls are implemented similarly.

Enchanted maze items derive from their unenchanted counterparts, and
just override the Enter operation to print out a different message.  (Of
course, they also provide their own constructor too.)

Armed with all these maze items, now it's time to actually build a maze.

Knowing that there's only going to be one maze, we can apply the
singleton pattern to ensure that only one maze gets created.  We make
the type limited and indefinite, and provide a "constructor" to return a
pointer to a statically allocated instance in the body.  (This is
similar to how the Fly-weight pattern is implemented).

I declared Maze_Type in its own child package, mostly so I could
localize a dependency on Maze_Rooms.  (The alternative --declaring
Maze_Type in the root package-- would require declaring Maze_Room there
too, which I found aesthetically unpleasing.)

The spec for Maze_Type looks like this:

package Mazes.Games is

   type Maze_Type (<>) is limited private;

   


   type Maze_Access is access all Maze_Type;

   function Maze return Maze_Access;
...
end Mazes.Games;


The singleton is statically declared in the body:

package body Mazes.Games is

   Singleton : aliased Maze_Type;

   ...

   function Maze return Maze_Access is
   begin
      return Singleton'Access;
   end;

   ...

end Mazes.Games;


Clients refer to the maze indirectly, by calling a selector that returns
a reference to the singleton.  Despite this, Maze manipulation has a
very natural syntax, because operations take access parameters:

   Room : constant Room_Handle :=
     Get_Room (1, Of_Maze => Maze);  <-- Maze returns ptr to singleton


The maze gets initialized during elaboration of the package body, by
populating the maze with a couple of rooms connected by a door:

with Mazes.Factory;
pragma Elaborate_All (Mazes.Factory);

package body Mazes.Games is

   Singleton : aliased Maze_Type;
   ...
begin

   declare

      Room_1 : constant Room_Handle := New_Room (1);

      Room_2 : constant Room_Handle := New_Room (2);

      Door : constant Door_Handle := New_Door (Room_1, Room_2);

   begin

      Singleton.Rooms := (Room_1, Room_2);

      Set_Side (+Room_1, North, New_Wall);
      ...

   end;

end Mazes.Games;


What we want to do is make the algorithm for maze initialization
independent of specific maze items.  That's where the factory comes in.

The Game package uses constructors for rooms, doors, and walls provided
by the factory, but is otherwise indifferent.  The kind of wall or the
kind of door used to construct the maze is a detail hidden by the
factory.

The spec for our "virtual" factory looks like this:

package  is

   function New_Wall return Maze_Handle;

   function New_Room
     (Number : Positive) return Room_Handle;

   function New_Door
     (Front_Room : Room_Handle;
      Back_Room  : Room_Handle) return Door_Handle;


In our example, there are two reifications of this virtual factory, a
default one for unenchanted maze items, and another for enchanted maze
items.  These are two different packages, each with an identical
interface:

package Mazes.Default_Factory is

   function New_Wall return Maze_Handle;
... (as above)


package Mazes.Enchanted_Factory is

   function New_Wall return Maze_Handle;
... (as above)



The body of the default factory returns unenchanted maze items:

   function New_Room
     (Number : Positive) return Room_Handle is

      Room : constant Room_Handle :=
        New_Room;  <-- constructor for unenchanted room
   begin
      Set_Number (+Room, Number);
      return Room;
   end;



The body of the enchanted factory returns enchanted maze items:

   function New_Room
     (Number : Positive) return Room_Handle is

      Room : constant Room_Handle :=
        New_Enchanted_Room;  <-- constructor for enchanted room
   begin
      Set_Number (+Room, Number);
      return Room;
   end;


The one thing that remains is to explain how to "connect" the maze to
the factory.  Recall that the body for the singleton was declared this
way:

with Mazes.Factory;
pragma Elaborate_All (Mazes.Factory);

package body Mazes.Games is ...;


Package Mazes.Factory is the actual "abstract factory" to which this
pattern refers.  It is implemented as a library-level renaming of either
the default factory or the enchanted factory.

If you implement Factory this way:

with Mazes.Default_Factory;
package Mazes.Factory renames Mazes.Default_Factory;

then you'll get the following output:

$ maze_main
entered room
entered wall
entered wall
entered door
entered wall


If you then implement Factory this other way:

with Mazes.Enchanted_Factory;
package Mazes.Factory renames Mazes.Enchanted_Factory;

then you'll get this other output:

$ maze_main
entered enchanted room - scary!
entered enchanted wall - by walking through it!
entered enchanted wall - by walking through it!
entered door needing spell - magic!
entered enchanted wall - by walking through it!


So you get a completely different behavior, by changing only a couple
lines of code.

As an example of this idea, you could use a factory to implement a
platform-neutral windowing API.  When you port your application to
another operating system, all you need to do is compile against a
different factory.  Your code is otherwise unchanged.

Matt


The code below is in a format suitable for use with gnatchop.

--STX
with Mazes;       use Mazes;
with Mazes.Games; use Mazes.Games;
with Mazes.Rooms; use Mazes.Rooms;

procedure Maze_Main is

   Room : constant Room_Handle :=
     Get_Room (1, Of_Maze => Maze);

begin

   Enter (+Room);

   for Direction in Direction_Type loop
      Enter (+Get_Side (+Room, Direction));
   end loop;

end;
with Mazes.Walls; use Mazes.Walls;

package body Mazes.Default_Factory is

   function New_Wall return Maze_Handle renames Walls.New_Wall;


   function New_Room
     (Number : Positive) return Room_Handle is

      Room : constant Room_Handle := New_Room;
   begin
      Set_Number (+Room, Number);
      return Room;
   end;


   function New_Door
     (Front_Room : Room_Handle;
      Back_Room  : Room_Handle) return Door_Handle is

      Door : constant Door_Handle := Doors.New_Door;
   begin
      Set_Room (+Door, Front, Front_Room);
      Set_Room (+Door, Back, Back_Room);

      return Door;
   end;

end Mazes.Default_Factory;
with Mazes.Rooms; use Mazes.Rooms;
with Mazes.Doors; use Mazes.Doors;

package Mazes.Default_Factory is

   function New_Wall return Maze_Handle;

   function New_Room
     (Number : Positive) return Room_Handle;

   function New_Door
     (Front_Room : Room_Handle;
      Back_Room  : Room_Handle) return Door_Handle;

end Mazes.Default_Factory;
with Mazes.Storage;
with Ada.Text_IO;  use Ada.Text_IO;

package body Mazes.Doors.Enchanted is

   type Door_Needing_Spell_Access is
     access all Door_Needing_Spell'Class;


   package Door_Storage is
     new Storage.Generic_Item
     (Door_Needing_Spell,
      Door_Needing_Spell_Access,
      Door_Handle);

   procedure Enter
     (Door : access Door_Needing_Spell) is
   begin
      Put_Line ("entered door needing spell - magic!");
   end;

   function New_Door_Needing_Spell return Door_Handle renames
     Door_Storage.New_Item;

   procedure Free (Door : access Door_Needing_Spell) renames
     Door_Storage.Do_Free;

end Mazes.Doors.Enchanted;
package Mazes.Doors.Enchanted is

   type Door_Needing_Spell is
     new Maze_Door with private;


   procedure Enter
     (Door : access Door_Needing_Spell);

   function New_Door_Needing_Spell return Door_Handle;

private

   type Door_Needing_Spell is
     new Maze_Door with null record;

   procedure Free (Door : access Door_Needing_Spell);

end Mazes.Doors.Enchanted;
with Mazes.Storage;
with Ada.Text_IO;

package body Mazes.Doors is

   package Door_Storage is
     new Storage.Generic_Item
     (Maze_Door,
      Maze_Door_Access,
      Door_Handle);


   procedure Enter (Door : access Maze_Door) is
   begin
      Ada.Text_IO.Put_Line ("entered door");
   end;


   procedure Set_Room
     (Door : access Maze_Door;
      Id   : in     Room_Id;
      Room : in     Room_Handle) is
   begin
      Door.Rooms (Id) := Room;
   end;


   function Get_Room
     (Door : Maze_Door;
      Id   : Room_Id) return Room_Handle is
   begin
      return Door.Rooms (Id);
   end;


   procedure Free (Door : access Maze_Door) renames
     Door_Storage.Do_Free;

   function New_Door return Door_Handle renames
     Door_Storage.New_Item;

   function "+"
     (Handle : Door_Handle) return Maze_Door_Access renames
     Door_Storage.Ref;

   function "+"
     (Handle : Door_Handle) return Maze_Handle is
   begin
      return Maze_Handle (Handle);
   end;

end Mazes.Doors;
with Mazes.Rooms; use Mazes.Rooms;

package Mazes.Doors is

   type Maze_Door is new Maze_Item with private;

   type Maze_Door_Access is access all Maze_Door'Class;


   type Room_Id is (Front, Back);


   procedure Enter (Door : access Maze_Door);

   procedure Set_Room
     (Door : access Maze_Door;
      Id   : in     Room_Id;
      Room : in     Room_Handle);

   function Get_Room
     (Door : Maze_Door;
      Id   : Room_Id) return Room_Handle;


   type Door_Handle is private;

   function New_Door return Door_Handle;

   function "+"
     (Handle : Door_Handle) return Maze_Door_Access;

   function "+"
     (Handle : Door_Handle) return Maze_Handle;

private

   type Room_Array is
      array (Room_Id) of Room_Handle;

   type Maze_Door is
      new Maze_Item with record
         Rooms   : Room_Array;
         Is_Open : Boolean := False;
      end record;

   procedure Free (Door : access Maze_Door);


   type Door_Handle is new Maze_Handle with null record;

end Mazes.Doors;
with Mazes.Rooms.Enchanted; use Mazes.Rooms.Enchanted;
with Mazes.Doors.Enchanted; use Mazes.Doors.Enchanted;
with Mazes.Walls.Enchanted; use Mazes.Walls.Enchanted;

package body Mazes.Enchanted_Factory is

   function New_Wall return Maze_Handle renames
     New_Enchanted_Wall;


   function New_Room
     (Number : Positive) return Room_Handle is

      Room : constant Room_Handle :=
        New_Enchanted_Room;
   begin
      Set_Number (+Room, Number);
      return Room;
   end;


   function New_Door
     (Front_Room : Room_Handle;
      Back_Room  : Room_Handle) return Door_Handle is

      Door : constant Door_Handle :=
        New_Door_Needing_Spell;
   begin
      Set_Room (+Door, Front, Front_Room);
      Set_Room (+Door, Back, Back_Room);

      return Door;
   end;

end Mazes.Enchanted_Factory;
with Mazes.Rooms; use Mazes.Rooms;
with Mazes.Doors; use Mazes.Doors;

package Mazes.Enchanted_Factory is

   function New_Wall return Maze_Handle;

   function New_Room
     (Number : Positive) return Room_Handle;

   function New_Door
     (Front_Room : Room_Handle;
      Back_Room  : Room_Handle) return Door_Handle;

end Mazes.Enchanted_Factory;


with Mazes.Enchanted_Factory;
--with Mazes.Default_Factory;
package Mazes.Factory renames
--  Mazes.Default_Factory;
  Mazes.Enchanted_Factory;




with Mazes.Doors;    use Mazes.Doors;
with Mazes.Factory;  use Mazes.Factory;
pragma Elaborate_All (Mazes.Factory);

package body Mazes.Games is

   Singleton : aliased Maze_Type;


   function Get_Room
     (Number  : in     Positive;
      Of_Maze : access Maze_Type) return Room_Handle is
   begin
      return Of_Maze.Rooms (Number);
   end;


   function Maze return Maze_Access is
   begin
      return Singleton'Access;
   end;


begin

   declare

      Room_1 : constant Room_Handle := New_Room (1);

      Room_2 : constant Room_Handle := New_Room (2);

      Door : constant Door_Handle := New_Door (Room_1, Room_2);

   begin

      Singleton.Rooms := (Room_1, Room_2);

      Set_Side (+Room_1, North, New_Wall);
      Set_Side (+Room_1, East, +Door);
      Set_Side (+Room_1, South, New_Wall);
      Set_Side (+Room_1, West, New_Wall);

      Set_Side (+Room_2, North, New_Wall);
      Set_Side (+Room_2, East, New_Wall);
      Set_Side (+Room_2, South, New_Wall);
      Set_Side (+Room_2, West, +Door);

   end;

end Mazes.Games;
with Mazes.Rooms;  use Mazes.Rooms;

package Mazes.Games is

   type Maze_Type (<>) is limited private;

   function Get_Room
     (Number  : in     Positive;
      Of_Maze : access Maze_Type) return Room_Handle;


   type Maze_Access is access all Maze_Type;

   function Maze return Maze_Access;

private

   type Room_Array is
      array (Positive range <>) of Room_Handle;

   type Maze_Type is
      limited record
         Rooms : Room_Array (1 .. 2);
      end record;

end Mazes.Games;
with Mazes.Storage;
with Ada.Text_IO;  use Ada.Text_IO;

package body Mazes.Rooms.Enchanted is

   type Enchanted_Room_Access is
      access all Enchanted_Room'Class;

   package Room_Storage is
     new Storage.Generic_Item
     (Enchanted_Room,
      Enchanted_Room_Access,
      Room_Handle);

   procedure Enter
     (Room : access Enchanted_Room) is
   begin
      Put_Line ("entered enchanted room - scary!");
   end;

   procedure Free (Room : access Enchanted_Room) renames
     Room_Storage.Do_Free;

   function New_Enchanted_Room return Room_Handle renames
     Room_Storage.New_Item;

end Mazes.Rooms.Enchanted;
package Mazes.Rooms.Enchanted is

   type Enchanted_Room is
     new Maze_Room with private;

   procedure Enter
     (Room : access Enchanted_Room);

   function New_Enchanted_Room return Room_Handle;

private

   type Enchanted_Room is
     new Maze_Room with null record;

   procedure Free (Room : access Enchanted_Room);

end Mazes.Rooms.Enchanted;
with Mazes.Storage;
with Ada.Text_IO;

package body Mazes.Rooms is

   package Room_Storage is
     new Storage.Generic_Item
     (Maze_Room,
      Maze_Room_Access,
      Room_Handle);


   procedure Enter (Room : access Maze_Room) is
   begin
      Ada.Text_IO.Put_Line ("entered room");
   end;


   procedure Set_Number
     (Room   : access Maze_Room;
      Number : in     Positive) is
   begin
      Room.Number := Number;
   end;


   function Get_Number
     (Room : access Maze_Room) return Positive is
   begin
      return Room.Number;
   end;


   procedure Set_Side
     (Room      : access Maze_Room;
      Direction : in     Direction_Type;
      Side      : in     Maze_Handle) is
   begin
      Room.Sides (Direction) := Side;
   end;


   function Get_Side
     (Room      : access Maze_Room;
      Direction : in     Direction_Type) return Maze_Handle is
   begin
      return Room.Sides (Direction);
   end;


   procedure Free (Room : access Maze_Room) renames
     Room_Storage.Do_Free;

   function New_Room return Room_Handle renames
     Room_Storage.New_Item;

   function "+"
     (Handle : Room_Handle) return Maze_Room_Access renames
     Room_Storage.Ref;

   function "+"
     (Handle : Room_Handle) return Maze_Handle is
   begin
      return Maze_Handle (Handle);
   end;

end Mazes.Rooms;
package Mazes.Rooms is

   type Maze_Room is new Maze_Item with private;

   type Maze_Room_Access is access all Maze_Room'Class;


   procedure Enter (Room : access Maze_Room);

   procedure Set_Number
     (Room   : access Maze_Room;
      Number : in     Positive);

   function Get_Number
     (Room : access Maze_Room) return Positive;

   procedure Set_Side
     (Room      : access Maze_Room;
      Direction : in     Direction_Type;
      Side      : in     Maze_Handle);

   function Get_Side
     (Room      : access Maze_Room;
      Direction : in     Direction_Type) return Maze_Handle;


   type Room_Handle is private;

   function New_Room return Room_Handle;

   function "+"
     (Handle : Room_Handle) return Maze_Room_Access;

   function "+"
     (Handle : Room_Handle) return Maze_Handle;

private

   type Maze_Item_Array is
      array (Direction_Type) of Maze_Handle;

   type Maze_Room is
     new Maze_Item with record
        Sides  : Maze_Item_Array;
        Number : Positive;
     end record;

   procedure Free (Room : access Maze_Room);

   type Room_Handle is new Maze_Handle with null record;

end Mazes.Rooms;
package body Mazes.Storage is

   package body Generic_Item is

      Free_List : Maze_Item_Access;


      procedure Do_Free (Item : access Item_Type) is
      begin
         Item.Next := Free_List;
         Free_List := Maze_Item_Access (Item);
      end;

      function New_Item return Item_Handle is
         Handle : Item_Handle;
      begin

         if Free_List = null then
            Handle.Item :=
              Maze_Item_Access (Item_Access'(new Item_Type));
         else
            Handle.Item := Free_List;
            Free_List := Free_List.Next;
         end if;

         Handle.Item.Count := 1;
         Handle.Item.Next := null;

         return Handle;
      end New_Item;

      function Ref (Handle : Item_Handle) return Item_Access is
      begin
         return Item_Access (Handle.Item);
      end;

   end Generic_Item;

end Mazes.Storage;

private package Mazes.Storage is

   generic

      type Item_Type is new Maze_Item with private;

      type Item_Access is access all Item_Type'Class;

      type Item_Handle is new Maze_Handle with private;

   package Generic_Item is

      procedure Do_Free (Item : access Item_Type);

      function New_Item return Item_Handle;

      function Ref (Handle : Item_Handle) return Item_Access;

   end Generic_Item;

end Mazes.Storage;

with Mazes.Storage;
with Ada.Text_IO;  use Ada.Text_IO;

package body Mazes.Walls.Enchanted is

   type Enchanted_Wall_Access is
      access all Enchanted_Wall'Class;

   package Wall_Storage is
     new Storage.Generic_Item
     (Enchanted_Wall,
      Enchanted_Wall_Access,
      Maze_Handle);


   procedure Enter (Wall : access Enchanted_Wall) is
   begin
      Put_Line ("entered enchanted wall - by walking through it!");
   end;

   function New_Enchanted_Wall return Maze_Handle renames
     Wall_Storage.New_Item;

   procedure Free (Wall : access Enchanted_Wall) renames
     Wall_Storage.Do_Free;


end Mazes.Walls.Enchanted;
package Mazes.Walls.Enchanted is

   type Enchanted_Wall is
     new Maze_Wall with private;

   procedure Enter
     (Wall : access Enchanted_Wall);

   function New_Enchanted_Wall return Maze_Handle;

private

   type Enchanted_Wall is
     new Maze_Wall with null record;

   procedure Free (Wall : access Enchanted_Wall);

end Mazes.Walls.Enchanted;
with Mazes.Storage;
with Ada.Text_IO;

package body Mazes.Walls is

   package Wall_Storage is
     new Storage.Generic_Item
     (Maze_Wall,
      Maze_Wall_Access,
      Maze_Handle);


   procedure Enter (Wall : access Maze_Wall) is
   begin
      Ada.Text_IO.Put_Line ("entered wall");
   end;

   procedure Free (Wall : access Maze_Wall) renames
     Wall_Storage.Do_Free;

   function New_Wall return Maze_Handle renames
     Wall_Storage.New_Item;

end Mazes.Walls;
package Mazes.Walls is

   type Maze_Wall is new Maze_Item with private;

   type Maze_Wall_Access is access all Maze_Wall'Class;


   procedure Enter (Wall : access Maze_Wall);

   function New_Wall return Maze_Handle;

private

   type Maze_Wall is new Maze_Item with null record;

   procedure Free (Wall : access Maze_Wall);

end Mazes.Walls;
package body Mazes is

   procedure Free (Item : access Maze_Item) is
   begin
      null;
   end Free;

   function "+" (Handle : Maze_Handle) return Maze_Item_Access is
   begin
      return Handle.Item;
   end;


   procedure Adjust
     (Handle : in out Maze_Handle) is
   begin
      if Handle.Item /= null then

         Handle.Item.Count := Handle.Item.Count + 1;

      end if;
   end Adjust;


   procedure Finalize
     (Handle : in out Maze_Handle) is
   begin
      if Handle.Item /= null then

         Handle.Item.Count := Handle.Item.Count - 1;

         if Handle.Item.Count = 0 then
            Free (Handle.Item);
         end if;

      end if;
   end Finalize;


end Mazes;
with Ada.Finalization; use Ada.Finalization;

package Mazes is

   pragma Preelaborate;


   type Maze_Item (<>) is abstract tagged limited private;
   --
   -- Named "MapSite" in the GoF book.

   type Maze_Item_Access is access all Maze_Item'Class;


   procedure Enter (Item : access Maze_Item) is abstract;

   type Direction_Type is (North, South, East, West);


   type Maze_Handle is private;

   function "+" (Handle : Maze_Handle) return Maze_Item_Access;

private

   type Maze_Item is
     abstract tagged limited record
        Next  : Maze_Item_Access;
        Count : Natural;
     end record;

   procedure Free (Item : access Maze_Item);


   type Maze_Handle is
     new Controlled with record
        Item : Maze_Item_Access;
     end record;

   procedure Adjust
     (Handle : in out Maze_Handle);

   procedure Finalize
     (Handle : in out Maze_Handle);

end Mazes;