gnoga_2.1.2_5f127c56/deps/PragmARC/pragmarc-rem_nn_wrapper.adb

-- PragmAda Reusable Component (PragmARC)
-- Copyright (C) 2018 by PragmAda Software Engineering.  All rights reserved.
-- **************************************************************************
--
-- History:
-- 2018 Aug 01     J. Carter          V2.4--Cleanup compiler warnings
-- 2016 Jun 01     J. Carter          V2.3--Random_Range moved to PragmARC.Real_Random_Ranges
-- 2016 Jun 01     J. Carter          V2.2--Changed comment for empty declarative part and formatting
-- 2016 Mar 15     J. Carter          V2.1--Added Random_Weights and improved reading and writing weights
-- 2014 Jul 01     J. Carter          V2.0--Improved interface
-- 2014 Jun 15     J. Carter          V1.2--Moved large arrays to heap
-- 2014 Jun 01     J. Carter          V1.1--Added concurrency
-- 2000 May 01     J. Carter          V1.0--Initial release
--
with Ada.Finalization;
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Sequential_IO;
with Ada.Unchecked_Deallocation;

with PragmARC.Real_Random_Ranges;
with PragmARC.Universal_Random;

use Ada;
package body PragmARC.REM_NN_Wrapper is
   package body REM_NN is
      subtype Pattern_ID is Positive range 1 .. Num_Patterns;
      type Desired_Set is array (Pattern_ID) of Output_Set;
      type Count_Value is range 0 .. System.Max_Int;

      -- Basics about nodes:
      -- A node maintains the weights & related values for the connections TO itself
      -- A node also calculates its output value and supplies it to other nodes (those to which it connects)
      -- on demand

      package Input is -- Definition of input nodes
         type Node_Handle is limited private;

         procedure Set_Input (Node : in out Node_Handle; Value : in Real); -- The node accepts its external input value
         function Get_Output (From : Node_Handle) return Real; -- The node provides its output on demand
      private -- Input
         type Node_Handle is record -- An input node just provides its input value as its output
            Output : Real := 0.0;
         end record;
      end Input;

      type Input_Node_Set is array (Input_ID) of Input.Node_Handle;
      type Input_Set_Ptr is access Input_Node_Set;

      type Weight_Set is array (Positive range <>) of Weight_Group;

      package Hidden is -- Definition of hidden nodes
         type Node_Handle is limited private;

         procedure Respond (Node : in out Node_Handle); -- The node collects its input & calculates its output
         function Get_Output (From : Node_Handle) return Real; -- The node provides its output on demand
         procedure Train (Node : in out Node_Handle; ID : in Hidden_ID); -- The node updates weights on connections to it

         -- To use pre-calculated weights, the network has to be able to set weights
         -- To save weights, the network has to be able to obtain weights
         procedure Set_Weight (Node : in out Node_Handle; From : in Input_ID; Weight : in Weight_Group);
         function Get_Weight (Node : Node_Handle; From : Input_ID) return Weight_Group;
         procedure Set_Bias_Weight (Node : in out Node_Handle; Weight : in Weight_Group);
         function Get_Bias_Weight (Node : Node_Handle) return Weight_Group;
      private -- Hidden
         type Node_Handle is record
            Output : Real := 0.0;
            Deriv  : Real := 0.0;
            Bias   : Weight_Group;
            Weight : Weight_Set (Input_ID); -- Weights from input nodes to this node
         end record;
      end Hidden;

      type Hidden_Node_Set is array (Hidden_ID) of Hidden.Node_Handle;
      type Hidden_Set_Ptr is access Hidden_Node_Set;

      type Star_Group is record
         E_Star : Real := 0.0;
         H_Star : Real := 0.0;
      end record;
      type Star_Set is array (Hidden_ID) of Star_Group;

      package Output is -- Definition of output nodes
         type Node_Handle (Input_To_Output : Boolean) is limited private;

         procedure Respond (Node : in out Node_Handle; Result : out Real);
         -- The node collects its input & calculates its output, which is provided in result
         procedure Train (Node : in out Node_Handle; ID : in Output_ID); -- The node updates weights on connections to it
         function Get_Stars (Node : Node_Handle; From : Hidden_ID) return Star_Group;
         -- The node provides weighted values of E* & H* to hidden nodes on demand

         -- To use pre-calculated weights, the network has to be able to set weights
         -- To save weights, the network has to be able to obtain weights
         procedure Set_Input_Weight (Node : in out Node_Handle; From : in Input_ID; Weight : in Weight_Group);
         function Get_Input_Weight (Node : Node_Handle; From : Input_ID) return Weight_Group;
         procedure Set_Hidden_Weight (Node : in out Node_Handle; From : in Hidden_ID; Weight : in Weight_Group);
         function Get_Hidden_Weight (Node : Node_Handle; From : Hidden_ID) return Weight_Group;
         procedure Set_Bias_Weight (Node : in out Node_Handle; Weight : in Weight_Group);
         function Get_Bias_Weight (Node : Node_Handle) return Weight_Group;
      private -- Output
         -- An output node has connections from hidden nodes, which have weights to update
         -- The hidden nodes require propagated values of E* & H*
         -- These values must be propagated BEFORE the weights on the connections are updated
         -- Because an output node's TRAIN procedure is called before the hidden node's TRAIN,
         -- the output node stores the weighted values of E* & H* in hidden_star before updating the weights

         type Node_Handle (Input_To_Output : Boolean) is record
            Output        : Real := 0.0;
            Deriv         : Real := 0.0;
            Bias          : Weight_Group;
            Hidden_Weight : Weight_Set (Hidden_ID); -- Weights from hidden nodes to this node
            Hidden_Star   : Star_Set; -- Weighted E* & H* values; see comment block above

            case Input_To_Output is
            when False =>
               null;
            when True =>
               Input_Weight : Weight_Set (Input_ID); -- Weights from input nodes to this node
            end case;
         end record;
      end Output;

      subtype Output_Node_Handle is Output.Node_Handle (Input_To_Output => Input_To_Output_Connections);
      type Output_Node_Set is array (Output_ID) of Output_Node_Handle;
      type Output_Set_Ptr is access Output_Node_Set;

      type Finalizer is new Ada.Finalization.Limited_Controlled with null record;

      overriding procedure Finalize (Object : in out Finalizer);

      Input_Lim  : constant := 300.0;
      H_Star_Lim : constant := 100.0;

      -- Network state information
      Input_Node_Ptr  : Input_Set_Ptr := new Input_Node_Set;
      Input_Node      : Input_Node_Set renames Input_Node_Ptr.all;
      Hidden_Node_Ptr : Hidden_Set_Ptr := new Hidden_Node_Set;
      Hidden_Node     : Hidden_Node_Set renames Hidden_Node_Ptr.all;
      Output_Node_Ptr : Output_Set_Ptr := new Output_Node_Set;
      Output_Node     : Output_Node_Set renames Output_Node_Ptr.all;
      Desired         : Desired_Set := Desired_Set'(others => Output_Set'(others => 0.0) );
      Target          : Output_Set  := Output_Set'(others => 0.0); -- Current D infinity
      Final           : Finalizer;
      pragma Unreferenced (Final);

      Current_Pattern : Positive;

      Cycle_P : Natural_Real := P; -- Values of the parameters which are used, taking into account effect of K_? values
      Cycle_Q : Natural_Real := Q;
      Cycle_S : Natural_Real := S;

      Update_Count : Count_Value := 0;

      package Connection_IO is new Sequential_IO (Element_Type => Weight_Info);

      package Random is new Universal_Random (Supplied_Real => Real);
      package Ranges is new Real_Random_Ranges (Supplied_Real => Real);
      package Real_Math is new Numerics.Generic_Elementary_Functions (Float_Type => Real);

      protected Control is
         procedure Random_Range (Min : in Real; Max : in Real; Result : out Real);
      end Control;

      protected body Control is
         procedure Random_Range (Min : in Real; Max : in Real; Result : out Real) is
            -- Empty
         begin -- Random_Range
            Result := Ranges.Random_Range (Random.Random, Min, Max);
         end Random_Range;
      end Control;

      function Random_Range (Min : Real; Max : Real) return Real is
         Result : Real;
      begin -- Random_Range
         Control.Random_Range (Min => Min, Max => Max, Result => Result);

         return Result;
      end Random_Range;

      -- Transfer: apply the node transfer function to a weighted summed input value
      --           Calculates node output & derivative
      procedure Transfer (Net_Input : in Real; Output : out Real; Deriv : out Real) is
         A : constant Real := Real_Math.Exp (Real'Min (Real'Max (0.5 * Net_Input, -Input_Lim), Input_Lim) );
         B : constant Real := 1.0 / A;
      begin -- Transfer
         Output := (A - B) / (A + B); -- Hyperbolic tangent (tanh)
         Deriv := 2.0 / ( (A + B) ** 2); -- Derivative of tanh
      end Transfer;

      -- New_Rm: Calculate the new value of a Recursive Mean
      function New_Rm (Length : Positive_Real; Old_Value : Real; New_Value : Real) return Real is
         -- Empty
      begin -- New_Rm
         return (1.0 - 1.0 / Length) * Old_Value + (1.0 / Length) * New_Value;
      end New_Rm;

      -- Update_values: Update the values related to a connection
      procedure Update_Values (Sender_Out   : in Real;
                               Receiver_Out : in Real;
                               E_Star       : in Real;
                               H_Star       : in Real;
                               Weight       : in out Weight_Group
                              )
      is
         Delta_W_Lim : constant := 100.0;
         Psi_Lim     : constant := 100.0;
         Denom_Lim   : constant := 1.0E-6;
         Weight_Lim  : constant := 100.0;

         Delta_W : Real;
         Psi     : Real;
         Denom   : Real;
      begin -- Update_Values
         -- Update numerator & denominator of delta W
         Weight.Deriv_Rm := New_Rm (Cycle_P, Weight.Deriv_Rm, (Sender_Out * H_Star) ** 2);
         Weight.Delta_W_Rm := New_Rm (Cycle_Q, Weight.Delta_W_Rm, (Beta / Cycle_P) * Sender_Out * E_Star);

         Delta_W := Real'Min (Real'Max (Weight.Delta_W_Rm / Weight.Deriv_Rm, - Delta_W_Lim), Delta_W_Lim);

         -- Determine if this connection needs to be inactivated or reactivated
         -- Thinning needs the current value of Weight.Weight, so do thinning calculations before applying Delta_W
         if Thinning_Active then
            Psi := Real'Min (Real'Max (2.0 * Sender_Out * Receiver_Out * Weight.Weight, -Psi_Lim), Psi_Lim);
            Denom := (2.0 * Sender_Out * Receiver_Out) ** 2;
            if Denom < Denom_Lim then
               Weight.G := New_Rm (Cycle_S,
                                   Weight.G,
                                   E_Star ** 2 + (Sender_Out * H_Star) ** 2 * 0.5 * Weight.Weight ** 2 *
                                   Real_Math.Exp (2.0 * Sender_Out * Receiver_Out * Weight.Weight) );
            else
               Weight.G := New_Rm (Cycle_S,
                                   Weight.G,
                                   E_Star ** 2 + (Sender_Out * H_Star) ** 2 *
                                   ( (1.0 - (1.0 + Psi) * Real_Math.Exp (-Psi)) / Denom) *
                                   Real_Math.Exp (2.0 * Sender_Out * Receiver_Out * Weight.Weight) );
            end if;

            if Weight.Active then
               Weight.Active := Weight.G > Ec;
            else
               Weight.Active := Weight.G > Ec + Delta_Ec;
            end if;
         end if;

         Weight.Weight := Real'Min (Real'Max (Weight.Weight + Delta_W, -Weight_Lim), Weight_Lim);
      end Update_Values;

      generic  -- ID_Generator
         Num_Tasks : Positive;
      package ID_Generator is
         function Next_ID return Positive;
      end ID_Generator;

      package body ID_Generator is
         Next : Positive := 1;

         function Next_ID return Positive is
            Result : constant Positive := Next;
         begin -- Next_ID
            if Next > Num_Tasks then
               raise Constraint_Error with "Too many tasks";
            end if;

            Next := Next + 1;

            return Result;
         end Next_ID;
      end ID_Generator;

      procedure Set_Weights (Weight : in Weight_Info) is
         -- Empty declarative part
      begin -- Set_Weights
         Set_I : for I in Weight.IH_Weight'Range(1) loop
            I_To_H : for H in Weight.IH_Weight'Range (2) loop
               Hidden.Set_Weight (Node => Hidden_Node (H), From => I, Weight => Weight.IH_Weight (I, H) );
            end loop I_To_H;

            if Input_To_Output_Connections then
               I_To_O : for O in Weight.IO_Weight'Range (2) loop
                  Output.Set_Input_Weight (Node => Output_Node (O), From => I, Weight => Weight.IO_Weight (I, O) );
               end loop I_To_O;
            end if;
         end loop Set_I;

         Set_H : for H in Weight.Hidden_Bias'Range loop
            Hidden.Set_Bias_Weight (Node => Hidden_Node (H), Weight => Weight.Hidden_Bias (H) );

            H_To_O : for O in Weight.HO_Weight'Range (2) loop
               Output.Set_Hidden_Weight (Node => Output_Node (O), From => H, Weight => Weight.HO_Weight (H, O) );
            end loop H_To_O;
         end loop Set_H;

         Set_O : for O in Weight.Output_Bias'Range loop
            Output.Set_Bias_Weight (Node => Output_Node (O), Weight => Weight.Output_Bias (O) );
         end loop Set_O;
      end Set_Weights;

      procedure Random_Weights (Max : in Positive_Real := 0.1) is
         Weight : constant Weight_Info :=
            (IH_Weight   => (others => (others => (Weight => Random_Range (-Max, Max), others => <>) ) ),
             IO_Weight   => (others => (others => (Weight => Random_Range (-Max, Max), others => <>) ) ),
             Hidden_Bias => (others => (Weight => Random_Range (-Max, Max), others => <>) ),
             HO_Weight   => (others => (others => (Weight => Random_Range (-Max, Max), others => <>) ) ),
             Output_Bias => (others => (Weight => Random_Range (-Max, Max), others => <>) ) );
      begin --Random_Weights
         Set_Weights (Weight => Weight);
      end Random_Weights;

      procedure Read (File_Name : in String; Weight : out Weight_Info) is
         File : Connection_IO.File_Type;
      begin -- Read
         Connection_IO.Open (File => File, Mode => Connection_IO.In_File, Name => File_Name);
         Connection_IO.Read (File => File, Item => Weight);
         Connection_IO.Close (File => File);
      end Read;

      procedure Read (File_Name : in String) is
         File   : Connection_IO.File_Type;
         Weight : Weight_Info;
      begin -- Read
         Connection_IO.Open (File => File, Mode => Connection_IO.In_File, Name => File_Name);
         Connection_IO.Read (File => File, Item => Weight);
         Connection_IO.Close (File => File);
         Set_Weights (Weight => Weight);
      end Read;

      procedure Prepare_For_Training is
         -- Empty
      begin -- Prepare_For_Training
         -- Pass each pattern through the network to obtain initial response (D zero)
         All_Patterns : for Pattern in Desired'Range loop
            Respond (Pattern => Pattern, Output => Desired (Pattern) );
         end loop All_Patterns;
      end Prepare_For_Training;

      procedure Get_Weights (Weight : out Weight_Info) is
         -- Empty
      begin -- Get_Weights
         Get_I : for I in Weight.IH_Weight'Range(1) loop
            I_To_H : for H in Weight.IH_Weight'Range (2) loop
               Weight.IH_Weight (I, H) := Hidden.Get_Weight (Node => Hidden_Node (H), From => I);
            end loop I_To_H;

            if Input_To_Output_Connections then
               I_To_O : for O in Weight.IO_Weight'Range (2) loop
                  Weight.IO_Weight (I, O) := Output.Get_Input_Weight (Node => Output_Node (O), From => I);
               end loop I_To_O;
            end if;
         end loop Get_I;

         Get_H : for H in Weight.Hidden_Bias'Range loop
            Weight.Hidden_Bias (H) := Hidden.Get_Bias_Weight (Node => Hidden_Node (H) );

            H_To_O : for O in Weight.HO_Weight'Range (2) loop
               Weight.HO_Weight (H, O) := Output.Get_Hidden_Weight (Node => Output_Node (O), From => H);
            end loop H_To_O;
         end loop Get_H;

         Get_O : for O in Weight.Output_Bias'Range loop
            Weight.Output_Bias (O) := Output.Get_Bias_Weight (Node => Output_Node (O) );
         end loop Get_O;
      end Get_Weights;

      procedure Write (File_Name : in String; Weight : in Weight_Info) is
         File : Connection_IO.File_Type;
      begin -- Write
         Connection_IO.Create (File => File, Name => File_Name);
         Connection_IO.Write (File => File, Item => Weight);
         Connection_IO.Close (File => File);
      end Write;

      procedure Write (File_Name : in String) is
         File   : Connection_IO.File_Type;
         Weight : Weight_Info;
      begin -- Write
         Get_Weights (Weight => Weight);
         Connection_IO.Create (File => File, Name => File_Name);
         Connection_IO.Write (File => File, Item => Weight);
         Connection_IO.Close (File => File);
      end Write;

      procedure Respond (Pattern : in Positive; Output : out Output_Set; Num_Tasks : in Positive := 1) is
         Input_Value : Node_Set (Input_ID);
      begin -- Respond
         Current_Pattern := Pattern;
         Get_Input (Pattern => Pattern, Input => Input_Value, Desired => Target);

         -- Get network response
         -- Send input to input nodes
         Input_Tasks : declare
            Tasks : constant Positive := Integer'Min (Num_Tasks, Input_ID'Last);

            package IDs is new ID_Generator (Num_Tasks => Tasks);

            task type Input_Agent (ID : Positive := IDs.Next_ID);

            task body Input_Agent is
               Start : constant Positive := (ID - 1) * (Input_ID'Last / Tasks) + 1;

               Stop : Positive := Start + Input_ID'Last / Tasks - 1;
            begin -- Input_Agent
               if ID = Tasks then
                  Stop := Input_ID'Last;
               end if;

               All_Input : for Node in Start .. Stop loop
                  Input.Set_Input (Node => Input_Node (Node), Value => Input_Value (Node) );
               end loop All_Input;
            end Input_Agent;

            type Agent_List is array (1 .. Tasks) of Input_Agent;

            Agent : Agent_List;
            pragma Unreferenced (Agent);
         begin -- Input_Tasks
            null;
         end Input_Tasks;

         -- For hidden nodes
         if Num_Hidden_Nodes > 0 then
            Hidden_Tasks : declare
               Tasks : constant Positive := Integer'Min (Num_Tasks, Hidden_ID'Last);

               package IDs is new ID_Generator (Num_Tasks => Tasks);

               task type Hidden_Agent (ID : Positive := IDs.Next_ID);

               task body Hidden_Agent is
                  Start : constant Positive := (ID - 1) * (Hidden_ID'Last / Tasks) + 1;

                  Stop  : Positive := Start + Hidden_ID'Last / Tasks - 1;
               begin -- Hidden_Agent
                  if ID = Tasks then
                     Stop := Hidden_ID'Last;
                  end if;

                  All_Hidden : for Node in Start .. Stop loop
                     Hidden.Respond (Node => Hidden_Node (Node) );
                  end loop All_Hidden;
               end Hidden_Agent;

               type Agent_List is array (1 .. Tasks) of Hidden_Agent;

               Agent : Agent_List;
               pragma Unreferenced (Agent);
            begin -- Hidden_Tasks
               null;
            end Hidden_Tasks;
         end if;

         -- For output nodes
         Output_Tasks : declare
            Tasks : constant Positive := Integer'Min (Num_Tasks, Output_ID'Last);

            package IDs is new ID_Generator (Num_Tasks => Tasks);

            task type Output_Agent (ID : Positive := IDs.Next_ID);

            task body Output_Agent is
               Start : constant Positive := (ID - 1) * (Output_ID'Last / Tasks) + 1;

               Stop  : Positive := Start + Output_ID'Last / Tasks - 1;
            begin -- Output_Agent
               if ID = Tasks then
                  Stop := Output_ID'Last;
               end if;

               All_Output : for Node in Start .. Stop loop
                  REM_NN.Output.Respond (Node => Output_Node (Node), Result => Output (Node) );
               end loop All_Output;
            end Output_Agent;

            type Agent_List is array (1 .. Tasks) of Output_Agent;

            Agent : Agent_List;
            pragma Unreferenced (Agent);
         begin -- Output_Tasks
            null;
         end Output_Tasks;
      end Respond;

      procedure Train (Num_Tasks : in Positive := 1) is
         -- Empty
      begin -- Train
         -- Update global "constants"
         Update_Count := Update_Count + 1;
         Cycle_P := Real'Max (P, Real (Update_Count) * K_P);
         Cycle_Q := Real'Max (Q, Real (Update_Count) * K_Q);
         Cycle_S := Real'Max (S, Real (Update_Count) * K_S);

         Output_Tasks : declare
            Tasks : constant Positive := Integer'Min (Num_Tasks, Output_ID'Last);

            package IDs is new ID_Generator (Num_Tasks => Tasks);

            task type Output_Agent (ID : Positive := IDs.Next_ID);

            task body Output_Agent is
               Start : constant Positive := (ID - 1) * (Output_ID'Last / Tasks) + 1;

               Stop  : Positive := Start + Output_ID'Last / Tasks - 1;
            begin -- Output_Agent
               if ID = Tasks then
                  Stop := Output_ID'Last;
               end if;

               All_Outputs : for Node in Start .. Stop loop
                  Desired (Current_Pattern) (Node) := New_Rm (R, Desired (Current_Pattern) (Node), Target (Node) );
                  Output.Train (Node => Output_Node (Node), ID => Node);
               end loop All_Outputs;
            end Output_Agent;

            type Agent_List is array (1 .. Tasks) of Output_Agent;

            Agent : Agent_List;
            pragma Unreferenced (Agent);
         begin -- Output_Tasks
            null;
         end Output_Tasks;

         if Num_Hidden_Nodes > 0 then
            Hidden_Tasks : declare
               Tasks : constant Positive := Integer'Min (Num_Tasks, Hidden_ID'Last);

               package IDs is new ID_Generator (Num_Tasks => Tasks);

               task type Hidden_Agent (ID : Positive := IDs.Next_ID);

               task body Hidden_Agent is
                  Start : constant Positive := (ID - 1) * (Hidden_ID'Last / Tasks) + 1;

                  Stop  : Positive := Start + Hidden_ID'Last / Tasks - 1;
               begin -- Hidden_Agent
                  if ID = Tasks then
                     Stop := Hidden_ID'Last;
                  end if;

                  All_Hidden : for Node in Start .. Stop loop
                     Hidden.Train (Node => Hidden_Node (Node), ID => Node);
                  end loop All_Hidden;
               end Hidden_Agent;

               type Agent_List is array (1 .. Tasks) of Hidden_Agent;

               Agent : Agent_List;
               pragma Unreferenced (Agent);
            begin -- Hidden_Tasks
               null;
            end Hidden_Tasks;
         end if;
      end Train;

      package body Input is
         procedure Set_Input (Node : in out Node_Handle; Value : in Real) is
            -- Empty
         begin -- Set_Input
            Node.Output := Value;
         end Set_Input;

         function Get_Output (From : Node_Handle) return Real is
            -- Empty
         begin -- Get_Output
            return From.Output;
         end Get_Output;
      end Input;

      package body Hidden is
         procedure Respond (Node : in out Node_Handle) is
            Net_Input : Real := 0.0;
         begin -- respond
            if Node.Bias.Active then
               Net_Input := Node.Bias.Weight;
            end if;

            Sum_Input : for I_ID in Input_ID loop
               if Node.Weight (I_ID).Active then
                  Net_Input := Net_Input + Input.Get_Output (Input_Node (I_ID) ) * Node.Weight (I_ID).Weight;
               end if;
            end loop Sum_Input;

            Transfer (Net_Input => Net_Input, Output => Node.Output, Deriv => Node.Deriv);
         end Respond;

         function Get_Output (From : Node_Handle) return Real is
            -- Empty
         begin -- Get_Output
            return From.Output;
         end Get_Output;

         procedure Train (Node : in out Node_Handle; ID : in Hidden_ID) is
            Star : Star_Group;
            Prop : Star_Group;
            In_Use : Boolean := False;
         begin -- Train
            -- Sum propagated E* & H* from output nodes
            Sum_Stars : for O_ID in Output_ID loop
               Prop := Output.Get_Stars (Output_Node (O_ID), ID);
               Star := Star_Group'(E_Star => Star.E_Star + Prop.E_Star,
                                   H_Star => Star.H_Star + Prop.H_Star);
            end loop Sum_Stars;

            Star.E_Star := Node.Deriv * Star.E_Star;
            Star.H_Star := Real'Min (Real'Max (Node.Deriv * Star.H_Star, -H_Star_Lim), H_Star_Lim);

            -- Update connections to this node
            Modify : for I_ID in Input_ID loop
               Update_Values (Sender_Out => Input.Get_Output (Input_Node (I_ID) ),
                              Receiver_Out => Node.Output,
                              E_Star => Star.E_Star,
                              H_Star => Star.H_Star,
                              Weight => Node.Weight (I_ID) );
            end loop Modify;

            Update_Values (Sender_Out => 1.0, -- Update bias
                           Receiver_Out => Node.Output,
                           E_Star => Star.E_Star,
                           H_Star => Star.H_Star,
                           Weight => Node.Bias);

            -- Check for inactivity
            Check : for I_ID in Input_ID loop
               In_Use := In_Use or Node.Weight (I_ID).Active;
            end loop Check;

            if not In_Use then -- No active input connections, so turn off bias
               Node.Bias.Active := False;
            end if;
         end Train;

         procedure Set_Weight (Node : in out Node_Handle; From : in Input_ID; Weight : in Weight_Group) is
            -- Empty
         begin -- Set_Weight
            Node.Weight (From) := Weight;
         end Set_Weight;

         function Get_Weight (Node : Node_Handle; From : Input_ID) return Weight_Group is
            -- Empty
         begin -- Get_Weight
            return Node.Weight (From);
         end Get_Weight;

         procedure Set_Bias_Weight (Node : in out Node_Handle; Weight : in Weight_Group) is
            -- Empty
         begin -- Set_Bias_Weight
            Node.Bias := Weight;
         end Set_Bias_Weight;

         function Get_Bias_Weight (Node : Node_Handle) return Weight_Group is
            -- Empty
         begin -- Get_Bias_Weight
            return Node.Bias;
         end Get_Bias_Weight;
      end Hidden;

      package body Output is
         procedure Respond (Node : in out Node_Handle; Result : out Real) is
            Net_Input : Real := 0.0;
         begin -- Respond
            if Node.Bias.Active then
               Net_Input := Node.Bias.Weight;
            end if;

            if Node.Input_To_Output then
               Sum_Input : for I_ID in Input_ID loop
                  if Node.Input_Weight (I_ID).Active then
                     Net_Input := Net_Input + Input.Get_Output (Input_Node (I_ID) ) * Node.Input_Weight (I_ID).Weight;
                  end if;
               end loop Sum_Input;
            end if;

            Sum_Hidden : for H_ID in Hidden_ID loop
               if Node.Hidden_Weight (H_ID).Active then
                  Net_Input := Net_Input + Hidden.Get_Output (Hidden_Node (H_ID) ) * Node.Hidden_Weight (H_ID).Weight;
               end if;
            end loop Sum_Hidden;

            Transfer (Net_Input => Net_Input, Output => Node.Output, Deriv => Node.Deriv);

            Result := Node.Output;
         end Respond;

         procedure Train (Node : in out Node_Handle; ID : in Output_ID) is
            Star : Star_Group;
         begin -- Train
            -- Calculate E* & H* for this node
            Star.H_Star := Real'Min (Real'Max (Node.Deriv, -H_Star_Lim), H_Star_Lim);
            Star.E_Star := Star.H_Star * (Desired (Current_Pattern) (ID) - Node.Output +
                                          Random_Range (-Random_E_Star_Range, Random_E_Star_Range) );
            Star.H_Star := Star.H_Star + Random_Range (-Random_H_Star_Range, Random_H_Star_Range);

            -- E* & H* have to be propagated back before the weights are updated
            -- This is done by multiplying them by the corresponding weights, & storing the result in Node.Hidden_Star
            -- The values in Node.Hidden_Star are then returned in response to calls to Get_Star
            Adjust_Stars : for H_ID in Hidden_ID loop
               if not Node.Hidden_Weight (H_ID).Active then
                  Node.Hidden_Star (H_ID) := Star_Group'(E_Star => 0.0, H_Star => 0.0);
               else
                  Node.Hidden_Star (H_ID) := Star_Group'(E_Star => Node.Hidden_Weight (H_ID).Weight * Star.E_Star,
                                                         H_Star => Node.Hidden_Weight (H_ID).Weight * Star.H_Star);
               end if;
            end loop Adjust_Stars;

            -- Update all connections to this node
            if Node.Input_To_Output then
               Update_Input : for I_ID in Input_ID loop
                  Update_Values (Sender_Out => Input.Get_Output (Input_Node (I_ID) ),
                                 Receiver_Out => Node.Output,
                                 E_Star => Star.E_Star,
                                 H_Star => Star.H_Star,
                                 Weight => Node.Input_Weight (I_ID) );
               end loop Update_Input;
            end if;

            Update_Hidden : for H_ID in Hidden_ID loop
               Update_Values (Sender_Out => Hidden.Get_Output (Hidden_Node (H_ID) ),
                              Receiver_Out => Node.Output,
                              E_Star => Star.E_Star,
                              H_Star => Star.H_Star,
                              Weight => Node.Hidden_Weight (H_ID) );
            end loop Update_Hidden;

            Update_Values (Sender_Out => 1.0, -- Update bias value
                           Receiver_Out => Node.Output,
                           E_Star => Star.E_Star,
                           H_Star => Star.H_Star,
                           Weight => Node.Bias);
         end Train;

         function Get_Stars (Node : Node_Handle; From : Hidden_ID) return Star_Group is
            -- Empty
         begin -- Get_Stars
            return Node.Hidden_Star (From);
         end Get_Stars;

         procedure Set_Input_Weight (Node : in out Node_Handle; From : in Input_ID; Weight : in Weight_Group) is
            -- Empty
         begin -- Set_Input_Weight
            Node.Input_Weight (From) := Weight;
         end Set_Input_Weight;

         function Get_Input_Weight (Node : Node_Handle; From : Input_ID) return Weight_Group is
            -- Empty
         begin -- Get_Input_Weight
            return Node.Input_Weight (From);
         end Get_Input_Weight;

         procedure Set_Hidden_Weight (Node : in out Node_Handle; From : in Hidden_ID; Weight : in Weight_Group) is
            -- Empty
         begin -- Set_Hidden_Weight
            Node.Hidden_Weight (From) := Weight;
         end Set_Hidden_Weight;

         function Get_Hidden_Weight (Node : Node_Handle; From : Hidden_ID) return Weight_Group is
            -- Empty
         begin -- Get_Hidden_Weight
            return Node.Hidden_Weight (From);
         end Get_Hidden_Weight;

         procedure Set_Bias_Weight (Node : in out Node_Handle; Weight : in Weight_Group) is
            -- Empty
         begin -- Set_Bias_Weight
            Node.Bias := Weight;
         end Set_Bias_Weight;

         function Get_Bias_Weight (Node : Node_Handle) return Weight_Group is
            -- Empty
         begin -- Get_Bias_Weight
            return Node.Bias;
         end Get_Bias_Weight;
      end Output;

      procedure Finalize (Object : in out Finalizer) is
         pragma Unreferenced (Object);

         procedure Free is new Ada.Unchecked_Deallocation (Object => Input_Node_Set,  Name => Input_Set_Ptr);
         procedure Free is new Ada.Unchecked_Deallocation (Object => Hidden_Node_Set, Name => Hidden_Set_Ptr);
         procedure Free is new Ada.Unchecked_Deallocation (Object => OutPut_Node_Set, Name => OutPut_Set_Ptr);
      begin -- Finalize
         Free (Input_Node_Ptr);
         Free (Hidden_Node_Ptr);
         Free (OutPut_Node_Ptr);
      end Finalize;
   begin -- REM_NN
      if Num_Hidden_Nodes <= 0 and then not Input_To_Output_Connections then
         raise Invalid_Architecture;
      end if;

      Random.Randomize;
   end REM_NN;
end PragmARC.REM_NN_Wrapper;
--
-- This 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 2, or (at your option) any later version.
-- This software is distributed in the hope that it will be useful, but WITH
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-- for more details. Free Software Foundation, 59 Temple Place - Suite
-- 330, Boston, MA 02111-1307, USA.
--
-- As a special exception, if other files instantiate generics from this
-- unit, or you link this unit with other files to produce an executable,
-- this unit does not by itself cause the resulting executable to be
-- covered by the GNU General Public License. This exception does not
-- however invalidate any other reasons why the executable file might be
-- covered by the GNU Public License.