The Strategy pattern provides a means of parameterizing a component to
accept an algorithm. This keeps the component simpler, and lets clients
pick and choose an algorithm specifically tailored to their needs.
The example in the book parameterizes a composition class (in a text
editor, say) to accept an algorithm for determining line breaks.
Compositors are implemented as stateless classes that have a single
operation, Compose, that returns an array of line break locations.
This implementation, I think, reflects a Smalltalk view of the world.
In Smalltalk, you don't have "free" subprograms, so it's necessary to
wrap the procedure in a class, and pass an instance of that type as the
value of the parameter. The client would then call Compose as an
operation of the Compositor object.
But an Ada programmer wouldn't do it that way. You would just declare a
free-standing procedure, and pass that as a generic actual parameter.
This is a far simpler approach that avoids all the heaviness of
type-based solution.
This is the technique I used in the sample code. The composition type
is provided by a generic package that imports the strategy as a generic
formal subprogram. Like this:
generic
with function Compose
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array is <>;
package Compositions is
type Composition_Type is limited private;
...
end Compositions;
A client decides which kind of line break algorithm he wants to use and
then instantiates the package on that function.
The simple algorithm determines line breaks on at a time:
with Compositors.Simple;
package Compositions is
new Compositions_G (Compositors.Simple);
The TeX algorithm determines the line breaks for an entire paragraph:
with Compositors.TeX;
package Compositions is
new Compositions_G (Compositors.TeX);
The interval algorithm calculates line breaks at regular intervals.
This algorithm is itself a generic, parameterized by the length of the
interval:
with Compositors.Generic_Interval;
function Compositors.Interval_100 is
new Compositors.Generic_Interval (100);
with Compositors.Interval_100;
package Compositions is
new Compositions_G (Compositors.Interval_100);
Comparing this implementation to the one in the book highlights the fact
that Ada provides facilities for implementing static abstractions that
are different from the facilities for implementing dynamic abstractions.
A Smalltalk programmer doesn't have a choice in the matter, and must use
dynamic abstractions even when he knows at compile-time what he wants.
Ada is a language for systems programming, and in that domain it's
important that you don't pay for things you don't need.
As a matter of fact, we don't even need generics for this example,
because we can just use library-level renaming, like we did for the
abstract factory.
The specification of the "abstract strategy" for breaking lines looks
like it did before:
function <Virtual Compose>
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array;
At compile-time, the client "reifies" the abstract strategy by renaming
one of the concrete implementations.
o Compose implemented using a line-at-a-time algorithm:
with Compositors.Simple;
function Compositors.Compose
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive)
return Coordinate_Array renames Simple; <--
o Compose implemented as a paragraph-at-a-time algorithm:
with Compositors.TeX;
function Compositors.Compose
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive)
return Coordinate_Array renames TeX; <--
o Compose implemented using regular intervals of 100:
with Compositors.Interval_100;
function Compositors.Compose
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive)
return Coordinate_Array renames Interval_100; <--
The composition package (now non-generic) withs the compose strategy as
if it were a normal library-level subprogram:
with Compositors.Compose;
package body Compositions is ...;
and thus he statically binds to whatever algorithm was renamed Compose.
This gives you all the benefits of the strategy pattern, with no muss,
and no fuss!
But wait! There's more! Act now an you'll get this handsome set of
Ginsu knives, absolutely free!!!
Because I'm feeling generous today, I decided to throw in another
example of the strategy pattern.
When implementing a dynamic abstraction like a linked list or unbounded
stack, you typically use a storage manager to maintain a pool of unused
storage nodes. Something like this:
generic
...
package Storage is
function New_Node return Storage_Node_Access;
procedure Free (Node : in out Storage_Node_Access);
end Storage;
What we want to do is provide a "strategy" for finalizing a node when it
gets Free'd, so a client can grant a node last wishes just prior to its
being returned to storage.
We implement this by parameterizing the storage manager with a generic
formal finalization procedure:
generic
...
with procedure Finalize
(Node : in out Storage_Node) is Do_Nothing;
package Storage is ...;
The Finalize procedure gets called as a side-effect of Free'ing a node:
procedure Free (Node : in out Storage_Node_Access) is
begin
if Node = null then
return;
end if;
Finalize (Node.all); <--
...
end Free;
Note that we supply a default value for Finalize, Do_Nothing, so that
clients who don't need to do anything special during finalization aren't
obligated to write their own dummy procedure that does nothing.
Both client and supplier have to understand the representation of node
type, so we declare that type off in its own package, and import it as a
generic formal package:
with Storage_Nodes;
generic
with package Nodes is new Storage_Nodes (<>);
use Nodes;
with procedure Finalize
(Node : in out Storage_Node) is Do_Nothing;
package Storage is
The default value of the finalization strategy (procedure Do_Nothing)
comes from the nodes package, which is where we declare the node type:
generic
type Item_Type is limited private;
package Storage_Nodes is
type Storage_Node;
type Storage_Node_Access is access all Storage_Node;
type Storage_Node is
limited record
Item : aliased Item_Type;
Next : Storage_Node_Access;
end record;
procedure Do_Nothing (Node : in out Storage_Node); <--
end Storage_Nodes;
Let's see how this gets used by creating two simple abstractions, a
linked list and an unbounded stack.
First we implement the list as a pointer to a storage node:
generic
type Item_Type is private;
package Lists is
type List_Type is private;
...
private
package Nodes is new Storage_Nodes (Item_Type);
use Nodes;
type List_Type is
record
Head : Storage_Node_Access;
end record;
end Lists;
When we Clear the list, we want all the nodes in the chain to get freed.
We can effect this by implementing Finalize so that it frees the next
node, which finalizes that node, which frees next one, and so on
recursively:
package body Lists is
procedure Finalize (Node : in out Storage_Node);
package List_Storage is new Storage (Nodes, Finalize); <--
use List_Storage;
procedure Finalize (Node : in out Storage_Node) is
begin
Free (Node.Next);
end;
Clear is implemented by just Free'ing the list head:
procedure Clear (List : in out List_Type) is
begin
Free (List.Head);
end;
which causes all the nodes in the list to get freed.
The list abstraction we just saw has a specific strategy for node
finalization, and therefore supplies a non-default implementation to the
instantiation of the storage manager. Now let's implement an unbounded
stack that doesn't need to do anything, and so can take the default.
Like we did for the list, we implement our stack as a list of nodes:
generic
type Item_Type is private;
package Unbounded_Stacks is
type Stack_Type is limited private;
...
private
package Nodes is new Storage_Nodes (Item_Type);
use Nodes;
type Stack_Type is
limited record
Top : Storage_Node_Access;
end record;
end Unbounded_Stacks;
This particular stack has doesn't need to clear the stack, so we just
instantiate the storage manager as is:
package body Unbounded_Stacks is
package Stack_Storage is new Storage (Nodes); <--
use Stack_Storage;
Compare this to the list example, noting how the list overrides the
default value of Finalize, and the stack takes the default.
The code below is in a format suitable for use with gnatchop.
--STX
package body Compositions_G is
procedure Repair (Composition : in out Composition_Type) is
subtype Coordinates_Range is
Positive range 1 .. Composition.Component_Count;
subtype Coordinates is
Coordinate_Array (Coordinates_Range);
Size : Coordinates;
Stretchability : Coordinates;
Shrinkability : Coordinates;
Breaks : constant Coordinate_Array :=
Compose (Size => Size,
Stretchability => Stretchability,
Shrinkability => Shrinkability,
Line_Width => Composition.Line_Width);
begin
null;
end Repair;
end Compositions_G;
with Coordinate_Types; use Coordinate_Types;
generic
with function Compose
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array is <>;
package Compositions_G is
type Composition_Type is limited private;
procedure Repair (Composition : in out Composition_Type);
private
type Composition_Type is
record
Line_Width : Positive := 80;
Line_Count : Natural;
Component_Count : Natural;
end record;
end Compositions_G;
function Compositors.Generic_Interval
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array is
Breaks : Coordinate_Array (Size'Range);
begin
return Breaks;
end;
with Coordinate_Types; use Coordinate_Types;
generic
Interval : in Positive;
function Compositors.Generic_Interval
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array;
function Compositors.Simple
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array is
Breaks : Coordinate_Array (Size'Range);
begin
return Breaks;
end;
with Coordinate_Types; use Coordinate_Types;
function Compositors.Simple
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array;
function Compositors.TeX
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array is
Breaks : Coordinate_Array (Size'Range);
begin
return Breaks;
end;
with Coordinate_Types; use Coordinate_Types;
function Compositors.TeX
(Size : Coordinate_Array;
Stretchability : Coordinate_Array;
Shrinkability : Coordinate_Array;
Line_Width : Positive) return Coordinate_Array;
package Compositors is
pragma Pure;
end Compositors;
package Coordinate_Types is
pragma Pure;
type Coordinate_Type is
record
null; -- <whatever goes here>
end record;
type Coordinate_Array is
array (Positive range <>) of Coordinate_Type;
end Coordinate_Types;
with Lists;
package Integer_Lists is new Lists (Integer);
with Unbounded_Stacks;
package Integer_Stacks is new Unbounded_Stacks (Integer);
with Storage;
package body Lists is
procedure Finalize (Node : in out Storage_Node);
package List_Storage is new Storage (Nodes, Finalize);
use List_Storage;
procedure Finalize (Node : in out Storage_Node) is
begin
Free (Node.Next);
end;
function Cons (Item : Item_Type;
List : List_Type) return List_Type is
Node : constant Storage_Node_Access := New_Node;
begin
Node.Item := Item;
Node.Next := List.Head;
return List_Type'(Head => Node);
end Cons;
function Get_Head (List : List_Type) return Item_Type is
begin
return List.Head.Item;
end;
procedure Set_Head (List : in List_Type;
Item : in Item_Type) is
begin
List.Head.Item := Item;
end;
function Get_Tail (List : List_Type) return List_Type is
begin
return List_Type'(Head => List.Head.Next);
end;
procedure Set_Tail (List : in List_Type;
Tail : in List_Type) is
begin
List.Head.Next := Tail.Head;
end;
procedure Clear (List : in out List_Type) is
begin
Free (List.Head);
end;
end Lists;
with Storage_Nodes;
generic
type Item_Type is private;
package Lists is
type List_Type is private;
Null_List : constant List_Type;
function Cons (Item : Item_Type;
List : List_Type) return List_Type;
function Get_Head (List : List_Type) return Item_Type;
procedure Set_Head (List : in List_Type;
Item : in Item_Type);
function Get_Tail (List : List_Type) return List_Type;
procedure Set_Tail (List : in List_Type;
Tail : in List_Type);
procedure Clear (List : in out List_Type);
private
package Nodes is new Storage_Nodes (Item_Type);
use Nodes;
type List_Type is
record
Head : Storage_Node_Access;
end record;
Null_List : constant List_Type := (Head => null);
end Lists;
package body Storage is
Free_List : Storage_Node_Access;
function New_Node return Storage_Node_Access is
Node : Storage_Node_Access;
begin
if Free_List = null then
Node := new Storage_Node;
else
Node := Free_List;
Free_List := Free_List.Next;
Node.Next := null;
end if;
return Node;
end New_Node;
procedure Free (Node : in out Storage_Node_Access) is
begin
if Node = null then
return;
end if;
Finalize (Node.all);
Node.Next := Free_List;
Free_List := Node;
Node := null;
end Free;
end Storage;
with Storage_Nodes;
generic
with package Nodes is new Storage_Nodes (<>);
use Nodes;
with procedure Finalize
(Node : in out Storage_Node) is Do_Nothing;
package Storage is
function New_Node return Storage_Node_Access;
procedure Free (Node : in out Storage_Node_Access);
end Storage;
package body Storage_Nodes is
procedure Do_Nothing (Node : in out Storage_Node) is
begin
null;
end;
end Storage_Nodes;
generic
type Item_Type is limited private;
package Storage_Nodes is
type Storage_Node;
type Storage_Node_Access is access all Storage_Node;
type Storage_Node is
limited record
Item : aliased Item_Type;
Next : Storage_Node_Access;
end record;
procedure Do_Nothing (Node : in out Storage_Node);
end Storage_Nodes;
with Integer_Lists; use Integer_Lists;
with Ada.Text_IO; use Ada.Text_IO;
procedure Test_List is
List : List_Type;
begin
List := Cons (1, Null_List);
List := Cons (2, List);
List := Cons (3, List);
declare
Index : List_Type := List;
begin
while Index /= Null_List loop
Put (Integer'Image (Get_Head (Index)));
Put (" ");
Index := Get_Tail (Index);
end loop;
New_Line;
end;
Clear (List);
end Test_List;
with Storage;
package body Unbounded_Stacks is
package Stack_Storage is new Storage (Nodes);
use Stack_Storage;
procedure Push
(Item : in Item_Type;
On : in out Stack_Type) is
Node : constant Storage_Node_Access := New_Node;
begin
Node.Item := Item;
Node.Next := On.Top;
On.Top := Node;
end Push;
procedure Pop
(Stack : in out Stack_Type) is
Node : Storage_Node_Access := Stack.Top;
begin
Stack.Top := Stack.Top.Next;
Free (Node);
end Pop;
function Get_Top
(Stack : Stack_Type) return Item_Type is
begin
return Stack.Top.Item;
end;
end Unbounded_Stacks;
with Storage_Nodes;
generic
type Item_Type is private;
package Unbounded_Stacks is
type Stack_Type is limited private;
procedure Push
(Item : in Item_Type;
On : in out Stack_Type);
procedure Pop
(Stack : in out Stack_Type);
function Get_Top
(Stack : Stack_Type) return Item_Type;
private
package Nodes is new Storage_Nodes (Item_Type);
use Nodes;
type Stack_Type is
limited record
Top : Storage_Node_Access;
end record;
end Unbounded_Stacks;
|
