--  Program 6A   May 2024




--  Playing Pools Plus (using three kinds of Poles for the Tower)



with System.Storage_Pools;  use System.Storage_Pools;
with System.Storage_Elements;  use System.Storage_Elements;
use System;
package Pools is
   type Pond(Size: Storage_Count) is
      new Root_Storage_Pool with private;

   procedure Allocate(Pool: in out Pond;
         Storage_Address: out Address;
         SISE: in Storage_Count;
         Align: in Storage_Count);

   procedure Deallocate(Pool: in out Pond;
         Storage_Address: in Address;
         SISE: in Storage_Count;
         Align: in Storage_Count);

   function Storage_Size(Pool: Pond)
         return Storage_Count;
   procedure Initialize(Pool: in out Pond);
   procedure Finalize(Pool: in out Pond);
   Error: exception;
private
   type Integer_Array is array (Storage_Count range <>) of Integer;
   type Boolean_Array is array (Storage_Count range <>) of Boolean;
   type Pond(Size: Storage_Count) is
         new Root_Storage_Pool with
      record
         Monitoring: Boolean;
         Free: Storage_Count;
         Count: Integer_Array(1 .. Size);
         Used: Boolean_Array(1 .. Size);
         Store: Storage_Array(1 .. Size);
      end record;
end;

with Ada.Text_IO;  use Ada.Text_IO;
with Ada.Integer_Text_IO;  use Ada.Integer_Text_IO;
package body Pools is

   procedure Put_Usage(Pool: in Pond) is
      Nol: Integer := 0;
      Mark: constant array (Boolean) of Character := ".*";
   begin
      if not Pool.Monitoring then return; end if;
      for I in 1 .. Pool.Size loop
         Put(Mark(Pool.Used(I)));
         Nol := Nol + 1;
         if Nol = 64 then New_Line;  Nol := 0; end if;
      end loop;
      Skip_Line;
   end Put_Usage;

   procedure Allocate(Pool: in out Pond;
         Storage_Address: out Address;
         SISE: in Storage_Count;
         Align: in Storage_Count) is
      Index: Storage_Offset;
   begin
      if Pool.Monitoring then
         Set_Col(40);  Put("Allocating    ");
         Put(Integer(SISE), 2);  Put(" , ");
         Put(Integer(Align), 2);  New_Line;
      end if;
      if https://url.uk.m.mimecastprotect.com/s/hsiCCJqDDiqqpBpvtVprGN?domain=pool.free < SISE then
          raise Error with "Not enough space";
      end if;
      Index := Align - Pool.Store(Align)'Address mod Align;
      while Index <= Pool.Size-SISE+1 loop
         if Pool.Used(Index .. Index+SISE-1) = (1 .. SISE => False) then
            for I in Index .. Index+SISE-1 loop
               Pool.Used(I) := True;
               Pool.Count(I) := Pool.Count(I) + 1;
            end loop;
            https://url.uk.m.mimecastprotect.com/s/hsiCCJqDDiqqpBpvtVprGN?domain=pool.free := https://url.uk.m.mimecastprotect.com/s/hsiCCJqDDiqqpBpvtVprGN?domain=pool.free - SISE;
            Storage_Address := Pool.Store(Index)'Address;
            Put_Usage(Pool);
            return;
         end if;
         Index := Index + Align;
      end loop;
      raise  Error with "Pool fragmented";
   end Allocate;

   procedure Deallocate(Pool: in out Pond;
         Storage_Address: in Address;
         SISE: in Storage_Count;
         Align: in Storage_Count) is
      Index: Storage_Offset;
   begin
      if Pool.Monitoring then
         Set_Col(40);  Put("Deallocating  ");
         Put(Integer(SISE), 2);  New_Line;
      end if;
      Index := Storage_Address - Pool.Store(1)'Address;
      for I in 1 .. SISE loop
          Pool.Used(I+Index) := False;
      end loop;
      https://url.uk.m.mimecastprotect.com/s/hsiCCJqDDiqqpBpvtVprGN?domain=pool.free := https://url.uk.m.mimecastprotect.com/s/hsiCCJqDDiqqpBpvtVprGN?domain=pool.free + SISE;
      Put_Usage(Pool);
   end Deallocate;

   function Storage_Size(Pool: Pond)
         return Storage_Count is
   begin
      return Pool.Size;
   end Storage_Size;

   procedure Initialize(Pool: in out Pond) is
      Char: Character;
   begin
      Put("Initializing pool of type Pond ");
      Put(" Pool size is ");
      Put(Integer(Pool.Size), 0);
      New_Line;
      loop
         Put("Is pool monitoring required, Y or N?  ");
         Get(Char);
         case Char is
            when 'y' | 'Y' =>
               Pool.Monitoring := True; exit;
            when 'n' | 'N' =>
               Pool.Monitoring := False; exit;
            when others =>
               null;
         end case;
         New_Line;
      end loop;
      New_Line;
      https://url.uk.m.mimecastprotect.com/s/hsiCCJqDDiqqpBpvtVprGN?domain=pool.free := Pool.Size;
      for I in 1 .. Pool.Size loop
         Pool.Count(I) := 0;  Pool.Used(I) := False;
      end loop;
   end Initialize;

   procedure Finalize(Pool: in out Pond) is
      Nol: Integer := 0;
   begin
      Put_Line("Finalizing pool - usages were");
      for I in 1 .. Pool.Size loop
         Put(Pool.Count(I), 4);  Nol := Nol + 1;
         if Nol = 16 then New_Line;  Nol := 0; end if;
      end loop;
      New_Line;  Skip_Line;
   end Finalize;

end Pools;

with Pools;
package Heap is
   The_Pool: Pools.Pond(Size => 128);
end Heap;

package Stacks is
   type Stack is limited interface;
   procedure Push(S: in out Stack; X: in Integer) is abstract;
   procedure Pop(S: in out Stack; X: out Integer) is abstract;
end Stacks;

with Heap;  use Heap;
package Stacks.Linked is
   type L_Stack is limited new Stack with private;
   procedure Push(S: in out L_Stack; X: in Integer);
   procedure Pop(S: in out L_Stack; X: out Integer);
private
   type Cell;
   type Cell_Ptr is access Cell;
   for Cell_Ptr'Storage_Pool use The_Pool;

   type Cell is
      record
         Next: Cell_Ptr;
         Value: Integer;
      end record;

   type L_Stack is limited new Stack with
      record
         Head: Cell_Ptr;
      end record;

end;

with Ada.Unchecked_Deallocation;  use Ada;
package body Stacks.Linked is

   procedure Free is new Unchecked_Deallocation(Cell, Cell_Ptr);

   procedure Push(S: in out L_Stack; X: in Integer) is
   begin
      S.Head := new Cell'(S.Head, X);
   end Push;

   procedure Pop(S: in out L_Stack; X: out Integer) is
      Old_Head: Cell_Ptr := S.Head;
   begin
      X := S.Head.Value;
      S.Head := S.Head.Next;
      Free(Old_Head);
   end Pop;

end Stacks.Linked;

with Heap;  use Heap;
package Stacks.Discrim is
   type D_Stack is limited new Stack with private;
   procedure Push(S: in out D_Stack; X: in Integer);
   procedure Pop(S: in out D_Stack; X: out Integer);
private
   type Cell;
   type Cell_Ptr is access Cell;
   for Cell_Ptr'Storage_Pool use The_Pool;

   type Integer_Array is array (Integer range <>) of Integer;

   type Cell(Size: Integer) is
      record
         Next: Cell_Ptr;
         Value: Integer_Array(1 .. Size);
      end record;

   type D_Stack is limited new Stack with
      record
         Head: Cell_Ptr;
      end record;

end;

with Ada.Unchecked_Deallocation;  use Ada;
package body Stacks.Discrim is

   procedure Free is new Unchecked_Deallocation(Cell, Cell_Ptr);

   procedure Push(S: in out D_Stack; X: in Integer) is
   begin
      S.Head := new Cell'(X, S.Head, (1..X => X));
   end Push;

   procedure Pop(S: in out D_Stack; X: out Integer) is
      Old_Head: Cell_Ptr := S.Head;
   begin
      X := S.Head.Size;
      S.Head := S.Head.Next;
      Free(Old_Head);
   end Pop;

end Stacks.Discrim;

package Stacks.Vector is
   type V_Stack(Max: Integer) is limited new Stack with private;
   procedure Push(S: in out V_Stack; X: in Integer);
   procedure Pop(S: in out V_Stack; X: out Integer);
private
   type Integer_Vector is array (Integer range <>) of Integer;
   type V_Stack(Max: Integer) is limited new Stack with
      record
         V: Integer_Vector(1 .. Max);
         Top: Integer;
      end record;
end;

package body Stacks.Vector is

   procedure Push(S: in out V_Stack; X: in Integer) is
   begin
      https://url.uk.m.mimecastprotect.com/s/61BeCKZXXu228D8NtvQ2bI?domain=s.top := https://url.uk.m.mimecastprotect.com/s/61BeCKZXXu228D8NtvQ2bI?domain=s.top + 1;
      S.V(S.Top) := X;
   end Push;

   procedure Pop(S: in out V_Stack; X: out Integer) is
   begin
      X := S.V(S.Top);
      https://url.uk.m.mimecastprotect.com/s/61BeCKZXXu228D8NtvQ2bI?domain=s.top := https://url.uk.m.mimecastprotect.com/s/61BeCKZXXu228D8NtvQ2bI?domain=s.top - 1;
   end Pop;

end Stacks.Vector;

package Tower is
   type Kind is (Linked, Discrim, Vector);
   type Kinds is array (1 .. 3) of Kind;
   procedure Start(K: Kinds; N, On: in Integer);
   procedure Move(N, From, To: in Integer);
end;

with Heap;  use Heap;
with Stacks;  use Stacks;
with Stacks.Linked;  use Stacks.Linked;
with Stacks.Discrim;  use Stacks.Discrim;
with Stacks.Vector;  use Stacks.Vector;
with Ada.Text_IO;  use Ada.Text_IO;
with Ada.Integer_Text_IO;  use Ada.Integer_Text_IO;
package body Tower is

   type Stack_Ptr is access Stack'Class;
   for Stack_Ptr'Storage_Pool use The_Pool;

   Pole: array (1 .. 3) of Stack_Ptr;

   procedure Start(K: Kinds; N, On: in Integer) is
      -- This sets up the three poles of the kinds
      -- requested and then pushes the initial discs
      -- onto the pole numbered On.

   begin
      for I in 1 .. 3 loop
         case K(I) is
            when Linked =>
               Pole(I) := new L_Stack;
            when Discrim =>
               Pole(I) := new D_Stack;
            when Vector =>
               Pole(I) := new V_Stack(N);
         end case;
      end loop;
      for I in reverse 1 .. N loop
         Push(Pole(On).all, I);
      end loop;
   end Start;

   procedure Move(N, From, To: in Integer) is
      -- Moves the discs according to the usual recursive
      -- algorithm. Note that From and To are always
      -- different in this program but it checks just in
      -- case.

      The_Disc: Integer;
   begin
      if From = To then
         null;    -- nothing to do!
      elsif N = 1 then
         Pop(Pole(From).all, The_Disc);
         Put("Moving disc number ");  Put(The_Disc, 0);
         Put(" from pole "); Put(From, 0);
         Put(" to pole "); Put(To, 0);
         New_Line;
         Push(Pole(To).all, The_Disc);
      else
         Move(N-1, From, 6-From-To);
         Move(1, From, To);
         Move(N-1, 6-From-To, To);
      end if;
   end Move;

end Tower;

with Tower, Pools;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Text_IO;  use Ada.Text_IO;
with Ada.Integer_Text_IO;  use Ada.Integer_Text_IO;
procedure Tower_Of_Hanoi_X is
   Size: Positive;
   Lets: String(1 .. 3);
   Patt: Tower.Kinds;
begin
   Put_Line("Welcome to the Tower of Hanoi");
   Put("Tower size please  ");
   Get(Size);
<<Again>>
   New_Line;
   Put("Give three letters L, D or V for types of poles  ");
   Get(Lets);  Skip_Line;
   for I in 1 .. 3 loop
      case Lets(I) is
         when 'l' | 'L' => Patt(I) := Tower.Linked;
         when 'd' | 'D' => Patt(I) := Tower.Discrim;
         when 'v' | 'V' => Patt(I) := Tower.Vector;
         when others => goto Again;
      end case;
   end loop;
   New_Line;
   Tower.Start(Patt, Size, 1);
   Tower.Move(Size, 1, 2);
   New_Line(2);
   Put_Line("Finished");  Skip_Line;
exception
   when Event: Pools.Error =>
      Put_Line(Exception_Message(Event));
      Put_Line("Tower toppled - tough");
      Skip_Line;
end Tower_Of_Hanoi_X;