Strategy Pattern

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;