Natools

-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- IMPLEMENTATION NOTE:                                                     --
-- In case of synchronized callbacks (same Origin and Period), there is a   --
-- collision on the internal map key. Since it is not expected to happen    --
-- often, a simple but not-so-efficient solution is used:                   --
-- When a collision is encountered, the callback is replaced by an          --
-- Event_List callback seeded with the existing callback and the new one.   --
-- When removing a callback, if it's not found directly, and second linear  --
-- is performed, looking for Event_List objects and removing it from them.  --
------------------------------------------------------------------------------

package body Natools.Cron is

   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference;
      --  Create an Event_List object containing Ref_1 and Ref_2,
      --  and return a reference to it.



   ------------------------
   -- Helper Subprograms --
   ------------------------

   function "<" (Left, Right : Periodic_Time) return Boolean is
      use type Ada.Calendar.Time;
   begin
      return Left.Origin < Right.Origin
        or else (Left.Origin = Right.Origin
           and then Left.Period < Right.Period);
   end "<";


   function Create_Event_List
     (Ref_1, Ref_2 : Callback_Refs.Reference)
      return Callback_Refs.Reference
   is
      function Create return Callback'Class;

      function Create return Callback'Class is
         Result : Event_List;
      begin
         Result.Append (Ref_1);
         Result.Append (Ref_2);
         return Result;
      end Create;
   begin
      return Callback_Refs.Create (Create'Access);
   end Create_Event_List;



   ----------------------
   -- Public Interface --
   ----------------------

   function Create

            end if;
         else
            if Actual_Time < Map.First_Key then
               First_Changed := True;
            end if;
         end if;

         declare
            Position : Entry_Maps.Cursor;
            Inserted : Boolean;
            Previous : Callback_Refs.Reference;
         begin
            Map.Insert (Actual_Time, Callback, Position, Inserted);

            if not Inserted then
               Previous := Entry_Maps.Element (Position);

               if Previous.Update.Data.all in Event_List then
                  Append
                    (Event_List (Previous.Update.Data.all),
                     Callback);
               else
                  Map.Replace_Element
                    (Position,
                     Create_Event_List (Previous, Callback));
               end if;
            end if;
         end;
      end Insert;


      procedure Remove (Callback : in Callback_Refs.Reference) is
         use type Callback_Refs.Reference;

         Cursor : Entry_Maps.Cursor := Map.First;
         Is_First : Boolean := True;
      begin
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor) = Callback then
               Map.Delete (Cursor);

               if Is_First then
                  First_Changed := True;
               end if;

               return;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;

         Is_First := True;
         Cursor := Map.First;
         while Entry_Maps.Has_Element (Cursor) loop
            if Entry_Maps.Element (Cursor).Update.Data.all in Event_List then
               declare
                  Mutator : constant Callback_Refs.Mutator
                    := Entry_Maps.Element (Cursor).Update;
                  List : Event_List renames Event_List (Mutator.Data.all);
                  Removed : Boolean;
               begin
                  List.Remove (Callback, Removed);

                  if Removed then
                     if List.Is_Empty then
                        Map.Delete (Cursor);

                        if Is_First then
                           First_Changed := True;
                        end if;
                     end if;

                     return;
                  end if;
               end;
            end if;

            Entry_Maps.Next (Cursor);
            Is_First := False;
         end loop;
      end Remove;

         end loop Wait_Loop;

         Callback.Update.Data.Run;
         Database.Update (Callback);
      end loop Main;
   end Worker;



   ----------------
   -- Event List --
   ----------------

   overriding procedure Run (Self : in out Event_List) is
   begin
      for Ref of Self.List loop
         Ref.Update.Data.Run;
      end loop;
   end Run;


   procedure Append
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference) is
   begin
      Self.List.Append (Ref);
   end Append;


   procedure Remove
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference;
      Removed : out Boolean)
   is
      use type Callback_Refs.Reference;
      Cursor : Event_Lists.Cursor := Self.List.First;
   begin
      Removed := False;

      while Event_Lists.Has_Element (Cursor) loop
         if Event_Lists.Element (Cursor) = Ref then
            Self.List.Delete (Cursor);
            Removed := True;
            return;
         end if;

         Event_Lists.Next (Cursor);
      end loop;
   end Remove;


   function Is_Empty (Self : Event_List) return Boolean is
   begin
      return Self.List.Is_Empty;
   end Is_Empty;

end Natools.Cron;

-- ticks may be skipped when computing resources lack.                      --
-- If you need more precision and/or more reliability, you might want to    --
-- consider using Ada.Real_Time.Timing_Events instead.                      --
------------------------------------------------------------------------------

with Ada.Calendar;

private with Ada.Containers.Doubly_Linked_Lists;
private with Ada.Containers.Ordered_Maps;
private with Ada.Finalization;
private with Ada.Unchecked_Deallocation;
private with Natools.References;
private with Natools.Storage_Pools;

package Natools.Cron is

   type Worker_Access is access Worker;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Worker, Worker_Access);

   Global_Worker : Worker_Access := null;


   package Event_Lists is new Ada.Containers.Doubly_Linked_Lists
     (Callback_Refs.Reference, Callback_Refs."=");

   type Event_List is new Callback with record
      List : Event_Lists.List;
   end record;

   overriding procedure Run (Self : in out Event_List);
      --  Sequentially run the contained events

   procedure Append
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference);
      --  Append Ref at the end of Self.List

   procedure Remove
     (Self : in out Event_List;
      Ref : in Callback_Refs.Reference;
      Removed : out Boolean);
      --  Remove Ref from Self.List, through a linear search

   function Is_Empty (Self : Event_List) return Boolean;
      --  Return whether Self contains any element

end Natools.Cron;