-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 3, or (at your option) any later
-- version. The SPARK toolset is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details. You should have received a copy of the GNU
-- General Public License distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

with Clists;
with CStacks;
with Structures;
with SP_Symbols;

use type SP_Symbols.SP_Symbol;

package body Pairs is

   --------------------------------------------------------------------------
   -- Local subprograms supporting CombinePredicateWithAction and
   -- ComposeActions
   --------------------------------------------------------------------------

   procedure Substitute (Heap                     : in out Cells.Heap_Record;
                         Structure_1, Structure_2 : in     Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives Heap,
   --#         Statistics.TableUsage from *,
   --#                                    Heap,
   --#                                    Structure_1,
   --#                                    Structure_2;
   is
      ModCell, P : Cells.Cell;
      S          : CStacks.Stack;
      DagFound   : Boolean;
      DagRoot    : Cells.Cell;

      function IsLeaf (Node : Cells.Cell) return Boolean
      --# global in Heap;
      is
      begin
         return Cells.Is_Null_Cell (Cells.Get_B_Ptr (Heap, Node));
      end IsLeaf;

      -----------------------

      procedure FindDagRep (RefCell  : in     Cells.Cell;
                            DagFound :    out Boolean;
                            DagRoot  :    out Cells.Cell)
      --# global in Heap;
      --#        in Structure_1;
      --# derives DagFound,
      --#         DagRoot  from Heap,
      --#                       RefCell,
      --#                       Structure_1;
      is
         RefVarName : Natural;
         RefVarOp   : SP_Symbols.SP_Symbol;
         ModVarCell : Cells.Cell;

      begin
         RefVarName := Cells.Get_Natural_Value (Heap, RefCell);
         RefVarOp   := Cells.Get_Op_Symbol (Heap, RefCell);
         ModVarCell := Clists.FirstCell (Heap, Structure_1);
         DagRoot    := Cells.Null_Cell;
         loop
            if Cells.Is_Null_Cell (ModVarCell) then
               DagFound := False;
               exit;
            end if;
            if Cells.Get_Natural_Value (Heap, ModVarCell) = RefVarName
              and then Cells.Get_Op_Symbol (Heap, ModVarCell) = RefVarOp then
               DagFound := True;
               DagRoot  := Cells.Get_B_Ptr (Heap, ModVarCell);
               exit;
            end if;
            ModVarCell := Clists.NextCell (Heap, ModVarCell);
         end loop;
      end FindDagRep;

   begin -- Substitute
      if Cells.Is_Reference_Cell (Heap, Structure_2) then
         FindDagRep (Structure_2, DagFound, DagRoot);
         if DagFound then
            Cells.Copy_Contents (Heap, DagRoot, Structure_2);
         end if;
      else
         -- Traverse Structure_2, using variant of tree-traversal
         -- algorithm of D.E. Knuth, Fundamental Algorithms, p.317.
         -- First mark roots of dags of Sructure_1 to prevent repeated copying.
         ModCell := Clists.FirstCell (Heap, Structure_1);
         loop
            exit when Cells.Is_Null_Cell (ModCell);
            Cells.Mark_Cell (Heap, Cells.Get_B_Ptr (Heap, ModCell));
            ModCell := Clists.NextCell (Heap, ModCell);
         end loop;
         -- Traverse dag:
         CStacks.CreateStack (S);
         P := Structure_2;
         loop
            loop
               exit when Cells.Is_Null_Cell (P);
               CStacks.Push (Heap, P, S);
               if IsLeaf (P) or Cells.Is_Marked (Heap, P) then
                  P := Cells.Null_Cell;
               else
                  P := Cells.Get_A_Ptr (Heap, P);
               end if;
            end loop;
            exit when CStacks.IsEmpty (S);
            P := CStacks.Top (Heap, S);
            CStacks.Pop (Heap, S);
            if IsLeaf (P) or Cells.Is_Marked (Heap, P) then
               P := Cells.Null_Cell;
            else
               if Cells.Is_Reference_Cell (Heap, Cells.Get_A_Ptr (Heap, P)) and
                 not Cells.Is_Marked (Heap, Cells.Get_A_Ptr (Heap, P)) then
                  FindDagRep (Cells.Get_A_Ptr (Heap, P), DagFound, DagRoot);
                  if DagFound then
                     Cells.Set_A_Ptr (Heap, P, DagRoot);
                  end if;
                  -- Garbage collection ?
               end if;
               if Cells.Is_Reference_Cell (Heap, Cells.Get_B_Ptr (Heap, P)) and
                 not Cells.Is_Marked (Heap, Cells.Get_B_Ptr (Heap, P)) then
                  FindDagRep (Cells.Get_B_Ptr (Heap, P), DagFound, DagRoot);
                  if DagFound then
                     Cells.Set_B_Ptr (Heap, P, DagRoot);
                  end if;
                  P := Cells.Null_Cell;
               else
                  P := Cells.Get_B_Ptr (Heap, P);
               end if;
            end if;
         end loop;

         -- unmark roots of Structure_1;
         ModCell := Clists.FirstCell (Heap, Structure_1);
         loop
            exit when Cells.Is_Null_Cell (ModCell);
            Cells.UnMark_Cell (Heap, Cells.Get_B_Ptr (Heap, ModCell));
            ModCell := Clists.NextCell (Heap, ModCell);
         end loop;
      end if;
   end Substitute;

   -- Merges two lists of assigned variables.  List1 becomes the merged list,
   -- of valid assignments.  Defunct assignments are transferred to OldRootList.
   -- The procedure disposes of the head of List2.
   procedure MergeLists (Heap                      : in out Cells.Heap_Record;
                         List1, List2, OldRootList : in     Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives Heap                  from *,
   --#                                    List1,
   --#                                    List2,
   --#                                    OldRootList &
   --#         Statistics.TableUsage from *,
   --#                                    Heap;
   is
      List1_Cell, List2_Cell, NewList : Cells.Cell;
   begin -- MergeLists
      Clists.CreateList (Heap, NewList);
      loop
         List1_Cell := Clists.FirstCell (Heap, List1);
         List2_Cell := Clists.FirstCell (Heap, List2);
         if Cells.Is_Null_Cell (List1_Cell) then
            Clists.TransferCells (Heap, List2, NewList);
            exit;
         end if;
         if Cells.Is_Null_Cell (List2_Cell) then
            Clists.TransferCells (Heap, List1, NewList);
            exit;
         end if;
         if Cells.Get_Natural_Value (Heap, List1_Cell) < Cells.Get_Natural_Value (Heap, List2_Cell) then
            Clists.RemoveLeader (Heap, List1);
            Clists.AppendCell (Heap, List1_Cell, NewList);
         elsif Cells.Get_Natural_Value (Heap, List1_Cell) = Cells.Get_Natural_Value (Heap, List2_Cell) then
            -- cells are only same if OpKinds are also same - new IF
            if Cells.Get_Op_Symbol (Heap, List1_Cell) = Cells.Get_Op_Symbol (Heap, List2_Cell) then
               -- next 4 statements were entire original contents of this IF
               Clists.RemoveLeader (Heap, List1);
               Clists.RemoveLeader (Heap, List2);
               Clists.AppendCell (Heap, List1_Cell, OldRootList);
               Clists.AppendCell (Heap, List2_Cell, NewList);
            else
               -- OpKinds are different so we can make an arbitrary decision
               -- as to which to place first in NewList.
               Clists.RemoveLeader (Heap, List1);
               Clists.AppendCell (Heap, List1_Cell, NewList);
            end if;
         else -- if Cells.Get_Natural_Value (List1_Cell) > Cells.Get_Natural_Value (List2_Cell) then
            Clists.RemoveLeader (Heap, List2);
            Clists.AppendCell (Heap, List2_Cell, NewList);
         end if;
      end loop;
      Cells.Set_A_Ptr (Heap, List1, Cells.Get_A_Ptr (Heap, NewList));
      Cells.Set_B_Ptr (Heap, List1, Cells.Get_B_Ptr (Heap, NewList));
      Cells.Dispose_Of_Cell (Heap, List2);
      Cells.Dispose_Of_Cell (Heap, NewList);
   end MergeLists;

   -----------------------

   procedure MarkAccessibleCells (Heap            : in out Cells.Heap_Record;
                                  Root            : in     Cells.Cell;
                                  MarkedCellStack :    out CStacks.Stack)
   --# global in out Statistics.TableUsage;
   --# derives Heap,
   --#         Statistics.TableUsage from *,
   --#                                    Heap,
   --#                                    Root &
   --#         MarkedCellStack       from Heap,
   --#                                    Root;
   is
      TopCell             : Cells.Cell;
      UnexploredCellStack : CStacks.Stack;

      procedure Mark (C : in Cells.Cell)
      --# global in out Heap;
      --#        in out MarkedCellStack;
      --#        in out Statistics.TableUsage;
      --#        in out UnexploredCellStack;
      --# derives Heap,
      --#         UnexploredCellStack   from C,
      --#                                    Heap,
      --#                                    MarkedCellStack,
      --#                                    UnexploredCellStack &
      --#         MarkedCellStack,
      --#         Statistics.TableUsage from *,
      --#                                    C,
      --#                                    Heap,
      --#                                    MarkedCellStack;
      is
      begin
         if not Cells.Is_Null_Cell (C) then
            if not Cells.Is_Marked (Heap, C) then
               Cells.Mark_Cell (Heap, C);
               CStacks.Push (Heap, C, MarkedCellStack);
               if not Cells.Is_Reference_Cell (Heap, C) then
                  CStacks.Push (Heap, C, UnexploredCellStack);
               end if;
            end if;
         end if;
      end Mark;

   begin -- MarkAccessibleCells;
      CStacks.CreateStack (MarkedCellStack);
      CStacks.CreateStack (UnexploredCellStack);
      Mark (Root);
      loop
         exit when CStacks.IsEmpty (UnexploredCellStack);
         TopCell := CStacks.Top (Heap, UnexploredCellStack);
         CStacks.Pop (Heap, UnexploredCellStack);
         Mark (Cells.Get_A_Ptr (Heap, TopCell));
         Mark (Cells.Get_B_Ptr (Heap, TopCell));
      end loop;
   end MarkAccessibleCells;

   -------------------------

   procedure CleanUpDags (Heap        : in out Cells.Heap_Record;
                          OldRootList : in     Cells.Cell)
   --# global in out Statistics.TableUsage;
   --# derives Heap,
   --#         Statistics.TableUsage from *,
   --#                                    Heap,
   --#                                    OldRootList;
   is
      DefunctCellStack, UnexploredCellStack : CStacks.Stack;
      TopCell                               : Cells.Cell;

      -----------------------

      procedure MarkAndPush (C : in Cells.Cell)
      --# global in out DefunctCellStack;
      --#        in out Heap;
      --#        in out Statistics.TableUsage;
      --#        in out UnexploredCellStack;
      --# derives DefunctCellStack,
      --#         Statistics.TableUsage,
      --#         UnexploredCellStack   from *,
      --#                                    C,
      --#                                    DefunctCellStack,
      --#                                    Heap &
      --#         Heap                  from *,
      --#                                    C,
      --#                                    DefunctCellStack,
      --#                                    UnexploredCellStack;
      is
      begin
         if not Cells.Is_Null_Cell (C) then
            if not Cells.Is_Marked (Heap, C) then
               Cells.Mark_Cell (Heap, C);
               CStacks.Push (Heap, C, DefunctCellStack);
               CStacks.Push (Heap, C, UnexploredCellStack);
            end if;
         end if;
      end MarkAndPush;

   begin -- CleanUpDags
      CStacks.CreateStack (UnexploredCellStack);
      CStacks.CreateStack (DefunctCellStack);
      MarkAndPush (OldRootList);
      loop
         exit when CStacks.IsEmpty (UnexploredCellStack);
         TopCell := CStacks.Top (Heap, UnexploredCellStack);
         CStacks.Pop (Heap, UnexploredCellStack);
         MarkAndPush (Cells.Get_A_Ptr (Heap, TopCell));
         MarkAndPush (Cells.Get_B_Ptr (Heap, TopCell));
      end loop;
      loop
         exit when CStacks.IsEmpty (DefunctCellStack);
         Cells.Dispose_Of_Cell (Heap, CStacks.Top (Heap, DefunctCellStack));
         CStacks.Pop (Heap, DefunctCellStack);
      end loop;
   end CleanUpDags;

   -------------------------

   procedure UnMarkCells (Heap            : in out Cells.Heap_Record;
                          MarkedCellStack : in out CStacks.Stack)
   --# derives Heap,
   --#         MarkedCellStack from Heap,
   --#                              MarkedCellStack;
   is
   begin
      loop
         exit when CStacks.IsEmpty (MarkedCellStack);
         Cells.UnMark_Cell (Heap, CStacks.Top (Heap, MarkedCellStack));
         CStacks.Pop (Heap, MarkedCellStack);
      end loop;
      -- CStacks.DisposeOfStack (Heap, MarkedCellStack);
   end UnMarkCells;

   -------------------------

   function IsNullPair (P : Pair) return Boolean is
   begin
      return Cells.Is_Null_Cell (Cells.Cell (P));
   end IsNullPair;

   --------------------------------------------------------------------------

   function IsTrue (Heap : Cells.Heap_Record;
                    P    : Pair) return Boolean is
   begin
      return Cells.Is_Null_Cell (Cells.Get_B_Ptr (Heap, Cells.Cell (P)));
   end IsTrue;

   --------------------------------------------------------------------------

   function IsUnitAction (Heap : Cells.Heap_Record;
                          P    : Pair) return Boolean is
   begin
      return Cells.Is_Null_Cell (Cells.Get_C_Ptr (Heap, Cells.Cell (P)));
   end IsUnitAction;

   --------------------------------------------------------------------------

   function CellToPair (C : Cells.Cell) return Pair is
   begin
      return Pair (C);
   end CellToPair;

   --------------------------------------------------------------------------

   function PairHead (P : Pair) return Cells.Cell is
   begin
      return Cells.Cell (P);
   end PairHead;

   --------------------------------------------------------------------------
   -- Exported subprograms
   --------------------------------------------------------------------------

   procedure CopyPair (Heap     : in out Cells.Heap_Record;
                       Original : in     Pair;
                       Copy     :    out Pair) is
      CopyName, RootOfNextPair : Cells.Cell;
   begin
      -- Deep copy, but ignoring A_Ptr field, so take a copy of it,
      -- and set A_Ptr to NullCell for now.
      RootOfNextPair := Cells.Get_A_Ptr (Heap, Cells.Cell (Original));
      Cells.Set_A_Ptr (Heap, Cells.Cell (Original), Cells.Null_Cell);

      -- Deep copy
      Structures.CopyStructure (Heap, Cells.Cell (Original), CopyName);
      Copy := Pair (CopyName);

      -- Put back the original value of A_Ptr field.
      Cells.Set_A_Ptr (Heap, Cells.Cell (Original), RootOfNextPair);
   end CopyPair;

   --------------------------------------------------------------------------

   -- Action_R is the structure of an action R
   -- Predicate_q is the structure of a predicate q
   procedure CombinePredicateWithAction
     (Heap                  : in out Cells.Heap_Record;
      Action_R, Predicate_q : in     Cells.Cell;
      Result                :    out Cells.Cell)
   is
      MarkedCellStack : CStacks.Stack;
      OldRootList     : Cells.Cell;
   begin
      Substitute (Heap, Action_R, Predicate_q);
      -- prepare Structure_1 for garbage collection;
      OldRootList := Action_R;

      -- perform step a7 of JFB Fig.6.13: remove redundant elements;
      if Clists.IsEmptyList (Heap, OldRootList) then
         Clists.DisposeOfList (Heap, OldRootList);
      else
         MarkAccessibleCells (Heap, Predicate_q, MarkedCellStack);
         CleanUpDags (Heap, OldRootList);
         --# accept F, 10, MarkedCellStack, "MarkedCellStack unused here";
         UnMarkCells (Heap, MarkedCellStack);
         --# end accept;
      end if;
      -- get rid of other structure in each case ? Simplify to structure 2 always ?
      Result := Predicate_q;
   end CombinePredicateWithAction;

   --------------------------------------------------------------------------

   -- Action_R is the structure of an action R
   -- Action_S is the structure of an action S
   procedure ComposeActions (Heap               : in out Cells.Heap_Record;
                             Action_R, Action_S : in     Cells.Cell;
                             Result             :    out Cells.Cell) is
      MarkedCellStack : CStacks.Stack;
      OldRootList     : Cells.Cell;
   begin
      Substitute (Heap, Action_R, Action_S);

      -- merge lists of modified variables and prepare redundant members
      -- for garbage collection;
      Clists.CreateList (Heap, OldRootList);
      MergeLists (Heap, Action_R, Action_S, OldRootList);

      -- perform step a7 of JFB Fig.6.13: remove redundant elements;
      if Clists.IsEmptyList (Heap, OldRootList) then
         Clists.DisposeOfList (Heap, OldRootList);
      else
         MarkAccessibleCells (Heap, Clists.FirstCell (Heap, Action_R), MarkedCellStack);
         CleanUpDags (Heap, OldRootList);
         --# accept F, 10, MarkedCellStack, "MarkedCellStack unused here";
         UnMarkCells (Heap, MarkedCellStack);
         --# end accept;
      end if;
      Result := Action_R;
      -- get rid of other structure in each case ? Simplify to structure 2 always ?
   end ComposeActions;

   --------------------------------------------------------------------------

   procedure FormConjunction
     (Heap                     : in out Cells.Heap_Record;
      Predicate_1, Predicate_2 : in     Cells.Cell;
      Result                   :    out Cells.Cell)
   is
      ConjunctionCell : Cells.Cell;
   begin
      Cells.Create_Cell (Heap, ConjunctionCell);
      Cells.Set_Kind (Heap, ConjunctionCell, Cell_Storage.Op);
      Cells.Set_Op_Symbol (Heap, ConjunctionCell, SP_Symbols.RWand);
      Cells.Set_A_Ptr (Heap, ConjunctionCell, Predicate_1);
      Cells.Set_B_Ptr (Heap, ConjunctionCell, Predicate_2);
      Result := ConjunctionCell;
   end FormConjunction;

   --------------------------------------------------------------------------

   procedure MultiplyPairs (Heap                     : in out Cells.Heap_Record;
                            Multiplicand, Multiplier : in     Pair;
                            Product                  :    out Pair) is
      p, R, q, S, Conjunction, CopyOfR, ProductCell, RS_Composition, Transformed_q : Cells.Cell;

   begin -- MultiplyPairs
      p := Cells.Get_B_Ptr (Heap, Cells.Cell (Multiplicand));
      R := Cells.Get_C_Ptr (Heap, Cells.Cell (Multiplicand));
      q := Cells.Get_B_Ptr (Heap, Cells.Cell (Multiplier));
      S := Cells.Get_C_Ptr (Heap, Cells.Cell (Multiplier));
      Cells.Create_Cell (Heap, ProductCell);

      -- form  p /\ q!R ;

      -- if q is just True
      if IsTrue (Heap, Multiplier) then
         -- new predicate is p;
         Cells.Set_B_Ptr (Heap, ProductCell, p);
      else
         -- if p is just True
         if IsTrue (Heap, Multiplicand) then
            -- new predicate is q!R;

            -- if R is null, then...
            if IsUnitAction (Heap, Multiplicand) then
               -- new predicate Product_Cell is q;
               Cells.Set_B_Ptr (Heap, ProductCell, q);
            else
               -- p is True, q is not null, so new
               -- predicate Product_Cell is q!R;
               Structures.CopyStructure (Heap, R, CopyOfR);
               CombinePredicateWithAction (Heap        => Heap,
                                           Action_R    => CopyOfR,
                                           Predicate_q => q,
                                           Result      => Transformed_q);
               Cells.Set_B_Ptr (Heap, ProductCell, Transformed_q);
            end if;
         else
            -- form q!R and perform its conjunction with p;

            -- if R is null...
            if IsUnitAction (Heap, Multiplicand) then
               -- ...then q!R is q
               Transformed_q := q;
            else
               -- form q!R and store in Transformed_q;
               Structures.CopyStructure (Heap, R, CopyOfR);
               CombinePredicateWithAction (Heap        => Heap,
                                           Action_R    => CopyOfR,
                                           Predicate_q => q,
                                           Result      => Transformed_q);
            end if;

            -- Product_Cell := p and Transformed_q
            FormConjunction (Heap, p, Transformed_q, Conjunction);
            Cells.Set_B_Ptr (Heap, ProductCell, Conjunction);
         end if;
      end if;

      -- Product_Cell's B_Ptr field now contains the result of forming
      -- p and q!R for all cases.

      -- Now form R.S

      -- If either R or S are null, then it's easy
      if IsUnitAction (Heap, Multiplicand) then
         Cells.Set_C_Ptr (Heap, ProductCell, S);
      elsif IsUnitAction (Heap, Multiplier) then
         Cells.Set_C_Ptr (Heap, ProductCell, R);
      else
         -- R and S both non-null, so
         -- construct and store R.S composition;
         ComposeActions (Heap     => Heap,
                         Action_R => R,
                         Action_S => S,
                         Result   => RS_Composition);

         Cells.Set_C_Ptr (Heap, ProductCell, RS_Composition);
      end if;
      Cells.Dispose_Of_Cell (Heap, Cells.Cell (Multiplicand));
      Cells.Dispose_Of_Cell (Heap, Cells.Cell (Multiplier));
      Product := Pair (ProductCell);
   end MultiplyPairs;

end Pairs;
