(20 . 7)(20 . 6)
-- Basics
with Version;  use Version;
with OS;       use OS;
with CmdLine;  use CmdLine;

-- FFA
with FFA;      use FFA;
(32 . 115)(31 . 170)
with FFA_RNG;  use FFA_RNG;


procedure FFA_Calc is
package body FFA_Calc is
   
   Width   : Positive;   -- Desired FFA Width
   Height  : Positive;   -- Desired Height of Stack
   RNG     : RNG_Device; -- The active RNG device.
   
begin
   if Arg_Count < 3 or Arg_Count > 4 then
      Eggog("Usage: ./ffa_calc WIDTH HEIGHT [/dev/rng]");
   end if;
   
   declare
      Arg1 : CmdLineArg;
      Arg2 : CmdLineArg;
   -- Ensure that requested Peh Dimensions are permissible.  Terminate if not.
   procedure Validate_Peh_Dimensions(Dimensions : in Peh_Dimensions) is
   begin
      -- Get commandline args:
      Get_Argument(1, Arg1); -- First arg
      Get_Argument(2, Arg2); -- Second arg
      
      if Arg_Count = 4 then
         -- RNG was specified:
         declare
            Arg3 : CmdLineArg;
         begin
            Get_Argument(3, Arg3); -- Third arg (optional)
            
            -- Ada.Sequential_IO chokes on paths with trailing whitespace!
            -- So we have to give it a trimmed path. But we can't use
            -- Ada.Strings.Fixed.Trim, because it suffers from
            -- SecondaryStackism-syphilis. Instead we are stuck doing this:
            Init_RNG(RNG, Arg3(Arg3'First .. Len_Arg(3)));
         end;
      else
         -- RNG was NOT specified:
         Init_RNG(RNG); -- Use the machine default then
      
      -- Test if proposed Width is permissible:
      if not FFA_FZ_Valid_Bitness_P(Dimensions.Width) then
         Eggog("Requested Invalid FZ Width, " & FFA_Validity_Rule_Doc);
      end if;
      
      -- Warn the operator if an unbounded Peh run has been requested:
      if Dimensions.Life = 0 then
         Achtung("WARNING: Life=0 enables UNBOUNDED run time;" &
                   " halting cannot be guaranteed!");
      end if;
      
      -- Parse into Positives:
      Width  := Positive'Value(Arg1);
      Height := Positive'Value(Arg2);
   exception
      when others =>
         Eggog("Invalid arguments!");
   end;
   end Validate_Peh_Dimensions;
   
   -- Test if proposed Width is permissible:
   if not FFA_FZ_Valid_Bitness_P(Width) then
      Eggog("Invalid Width: " & FFA_Validity_Rule_Doc);
   end if;
   
   -- The Calculator itself:
   declare
   -- Start a Peh Machine with the given Dimensions and Tape; return a Verdict.
   function Peh_Machine(Dimensions : in Peh_Dimensions;
                        Tape       : in Peh_Tapes;
                        RNG        : in RNG_Device) return Peh_Verdicts is
      
      -- The number of Words required to make a FZ of the given Bitness.
      Wordness : Indices := Indices(Width / Bitness);
      Wordness : Indices := Indices(Dimensions.Width / Bitness);
      
      --------------------------------------------------------
      -- State --
      --------------------------------------------------------
      -- The Stack:
      subtype Stack_Positions is Natural range 0 .. Height;
      -- The Data Stack:
      subtype Stack_Positions is Natural range 0 .. Dimensions.Height;
      type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
      Stack      : Stacks(Stack_Positions'Range);
      Stack         : Stacks(Stack_Positions'Range);
      
      -- Current top of the Data Stack:
      SP            : Stack_Positions := Stack_Positions'First;
      
      -- Valid indices into the Tape:
      subtype Tape_Positions is Peh_Tape_Range range Tape'First .. Tape'Last;
      
      -- Position of the CURRENT Op on the Tape:
      IP            : Tape_Positions;
      
      -- After an Op, will contain position of NEXT op (if = to IP -> halt)
      IP_Next       : Tape_Positions;
      
      -- Control Stack; permits bidirectional motion across the Tape:
      Control_Stack : array(ControlStack_Range) of Tape_Positions
        := (others => Tape_Positions'First);
      
      -- Stack Pointer:
      SP         : Stack_Positions := Stack_Positions'First;
      -- Current top of the Control Stack:
      CSP           : ControlStack_Range := ControlStack_Range'First;
      
      -- Registers:
      subtype RegNames is Character range 'g' .. 'z';
      type RegTables is array(RegNames range <>) of FZ(1 .. Wordness);
      Registers     : RegTables(RegNames'Range);
      
      -- Carry/Borrow Flag:
      Flag       : WBool   := 0;
      Flag          : WBool        := 0;
      
      -- Odometer:
      Pos        : Natural := 0;
      Ticks         : Natural      := 0;
      
      -- The current levels of the three types of nestedness:
      QuoteLevel : Natural := 0;
      CommLevel  : Natural := 0;
      CondLevel  : Natural := 0;
      QuoteLevel    : Natural      := 0;
      CommLevel     : Natural      := 0;
      CondLevel     : Natural      := 0;
      
      -- Prefixed Operators
      PrevC      : Character := ' ';
      HavePrefix : Boolean   := False;
      PrevC         : Character    := ' ';
      HavePrefix    : Boolean      := False;
      
      -- Current Verdict. We run while 'Mu', tape remains, and Ticks under max.
      Verdict       : Peh_Verdicts := Mu;
      --------------------------------------------------------
      
      
      -- Clear the stack and set SP to bottom.
      -- Determine whether we have reached the given limit of Life:
      function Exhausted_Life return Boolean is
         -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
         MustDie : Boolean := 
           (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
      begin
         if MustDie then
            Achtung("WARNING: Exhausted Life ("
                      & Natural'Image(Ticks) & " ticks )");
         end if;
         return MustDie;
      end Exhausted_Life;
      
      
      -- Clear all state, other than blocks, Control Stack, Tape and Verdict:
      procedure Zap is
      begin
         -- Clear the stack
         -- Clear the Data Stack:
         for i in Stack'Range loop
            FFA_FZ_Clear(Stack(i));
         end loop;
         -- Set SP to bottom
         SP   := Stack_Positions'First;
         -- Clear Overflow flag
         Flag := 0;
         -- Clear prefix
         HavePrefix := False;
         PrevC      := ' ';
         -- Set SP to bottom:
         SP            := Stack_Positions'First;
         -- Clear all Registers:
         for r in RegNames'Range loop
            FFA_FZ_Clear(Registers(r));
         end loop;
         -- Clear Overflow flag:
         Flag          := 0;
         -- Clear prefix:
         HavePrefix    := False;
         PrevC         := ' ';
      end Zap;
      
      
      -- Report a fatal error condition at the current symbol
      -- Report a fatal error condition at the current symbol.
      -- On Unixlikes, this will also end the process and return control to OS.
      procedure E(S : in String) is
      begin
         Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
         Zap; -- Jettison all resettable state!
         Eggog("FATAL: Tick:" & Natural'Image(Ticks) &
                 " IP:" & Tape_Positions'Image(IP) & " : " & S);
      end E;
      
      
      -------------------
      -- Control Stack --
      -------------------
      
      -- Push a given Tape Position to the Control Stack:
      procedure Control_Push(Position : in Tape_Positions) is
      begin
         -- First, test for Overflow of Control Stack:
         if CSP = Control_Stack'Last then
            E("Control Stack Overflow!");
         end if;
         
         -- Push given Tape Position to Control Stack:
         CSP                := CSP + 1;
         Control_Stack(CSP) := Position;
      end Control_Push;
      
      
      -- Pop a Tape Position from the Control Stack:
      function Control_Pop return Tape_Positions is
         Position : Tape_Positions;
      begin
         -- First, test for Underflow of Control Stack:
         if CSP = Control_Stack'First then
            E("Control Stack Underflow!");
         end if;
         
         -- Pop a Tape Position from Control Stack:
         Position           := Control_Stack(CSP);
         Control_Stack(CSP) := Tape_Positions'First;
         CSP                := CSP - 1;
         return Position;
      end Control_Pop;
      
      
      ----------------
      -- Data Stack --
      ----------------
      
      -- Move SP up
      procedure Push is
      begin
(206 . 11)(260 . 40)
      end Print_FZ;
      
      
      -- Denote that the given op is a prefix
      procedure IsPrefix is
      -- Print a Debug Trace (used in 'QD')
      procedure Print_Trace is
      begin
         HavePrefix := True;
      end IsPrefix;
         -- Print Data Stack Trace:
         Write_String("Data Stack:");
         Write_Newline;
         for i in reverse Stack'First + 1 .. SP loop
            Write_String("   " & Stack_Positions'Image(i) & " : ");
            Print_FZ(Stack(i));
         end loop;
         
         -- Print Control Stack Trace:
         Write_String("Control Stack:");
         Write_Newline;
         for i in reverse Control_Stack'First + 1 .. CSP loop
            Write_String("   " & ControlStack_Range'Image(i) & " :"
                           & Tape_Positions'Image(Control_Stack(i)));
            Write_Newline;
         end loop;
         
         -- Print All Registers:
         Write_String("Registers:");
         Write_Newline;
         for r in RegNames'Range loop
            Write_String("    " & r & " : ");
            Print_FZ(Registers(r));
         end loop;
         
         -- Print Ticks and IP:
         Write_String("Ticks :" & Natural'Image(Ticks));
         Write_Newline;
         Write_String("IP    :" & Tape_Positions'Image(IP));
         Write_Newline;
      end Print_Trace;
      
      
      -- Execute a Normal Op
(275 . 6)(358 . 13)
               Want(1);
               Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
               
               -------------------------
               -- Fetch from Register --
               -------------------------
            when 'g' .. 'z' =>
               Push;
               Stack(SP) := Registers(C); -- Put value of Register on stack
               
               ------------------
               -- Stack Motion --
               ------------------
(490 . 25)(580 . 18)
               Print_FZ(Stack(SP));
               Drop;
               
               -- Zap (reset)
               -- Zap (reset all resettables)
            when 'Z' =>
               Zap;
               
               -- Quit with Stack Trace
            when 'Q' =>
               for I in reverse Stack'First + 1 .. SP loop
                  Print_FZ(Stack(I));
               end loop;
               Quit(0);
               
               -- Put the FFACalc Program Version on the stack,
               -- Put the Peh Program Version on the stack,
               -- followed by FFA Program Version.
            when 'V' =>
               Push;
               Push;
               -- FFACalc Version:
               -- Peh Version:
               FFA_FZ_Clear(Stack(SP - 1));
               FFA_FZ_Set_Head(Stack(SP - 1), Word(FFACalc_K_Version));
               FFA_FZ_Set_Head(Stack(SP - 1), Word(Peh_K_Version));
               -- FFA Version:
               FFA_FZ_Clear(Stack(SP));
               FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
(540 . 24)(623 . 50)
               -- Prefixes --
               --------------
               
               -- 'Left...'    :
            when 'L' =>
               IsPrefix;
               
               -- 'Right...'   :
            when 'R' =>
               IsPrefix;
            when
              'Q' -- 'Quit...'
              |
              'L' -- 'Left...'
              |
              'R' -- 'Right...'
              |
              'M' -- 'Modular...'
              |
              '$' -- Pop top of Stack into the following Register...
              =>
               HavePrefix := True;
               
               -------------------
               -- Control Stack --
               -------------------
               
               -- Push current IP (i.e. of THIS Op) to Control Stack.
            when ':' =>
               Control_Push(IP);
               
               -- Conditional Return: Pop top of Stack, and...
               -- ... if ZERO:    simply discard the top of the Control Stack.
               -- ... if NONZERO: pop top of Control Stack and make it next IP.
            when ',' =>
               Want(1);
               declare
                  Position : Tape_Positions := Control_Pop;
               begin
                  if FFA_FZ_NZeroP(Stack(SP)) = 1 then
                     IP_Next := Position;
                  end if;
               end;
               Drop;
               
               -- 'Modular...' :
            when 'M' =>
               IsPrefix;
               -- UNconditional Return: Control Stack top popped into IP_Next.
            when ';' =>
               IP_Next := Control_Pop;
               
               ---------------------------------------------------------
               -- Reserved Ops, i.e. ones we have not defined yet:   --
               -- Reserved Ops, i.e. ones we have not defined yet:    --
               ---------------------------------------------------------
            when '!' | '@' | '$' | ':' | ';' | ',' |
                 'H' | 'I' | 'J' | 'K' | 'N' |
                 'T' | 'X' | 'Y' =>
            when '!' | '@' |
                 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
               
               E("This Operator is not defined yet: " & C);
               ---------------------------------------------------------
(578 . 12)(687 . 81)
      -- Execute a Prefixed Op
      procedure Op_Prefixed(Prefix : in Character;
                            O      : in Character) is
         
         -- Report an attempt to execute an undefined Prefix Op:
         procedure Undefined_Prefix_Op is
         begin
            E("Undefined Prefix Op: " & Prefix & O);
         end Undefined_Prefix_Op;
         
      begin
         
         -- The Prefixed Op:
         -- Which Prefix Op?
         case Prefix is
            
            ---------------------------------------------------------
            -- Quit...
            when 'Q' =>
               
               -- .. Quit how?
               case O is
                  
                  -- ... with a 'Yes' Verdict:
                  when 'Y' =>
                     Verdict := Yes;
                     
                  -- ... with a 'No' Verdict:
                  when 'N' =>
                     Verdict := No;
                     
                  -- ... with a 'Mu' Verdict: (permitted, but discouraged)
                  when 'M' =>
                     IP_Next := IP; -- Force a 'Mu' Termination
                     
                  -- ... with Debug Trace, and a 'Mu' Verdict:
                  when 'D' =>
                     Print_Trace;
                     IP_Next := IP; -- Force a 'Mu' Termination
                     
                     -- ... with an explicit Tape-triggered fatal EGGOG!
                     -- The 'QE' curtain call is intended strictly to signal
                     -- catastrophic (e.g. iron) failure from within a Tape
                     -- program ('cosmic ray' scenario) where a ~hardwired
                     -- mechanism~ of any kind appears to have done something
                     -- unexpected; or to abort on a failed test of the RNG;
                     -- or similar hard-stop scenarios, where either physical
                     -- iron, or basic FFA routine must be said to have failed,
                     -- and the continued use of the system itself - dangerous.
                     -- The use of 'QE' for any other purpose is discouraged;
                     -- please do not use it to indicate failed decryption etc.
                  when 'E' =>
                     -- Hard-stop with this eggog:
                     E("Tape-triggered CATASTROPHIC ERROR! " &
                         "Your iron and/or your build of Peh, " &
                         "may be defective! Please consult " & 
                         "the author of this Tape.");
                     
                     -- ... Unknown (Eggog):
                  when others =>
                     Undefined_Prefix_Op;
                     
               end case;
               
            ---------------------------------------------------------
            -- Write into Register...
            when '$' =>
               
               -- Eggog if operator gave us a garbage Register name:
               if O not in RegNames then
                  E("There is no Register '" & O & "' !");
               end if;
               
               -- Selected Register exists; move top FZ on stack into it:
               Want(1);
               Registers(O) := Stack(SP);
               Drop;
            
            ---------------------------------------------------------
            -- Left...
            when 'L' =>
               
(608 . 9)(786 . 9)
                  when 'R' =>
                     E("Left-Rotate not yet defined!");
                     
                  -- ... Unknown:
                  -- ... Unknown (Eggog):
                  when others =>
                     E("Undefined Op: L" & O);
                     Undefined_Prefix_Op;
                     
               end case;
            ---------------------------------------------------------
(646 . 9)(824 . 9)
                                         XY => Stack(SP - 1));
                     Drop;
                     
                  -- ... Unknown:
                  -- ... Unknown (Eggog):
                  when others =>
                     E("Undefined Op: R" & O);
                     Undefined_Prefix_Op;
                     
               end case;
            ---------------------------------------------------------
(689 . 9)(867 . 9)
                     Drop;
                     Drop;
                     
                  -- ... Unknown:
                  -- ... Unknown (Eggog):
                  when others =>
                     E("Undefined Op: M" & O);
                     Undefined_Prefix_Op;
                     
               end case;
            ---------------------------------------------------------
(769 . 29)(947 . 77)
            Op_Normal(C);
         end if;
         
         -- In all cases, save the current symbol as possible prefix:
         PrevC := C;
         
      end Op;
      
      
      -- Current Character
      C : Character;
      
   begin
      -- Reset the Calculator      
      -- Reset all resettable state:
      Zap;
      -- Process characters until EOF:
      
      -- Execution begins with the first Op on the Tape:
      IP := Tape_Positions'First;
      
      loop
         if Read_Char(C) then
            -- Execute Op:
            Op(C);
            -- Advance Odometer
            Pos := Pos + 1;
            -- Save the op for use in prefixed ops
            PrevC := C;
         
         -- If current Op is NOT the last Op on the Tape:
         if IP /= Tape_Positions'Last then
            
            -- ... then default successor of the current Op is the next one:
            IP_Next := IP + 1;
            
         else
            Zap;
            Quit(0); -- if EOF, we're done
            
            -- ... but if no 'next' Op exists, or quit-with-Mu, we stay put:
            IP_Next := IP; -- ... this will trigger an exit from the loop.
            
         end if;
         
         -- Advance Odometer for every Op (incl. prefixes, in comments, etc) :
         Ticks := Ticks + 1;
         
         -- Execute the Op at the current IP:
         Op(Tape(IP));
         
         -- Halt when...
         exit when
           Verdict /= Mu or -- Got a Verdict, or...
           IP_Next  = IP or -- Reached the end of the Tape, or...
           Exhausted_Life;  -- Exhausted Life.
         
         -- We did not halt yet, so select the IP of the next Op to fetch:
         IP := IP_Next;
         
      end loop;
   end;
      
      -- Warn operator about any unclosed blocks:
      if CommLevel > 0 then
         Achtung("WARNING: Tape terminated with an unclosed Comment!");
      end if;
      
      if QuoteLevel > 0 then
         Achtung("WARNING: Tape terminated with an unclosed Quote!");
      end if;
      
      if CondLevel > 0 then
         Achtung("WARNING: Tape terminated with an unclosed Conditional!");
      end if;
      
      -- Warn operator if we terminated with a non-empty Control Stack.
      -- This situation ought to be considered poor style in a Peh Tape;
      -- for clarity, Verdicts should be returned from a place near
      -- the visually-apparent end of a Tape. However, this is not mandatory.
      if CSP /= Control_Stack'First then
         Achtung("WARNING: Tape terminated with a non-empty Control Stack!");
      end if;
      
      -- We're done with the Tape, so clear the state:
      Zap;
      
      -- Return the Verdict:
      return Verdict;
      
   end Peh_Machine;
   
end FFA_Calc;