Observers That Are Observed

In the original version of the observer pattern, a clock timer subject
was observed by digital clock observers.  When a tick happened, the
timer would update his observers, causing the digital clocks to display
the time.

In this variation, an observer can be a subject too.  A slave timer
observes a master timer, which signals its slave observers when a tick
happens.  The slave timer is also observed by digital clocks, which
display the time when signalled by their slave timer subject.

Implementation

As before, there two tagged types, one for subjects and one for
observers.  The subject type is unchanged from our original example.

The observer type is different, and instead of being the root of a
separate type hierarchy, it now derives from subject:

   type Root_Observer_Type is
     abstract new Root_Subject_Type with private;

This change allows an observer to be observed.

For subtle reasons, I also moved the access discriminants out of the
Root_Observer_Type.  This means a different mechanism is needed to bind
an observer to a subject, so we just use traditional operations:

   procedure Attach
     (Observer : access Root_Observer_Type'Class;
      To       : access Root_Subject_Type'Class);

   procedure Detach
     (Observer : access Root_Observer_Type'Class;
      From     : access Root_Subject_Type'Class);

A client can't see the representation of observer and subject types, so
there doesn't seem to be any compelling reason for a client to override
these operations.  Therefore, as with Notify, Attach and Detach are
class-wide operations.

The Master_Timer type is much the same as our Clock_Timer type before.
It publicly derives from root subject, so observers know it's
observable:

   type Master_Timer is new Root_Subject_Type with private;

It also privately derives from Root_Subject_Type, extending that type
with components for time-keeping:

  private

    type Master_Timer is
      new Root_Subject_Type with record
         Hour   : Hour_Number;
         Minute : Minute_Number;
         Second : Second_Number;
      end record;

  end Timers.Master;

When the Tick operation is called, the master timer updates its internal
state and then calls Notify, which updates its (slave timer) observers.

The Slave_Timer type is the interesting type.  It both observes master
timers (that's the source of its time), and is observed by digital
clocks, which display the slave timer's time.

In order to be observed, the slave timer must publicly state that it
is a subject, the same as for the master timer:

   type Slave_Timer (Master : access Master_Timer'Class) is
      new Root_Subject_Type with private;

A slave timer is also an observer, and must somehow bind to its subject.
That's what the access discriminant is for.  This approach guarantees
that a dangling reference from observer (slave timer) to subject (master
timer) cannot occur.

The slave timer is implemented as a private derivation from
Root_Observer_Type:

   type Slave_Timer (Master : access Master_Timer'Class) is
     new Root_Observer_Type with record
        Control : Slave_Control (Slave_Timer'Access);
     end record;

Note carefully what we have done.  The Slave_Timer type publicly
derives from Root_Subject_Type, but privately derives from
Root_Observer_Type.

This is allowed because the parent type in the full view can be any type
in the derivation class whose root is the parent type in partial view.
This is indeed the case here, because Root_Observer_Type derives from
Root_Subject_Type.

Private derivation from Root_Observer_Type means we can also hide the
fact that there's an Update operation.  Only subjects should be able to
call Update, not clients of the observer.

Observers can have a shorter lifetime than subjects, because they can be
declared in an inner scope.  It would be disaster if an observer were
allowed to vanish without first detaching itself from its subject.

Therefore, unbinding of an observer from its subject should be done
automatically, to ensure that no dangling reference from subject to
observer ever occurs.

To do this, we create a controlled component that binds to its enclosing
record (the "current instance" of the type), and calls Attach during
Initialize, and Detach during Finalize:

   type Slave_Control (Slave : access Slave_Timer) is
     new Limited_Controlled with null record;

   procedure Initialize (Control : in out Slave_Control) is
   begin
      Attach (Control.Slave, To => Control.Slave.Master);
   end;

   procedure Finalize (Control : in out Slave_Control) is
   begin
      Detach (Control.Slave, From => Control.Slave.Master);
   end;

Because the slave timer is a non-abstract observer (if only privately),
it must supply an implementation of Update:

   procedure Update (Timer : access Slave_Timer) is
   begin
      Notify (Timer.all);
   end;

When the slave timer is updated by the master timer, it responds by
simply notifying its own observers.  We're basically propagating the
event signalled by the master timer, all the way back to the digital
clocks (who aren't observing the master timer directly).

The digital clock is slightly changed.  In the original implementation,
type Digital_Clock publicly derived from Root_Observer_Type.  But that
unnecessarily exposed an implementation detail, because the only thing
clients care about is that the type has an access discriminant.

So we move the derivation from Root_Observer_Type to the private region,
and declare the public view of the type as limited private:

    type Digital_Clock (Timer : access Slave_Timer'Class) is
      limited private;

  private
    ...
    type Digital_Clock (Timer : access Slave_Timer'Class) is
      new Root_Observer_Type with record
         Control : Control_Type (Digital_Clock'Access);
      end record;

    procedure Update (Clock : access Digital_Clock);

  end Digital_Clocks;



Summary

There are three different roles being played in this version of the
Observer pattern, and each uses a slightly different idiom for its
implementation:

1) Subject Only (Master_Timer)

Publicly and privately derive from Root_Subject_Type:

    type Subject_Type is new Root_Subject_Type with private;
...
  private

    type Subject_Type is
      new Root_Subject_Type with record ...;

  end;


2) Observer Only (Digital_Clock)

Public view is limited private with an access discriminant; private view
derives from Root_Observer_Type:

    type Observer_Type (Subject : access Subject_Type'Class) is
       limited private;
...
  private

    type Observer_Control (Observer : access Observer_Type) is
      new Limited_Controlled with null record;

    type Observer_Type (Subject : access Subject_Type'Class) is
       new Root_Observer_Type with record
          Control : Observer_Control (Observer_Type'Access);
          ...
       end record;


3) Both Observer and Subject (Slave_Timer)

The public view derives from Root_Subject_Type and adds an access
discriminant; the private view derives from Root_Observer_Type:

    type Sub_and_Obs_Type (Sub : access Subject_Type'Class) is
      new Root_Subject_Type with private;
...
  private

    type Sub_And_Obs_Control (SO : access Sub_And_Obs_Type'Class) is
      new Limited_Controlled with null record;

    type Sub_And_Obs_Type (Sub : access Subject_Type'Class) is
      new Root_Observer_Type with record
         Control : Sub_And_Obs_Control (Sub_And_Obs_Type'Access);
         ...
      end record;

  end;

The following code is ready for GNAT Chop:

--STX
with Ada.Text_IO;  use Ada.Text_IO;
package body Digital_Clocks is

   procedure Update (Clock : access Digital_Clock) is

      Hour_Image : constant String :=
        Integer'Image (Get_Hour (Clock.Timer.all) + 100);

      Minute_Image : constant String :=
        Integer'Image (Get_Minute (Clock.Timer.all) + 100);

      Second_Image : constant String :=
        Integer'Image (Get_Second (Clock.Timer.all) + 100);

      Clock_Image : constant String :=
        Hour_Image (3 .. Hour_Image'Last) & ":" &
        Minute_Image (3 .. Minute_Image'Last) & ":" &
        Second_Image (3 .. Second_Image'Last);

   begin

      Put_Line (Clock_Image);

   end Update;


   procedure Initialize (Control : in out Control_Type) is
   begin
      Attach (Control.Clock, To => Control.Clock.Timer);
   end;

   procedure Finalize (Control : in out Control_Type) is
   begin
      Detach (Control.Clock, From => Control.Clock.Timer);
   end;


end Digital_Clocks;






with Timers.Slave;           use Timers.Slave;
with Subjects_And_Observers;
with Ada.Finalization;

package Digital_Clocks is

   pragma Elaborate_Body;

   type Digital_Clock (Timer : access Slave_Timer'Class) is
      limited private;

private

   use Ada.Finalization;

   type Control_Type (Clock : access Digital_Clock) is
     new Limited_Controlled with null record;

   procedure Initialize (Control : in out Control_Type);

   procedure Finalize (Control : in out Control_Type);


   use Subjects_And_Observers;

   type Digital_Clock (Timer : access Slave_Timer'Class) is
     new Root_Observer_Type with record
        Control : Control_Type (Digital_Clock'Access);
     end record;

   procedure Update (Clock : access Digital_Clock);

end Digital_Clocks;






package body Subjects_And_Observers is

   procedure Notify (Subject : in out Root_Subject_Type'Class) is
      Observer : Observer_Access := Subject.Head;
   begin
      while Observer /= null loop
         Update (Observer);
         Observer := Observer.Next;
      end loop;
   end Notify;


   procedure Attach
     (Observer : access Root_Observer_Type'Class;
      To       : access Root_Subject_Type'Class) is
   begin
      Observer.Next := To.Head;
      To.Head := Observer.all'Unchecked_Access;
   end;


   procedure Detach
     (Observer : access Root_Observer_Type'Class;
      From     : access Root_Subject_Type'Class) is

      OA : constant Observer_Access :=
        Observer.all'Unchecked_Access;

      Prev  : Observer_Access;
      Index : Observer_Access;
   begin
      if From.Head = OA then
         From.Head := From.Head.Next;
      else
         Prev := From.Head;
         Index := From.Head.Next;

         while Index /= OA loop
            Prev := Index;
            Index := Index.Next;
         end loop;

         Prev.Next := Index.Next;
      end if;
   end Detach;


end Subjects_And_Observers;
package Subjects_And_Observers is

   pragma Preelaborate;


   type Root_Subject_Type is
     abstract tagged limited private;

   procedure Notify (Subject : in out Root_Subject_Type'Class);


   type Root_Observer_Type is
     abstract new Root_Subject_Type with private;

   procedure Update (Observer : access Root_Observer_Type) is abstract;


   procedure Attach
     (Observer : access Root_Observer_Type'Class;
      To       : access Root_Subject_Type'Class);

   procedure Detach
     (Observer : access Root_Observer_Type'Class;
      From     : access Root_Subject_Type'Class);

private

   type Observer_Access is access all Root_Observer_Type'Class;
   pragma Suppress (Access_Check, On => Observer_Access);

   type Root_Subject_Type is
     abstract tagged limited record
        Head : Observer_Access;
     end record;

   type Root_Observer_Type is
     abstract new Root_Subject_Type with record
        Next : Observer_Access;
     end record;

end Subjects_And_Observers;
with Timers.Master;   use Timers.Master;
with Timers.Slave;    use Timers.Slave;

with Digital_Clocks;  use Digital_Clocks;

with Ada.Text_IO;     use Ada.Text_IO;

procedure Test_Observers is

   Master : aliased Master_Timer;

   procedure Do_Ticks is
   begin
      delay 1.0;
      Tick (Master);

      delay 2.0;
      Tick (Master);

      delay 3.0;
      Tick (Master);

      New_Line;
   end Do_Ticks;


   Timer : aliased Slave_Timer (Master'Access);
   Clock : Digital_Clock (Timer'Access);

begin

   Do_Ticks;

   declare
      Another_Timer : aliased Slave_Timer (Master'Access);
      Another_Clock : Digital_Clock (Another_Timer'Access);
   begin
      Do_Ticks;

      declare
         Yet_Another_Timer : aliased Slave_Timer (Master'Access);
         Yet_Another_Clock : Digital_Clock (Yet_Another_Timer'Access);
      begin
         Do_Ticks;
      end;

      Do_Ticks;
   end;

   Do_Ticks;

end Test_Observers;







with Ada.Calendar;  use Ada.Calendar;

package body Timers.Master is

   procedure Tick (Timer : in out Master_Timer) is

      Current_Time : constant Time := Clock;

      Current_Seconds : constant Natural :=
        Natural (Seconds (Current_Time));

   begin

      Timer.Hour := Current_Seconds / 3600;

      Timer.Minute := (Current_Seconds - 3600 * Timer.Hour) / 60;

      Timer.Second :=
        Current_Seconds -
        3600 * Timer.Hour -
        60 * Timer.Minute;

      Notify (Timer);

   end Tick;


   function Get_Hour (Timer : Master_Timer) return Hour_Number is
   begin
      return Timer.Hour;
   end;


   function Get_Minute (Timer : Master_Timer) return Minute_Number is
   begin
      return Timer.Minute;
   end;


   function Get_Second (Timer : Master_Timer) return Second_Number is
   begin
      return Timer.Second;
   end;


end Timers.Master;
with Subjects_And_Observers; use Subjects_And_Observers;

package Timers.Master is

   pragma Elaborate_Body;


   type Master_Timer is new Root_Subject_Type with private;

   procedure Tick (Timer : in out Master_Timer);

   function Get_Hour (Timer : Master_Timer) return Hour_Number;

   function Get_Minute (Timer : Master_Timer) return Minute_Number;

   function Get_Second (Timer : Master_Timer) return Second_Number;

private

   type Master_Timer is
     new Root_Subject_Type with record
        Hour   : Hour_Number;
        Minute : Minute_Number;
        Second : Second_Number;
     end record;

end Timers.Master;
package body Timers.Slave is

   procedure Initialize (Control : in out Slave_Control) is
   begin
      Attach (Control.Slave, To => Control.Slave.Master);
   end;


   procedure Finalize (Control : in out Slave_Control) is
   begin
      Detach (Control.Slave, From => Control.Slave.Master);
   end;


   function Get_Hour (Timer : Slave_Timer) return Hour_Number is
   begin
      return Get_Hour (Timer.Master.all);
   end;


   function Get_Minute (Timer : Slave_Timer) return Minute_Number is
   begin
      return Get_Minute (Timer.Master.all);
   end;


   function Get_Second (Timer : Slave_Timer) return Second_Number is
   begin
      return Get_Second (Timer.Master.all);
   end;


   procedure Update (Timer : access Slave_Timer) is
   begin
      Notify (Timer.all);
   end;

end Timers.Slave;





with Subjects_And_Observers; use Subjects_And_Observers;
with Timers.Master;          use Timers.Master;
with Ada.Finalization;

package Timers.Slave is

   pragma Elaborate_Body;


   type Slave_Timer (Master : access Master_Timer'Class) is
      new Root_Subject_Type with private;

   function Get_Hour (Timer : Slave_Timer) return Hour_Number;

   function Get_Minute (Timer : Slave_Timer) return Minute_Number;

   function Get_Second (Timer : Slave_Timer) return Second_Number;

private

   use Ada.Finalization;

   type Slave_Control (Slave : access Slave_Timer) is
     new Limited_Controlled with null record;

   procedure Initialize (Control : in out Slave_Control);

   procedure Finalize (Control : in out Slave_Control);


   type Slave_Timer (Master : access Master_Timer'Class) is
     new Root_Observer_Type with record
        Control : Slave_Control (Slave_Timer'Access);
     end record;

   procedure Update (Timer : access Slave_Timer);

end Timers.Slave;
package Timers is

   pragma Pure;

   subtype Hour_Number is Natural range 0 .. 23;

   subtype Minute_Number is Natural range 0 .. 59;

   subtype Second_Number is Natural range 0 .. 59;

end Timers;