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;
|
