AdaPower Logged in as Guest
Ada Tools and Resources

Ada 95 Reference Manual
Ada Source Code Treasury
Bindings and Packages
Ada FAQ


Join >
Home >
Articles >
Getting Started >
Ada FAQ >
Source Treasury >
Books & Tutorials >
Packages for Reuse >
Latest Additions >
Ada Projects >
Press Releases >
Ada Audio / Video >
Home Pages >
Links >
Contact >
About >
Login >
Back
Command Pattern (Matthew Heaney)

Command objects manage the processing that occurs when a user
manipulates the application in some way.

Objectifying a command admits all kinds of interesting possibilities.
You can put the command on a stack to implement undo and redo, or write
the command to disk to implement record/playback.

You don't even have to execute the command right away.  In a simulation
each command has a scenario time.  You put the command on a queue and
execute the command later, when the simulation reaches that point in the
scenario.

In the example here, a menu-based application manages a group of open
documents.  Each menu item contains a command object, bound at creation
time to a document object, which when executed calls a document
operation.


Implementation

In C++, you can bind a command to a document by passing the document as
a parameter in the constructor for the command.

For binding one object to another in Ada95 we use access discriminants,
a language feature created specifically for this purpose.  The advantage
of this approach over C++ constructors is that the language guarantees
that a dangling reference cannot occur.

In order to have an access discriminant, the type must be limited.  This
was already the case for the command class, because we used the
limited-and-indefinite idiom to control instance creation:

  package Commands is

    type Root_Command_Type (<>) is abstract tagged limited private;

That the type is also indefinite means we can hide the access
discriminant, by declaring it only in the full view of the type:

  package Commands.Open is

    type Open_Command_Type is
      new Root_Command_Type with private;
    ...
  private

   type Open_Command_Type (App : access Application_Type'Class) is
     new Root_Command_Type with null record;
   ...
  end Commands.Open;


We bind an open command to an application instance by passing the
reference in the constructor for the type (very similar, actually, to
the C++ mechanism):

   function New_Open_Command (App : access Application_Type'Class)
     return Open_Command_Access is
   begin
      return new Open_Command_Type (App);
   end;


When an open command is executed, the command creates a new document and
opens it, and adds it to the application:

   procedure Execute (Command : access Open_Command) is
   ...
      Add (Doc, To => Command.App.all);


The paste command is implemented similarly, except that it is bound to a
document instance:

     type Paste_Command_Type (Doc : access Document_Type'Class) is
       new Root_Command_Type with private;


When you execute a paste command, it calls the paste operation of the
document to which it is bound:

   procedure Execute (Command : access Paste_Command_Type) is
   begin
      Documents.Paste (Command.Doc);
   end;


You can generalize this idea by creating a generic package, allowing a
command to be bound to any kind of type:

   generic

      type Receiver_Type (<>) is limited private;

      with procedure Action (Receiver : in out Receiver_Type);

   package Commands.Simple is

      type Simple_Command_Type (Receiver : access Receiver_Type) is
        new Root_Command_Type with private;


The generic formal procedure Action specifies what you do to the object
when you execute the command:

   procedure Execute (Command : access Simple_Command_Type) is
   begin
      Action (Command.Receiver.all);
   end;


In the sample code, I use the simple command generic to create a command
that counts the number of documents in an application.

We want to be able to count the number of documents for any type in the
class, so we will instantiate the generic on the class-wide type.
Actual types that are indefinite (like Application_Type'Class) are
allowed because the formal type (Receiver_Type) was declared with
unknown discriminants.

There was no existing class-wide operation for applications that counts
documents, so we just extend package Applications with a public child
subprogram:

  procedure Applications.Count_Docs
    (App : in out Application_Type'Class);

Because it is a child, Count_Docs has access to the representation of
Application_Type, and it can therefore be implemented by iterating over
the documents in the collection maintained by the application.

A macro command maintains a list of commands, and so doesn't need an
access discriminant of its own.  When you execute a macro command, it
calls the execute operation for all the commands on the list:

  procedure Execute (Command : access Macro_Command_Type) is
     Index : Root_Command_Access := Command.Next;
  begin
     while Index /= null loop
        Execute (Index);
        Index := Index.Next;
     end loop;
  end Execute;

This is an example of the Composite pattern.

Note that if you have a well-known object (singleton or otherwise) that
is the recipient of command activity, then you don't need to bind the
command to anything.  In the implementation of Execute, you just call
the well-known object directly.


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

--STX
with Ada.Text_IO; use Ada.Text_IO;

procedure Applications.Count_Docs
  (App : in out Application_Type'Class) is

   Count : Natural := 0;

   procedure Inc_Count (Doc : access Document_Type'Class) is
   begin
      Count := Count + 1;
   end;

   procedure Do_Count_Docs is
     new For_Every_Document (Inc_Count);

begin

   Do_Count_Docs (App.Container);

   case Count is
      when 0 =>
         Put_Line ("There are no docs in the app.");

      when 1 =>
         Put_Line ("There is 1 doc in the app.");

      when others =>
         Put_Line
           ("There are" &
            Integer'Image (Count) &
            " docs in the app.");

   end case;

end Applications.Count_Docs;
procedure Applications.Count_Docs
  (App : in out Application_Type'Class);
package body Applications is

   procedure Add
     (Document : access Document_Type'Class;
      To       : in out Application_Type) is

      App : Application_Type renames To;
   begin
      Add (Document, To => App.Container);
   end;

end Applications;


with Documents;            use Documents;
with Documents.Containers;

package Applications is

   type Application_Type is tagged limited private;

   procedure Add
     (Document : access Document_Type'Class;
      To       : in out Application_Type);

private

   use Documents.Containers;

   type Application_Type is
      tagged limited record
         Container : Document_Container;
      end record;

end Applications;


with Applications.Count_Docs; use Applications;
with Commands.Simple;

package Commands.App is
  new Simple (Application_Type'Class, Count_Docs);

with Ada.Unchecked_Deallocation;

package body Commands.Macro is

   procedure Deallocate is
     new Ada.Unchecked_Deallocation
     (Macro_Command_Type,
      Macro_Command_Access);


   function New_Macro_Command return Macro_Command_Access is
   begin
      return new Macro_Command_Type;
   end;


   procedure Do_Free (Command : access Macro_Command_Type) is

      Index : Root_Command_Access := Command.Next;
      Item  : Root_Command_Access;
   begin
      while Index /= null loop
         Item := Index;
         Index := Index.Next;
         Free (Item);
      end loop;

      declare
         CA : Macro_Command_Access :=
           Macro_Command_Access (Command);
      begin
         Deallocate (CA);
      end;
   end Do_Free;



   procedure Execute (Command : access Macro_Command_Type) is
      Index : Root_Command_Access := Command.Next;
   begin
      while Index /= null loop
         Execute (Index);
         Index := Index.Next;
      end loop;
   end Execute;


   procedure Add (Command : access Root_Command_Type'Class;
                  To      : access Macro_Command_Type) is
   begin
      Command.Next := To.Next;
      To.Next := Root_Command_Access (Command);
   end;


end Commands.Macro;




package Commands.Macro is

   type Macro_Command_Type is new Root_Command_Type with private;

   type Macro_Command_Access is access all Macro_Command_Type;

   function New_Macro_Command return Macro_Command_Access;

   procedure Execute (Command : access Macro_Command_Type);

   procedure Add (Command : access Root_Command_Type'Class;
                  To      : access Macro_Command_Type);

private

   type Macro_Command_Type is new Root_Command_Type with null record;
   --
   -- We've already got a Next pointer that we (can) use for storage
   -- management of commands, so let's just use that as the head of our
   -- command list.
   --

   procedure Do_Free (Command : access Macro_Command_Type);

end Commands.Macro;




with Documents; use Documents;

with Ada.Text_IO;  use Ada.Text_IO;
with Ada.Unchecked_Deallocation;

package body Commands.Open is

   procedure Deallocate is
     new Ada.Unchecked_Deallocation
     (Open_Command_Type,
      Open_Command_Access);


   function New_Open_Command (App : access Application_Type'Class)
     return Open_Command_Access is
   begin
      return new Open_Command_Type (App);
   end;


   procedure Do_Free (Command : access Open_Command_Type) is

      CA : Open_Command_Access :=
        Open_Command_Access (Command);
   begin
      Deallocate (CA);
   end;


   function Ask_User_For_Name return String is

      Line : String (1 .. 80);
      Last : Natural;
   begin
      Put ("Name: ");
      Get_Line (Line, Last);
      return Line (1 .. Last);
   end;


   procedure Execute (Command : access Open_Command_Type) is

      Doc : Document_Access;

      Name : constant String := Ask_User_For_Name;

   begin

      if Name /= "" then

         Doc := New_Doc (Name);

         Add (Doc, To => Command.App.all);

         Documents.Open (Doc);

      end if;

   end Execute;

end Commands.Open;





with Applications; use Applications;

package Commands.Open is

   type Open_Command_Type is
     new Root_Command_Type with private;

   type Open_Command_Access is access all Open_Command_Type;

   function New_Open_Command (App : access Application_Type'Class)
     return Open_Command_Access;


   procedure Execute (Command : access Open_Command_Type);

private

   type Open_Command_Type (App : access Application_Type'Class) is
     new Root_Command_Type with null record;

   function Ask_User_For_Name return String;

   procedure Do_Free (Command : access Open_Command_Type);

end Commands.Open;





with Ada.Unchecked_Deallocation;

package body Commands.Paste is

   procedure Deallocate is
     new Ada.Unchecked_Deallocation
     (Paste_Command_Type,
      Paste_Command_Access);


   function New_Paste_Command (Doc : access Document_Type'Class)
     return Paste_Command_Access is
   begin
     return new Paste_Command_Type (Doc);
   end;


   procedure Do_Free (Command : access Paste_Command_Type) is

      CA : Paste_Command_Access :=
        Paste_Command_Access (Command);
   begin
      Deallocate (CA);
   end;


   procedure Execute (Command : access Paste_Command_Type) is
   begin
      Documents.Paste (Command.Doc);
   end;

end Commands.Paste;



with Documents; use Documents;

package Commands.Paste is

   type Paste_Command_Type is
     new Root_Command_Type with private;

   type Paste_Command_Access is access all Paste_Command_Type;

   function New_Paste_Command (Doc : access Document_Type'Class)
     return Paste_Command_Access;

   procedure Execute (Command : access Paste_Command_Type);

private

   type Paste_Command_Type (Doc : access Document_Type'Class) is
     new Root_Command_Type with null record;

   procedure Do_Free (Command : access Paste_Command_Type);

end Commands.Paste;



with Ada.Unchecked_Deallocation;

package body Commands.Simple is

   procedure Deallocate is
     new Ada.Unchecked_Deallocation
     (Simple_Command_Type,
      Simple_Command_Access);


   function New_Simple_Command (Receiver : access Receiver_Type)
     return Simple_Command_Access is
   begin
      return new Simple_Command_Type (Receiver);
   end;


   procedure Do_Free (Command : access Simple_Command_Type) is

      CA : Simple_Command_Access :=
        Simple_Command_Access (Command);
   begin
      Deallocate (CA);
   end;


   procedure Execute (Command : access Simple_Command_Type) is
   begin
      Action (Command.Receiver.all);
   end;

end Commands.Simple;




generic
   type Receiver_Type (<>) is limited private;
   with procedure Action (Receiver : in out Receiver_Type);
package Commands.Simple is

   type Simple_Command_Type (Receiver : access Receiver_Type) is
     new Root_Command_Type with private;

   type Simple_Command_Access is access all Simple_Command_Type;

   function New_Simple_Command (Receiver : access Receiver_Type)
     return Simple_Command_Access;

   procedure Execute (Command : access Simple_Command_Type);

private

   type Simple_Command_Type (Receiver : access Receiver_Type) is
     new Root_Command_Type with null record;

   procedure Do_Free (Command : access Simple_Command_Type);

end Commands.Simple;




package body Commands is

   procedure Free (Command : in out Root_Command_Access) is
   begin
      Do_Free (Command);
      Command := null;
   end;

   procedure Do_Free (Command : access Root_Command_Type) is
   begin
      null;
   end;

end Commands;






package Commands is

   type Root_Command_Type (<>) is abstract tagged limited private;

   type Root_Command_Access is access all Root_Command_Type'Class;

   procedure Execute
     (Command : access Root_Command_Type) is abstract;

   procedure Free (Command : in out Root_Command_Access);

private

   type Root_Command_Type is
     abstract tagged limited record
        Next : Root_Command_Access;
     end record;

   procedure Do_Free (Command : access Root_Command_Type);

end Commands;






package body Documents.Containers is

   procedure Add (Document : access Document_Type'Class;
                  To       : in out Document_Container) is

      Container : Document_Container renames To;
   begin
      Document.Next := Container.Head;
      Container.Head := Document_Class_Access (Document);
   end;


   procedure For_Every_Document (Container : in Document_Container) is

      Index : Document_Class_Access := Container.Head;
   begin
      while Index /= null loop
         Process (Index);
         Index := Index.Next;
      end loop;
   end For_Every_Document;


end Documents.Containers;


package Documents.Containers is

   type Document_Container is limited private;

   procedure Add (Document : access Document_Type'Class;
                  To       : in out Document_Container);

   generic
      with procedure Process (Doc : access Document_Type'Class);
   procedure For_Every_Document (Container : in Document_Container);

private

   type Document_Container is
      limited record
         Head : Document_Class_Access;
      end record;

end Documents.Containers;


with Ada.Unchecked_Deallocation;
with Ada.Text_IO;                 use Ada.Text_IO;

package body Documents is

   procedure Deallocate is
     new Ada.Unchecked_Deallocation
     (Document_Type, Document_Access);


   function New_Doc (Name : String) return Document_Access is

      Doc : constant Document_Access :=
        Document_Access'(new Document_Type);
   begin
      Doc.Name := To_Unbounded_String (Name);
      return Doc;
   end;


   procedure Do_Free (Doc : access Document_Type) is

      DA : Document_Access := Document_Access (Doc);
   begin
      Deallocate (DA);
   end;


   procedure Open
     (Document : access Document_Type) is
   begin
      Put_Line
        ("opening document named '" &
         To_String (Document.Name) &
         "'");
   end;

   procedure Close
     (Document : access Document_Type) is
   begin
      Put_Line ("closing document");
   end;

   procedure Cut
     (Document : access Document_Type) is
   begin
      Put_Line
        ("cut text from doc named '" &
         To_String (Document.Name) &
         "'");
   end;

   procedure Copy
     (Document : access Document_Type) is
   begin
      Put_Line ("copy text from doc");
   end;

   procedure Paste
     (Document : access Document_Type) is
   begin
      Put_Line
        ("paste text into doc named '" &
         To_String (Document.Name) &
         "'");
   end;


   procedure Free (Document : in out Document_Class_Access) is
   begin
      Do_Free (Document);
      Document := null;
   end;

end Documents;


with Ada.Strings.Unbounded;

package Documents is

   type Document_Type (<>) is tagged limited private;

   type Document_Class_Access is access all Document_Type'Class;


   type Document_Access is access all Document_Type;

   function New_Doc (Name : String) return Document_Access;


   procedure Open
     (Document : access Document_Type);

   procedure Close
     (Document : access Document_Type);

   procedure Cut
     (Document : access Document_Type);

   procedure Copy
     (Document : access Document_Type);

   procedure Paste
     (Document : access Document_Type);


   procedure Free (Document : in out Document_Class_Access);

private

   use Ada.Strings.Unbounded;

   type Document_Type is
      tagged limited record
         Next : Document_Class_Access;
         Name : Unbounded_String;
      end record;

   procedure Do_Free (Doc : access Document_Type);

end Documents;


with Documents;    use Documents;
with Applications; use Applications;

with Commands.Paste;
with Commands.Open;
with Commands.App;  use Commands.App;

procedure Test_Commands is

   App : aliased Application_Type;

   App_Command : constant Commands.App.Simple_Command_Access :=
     New_Simple_Command (App'Access);

begin

   Execute (App_Command);

   declare
      use Commands.Open;

      Command : Open_Command_Access :=
        New_Open_Command (App'Access);
   begin
      Execute (Command);
   end;

   Execute (App_Command);

   declare
      use Commands.Paste;

      Doc : constant Document_Access :=
        New_Doc ("pastedoc.dat");

      Command : constant Paste_Command_Access :=
        New_Paste_Command (Doc);
   begin
      Execute (Command);
      Add (Doc, To => App);
   end;

   Execute (App_Command);

end Test_Commands;


(c) 1998-2004 All Rights Reserved David Botton