⟦e57ace238⟧

TextFile

with Element;
with Lex;
with Queue_Generic;
with Station_Identifier;
with Symbol_Table;
with Text_Io;
with Trame_Product;
with Token;
use Token;

package body Abstract_Tree is

    Max_Character : constant Natural := 80;
    subtype My_String is String (1 .. Max_Character);

    type P_String is access String;

    package List is new Queue_Generic (Element => P_Node);

    package Current_Time is

        procedure Initialize;
        procedure Add (Value : Natural);
        procedure Sub (Value : Natural);
        function Get return Natural;
        procedure Set (Value : Natural);

    end Current_Time;

    type Instruction_List is
        record
            The_List : List.Queue;
            The_Iterator : List.Iterator;
        end record;

    type T_Begin is
        record
            The_Token : Token.Object;
            A_List : P_Instruction_List;
        end record;

    type T_Repeat is
        record
            The_Token : Token.Object;
            Left : P_Node;
            Right : P_Instruction_List;
        end record;

    type Wait is
        record
            The_Token : Token.Object;
            The_Id : P_Node;
        end record;

    type Expression is
        record
            The_Token : Token.Object;
            Left : P_Node;
            Right : P_Node;
            The_Value : Integer;
        end record;

    type Action is
        record
            The_Token : Token.Object;
            Left : P_Node;
            Right : P_Node;
        end record;

    type T_While is
        record
            The_Token : Token.Object;
            First_Condition : P_Node;
            Relation : P_Node;
            Second_Condition : P_Node;
            A_List : P_Instruction_List;
        end record;

    type Change is
        record
            The_Token : Token.Object;
            The_Class : P_Node;
            The_Actor : P_Node;
            Value : P_Node;
        end record;

    type Evolution is
        record
            The_Token : Token.Object;
            The_Class : P_Node;
            The_Actor : P_Node;
            First_Value : P_Node;
            Second_Value : P_Node;
        end record;

    type Block_Time is
        record
            The_Token : Token.Object;
            The_Time : P_Node;
            The_List : P_Instruction_List;
            The_Next_List : P_Instruction_List;
        end record;

    type Next is new T_Begin;
    type Call_Scene is new Wait;
    type Call_Effect is new T_Repeat;

    type Node (A_Kind_Node : Kind_Node) is
        record
            case A_Kind_Node is
                when Debut =>
                    Node_Begin : T_Begin;
                when Repeter =>
                    Node_Repeat : T_Repeat;
                when Dans =>
                    Node_Block_Time : Block_Time;
                when Lancereffet =>
                    Node_Call_Effect : Call_Effect;
                when Attendre =>
                    Node_Wait : Wait;
                when Lancerscene =>
                    Node_Call_Scene : Call_Scene;
                when Tant_Que =>
                    Node_While : T_While;
                when Plus | Moins | Mult | Div | Affect =>
                    Node_Expression : Expression;
                when Activer | Desact =>
                    Node_Action : Action;
                when Changer =>
                    Node_Change : Change;
                when Evoluer =>
                    Node_Evolution : Evolution;
                when Id =>
                    The_Name : My_String;
                when Nbr =>
                    The_Value : Natural;
                when Inf | Sup | Egal | Pas_Egal | Inf_Ou_Egal | Sup_Ou_Egal =>
                    The_Token : Token.Object;
                when Empty =>
                    null;
            end case;
        end record;

    package body Current_Time is separate;

    function Normaliser (S : String; Length : Natural) return String is
    begin
        if S'Length >= Length then
            return S (S'First .. S'First + Length - 1);
        else
            return S & (1 .. Length - S'Length => ' ');
        end if;
    end Normaliser;


    function Make_Node (A_Token : Token.Object; The_Left, The_Right : in P_Node)
                       return P_Node is
        The_Expression : Expression;
        The_Action : Action;
    begin
        case A_Token is
            when L_Plus | L_Moins | L_Div | L_Mult | L_Affect =>
                The_Expression.The_Token := A_Token;
                The_Expression.Left := The_Left;
                The_Expression.Right := The_Right;
                return new Node'(A_Kind_Node => Plus,
                                 Node_Expression => The_Expression);
            when L_Activer | L_Desact =>
                The_Action.The_Token := A_Token;
                The_Action.Left := The_Left;
                The_Action.Right := The_Right;
                return new Node'(A_Kind_Node => Activer,
                                 Node_Action => The_Action);
            when others =>
                raise Bad_Token;
        end case;
    end Make_Node;


    function Make_Node (A_Token : Token.Object;
                        The_Left : in P_Node;
                        The_Right : in P_Instruction_List) return P_Node is
        The_Repeat : T_Repeat;
        The_Call_Effect : Call_Effect;
    begin
        case A_Token is
            when L_Repeter =>
                The_Repeat.The_Token := A_Token;
                The_Repeat.Left := The_Left;
                The_Repeat.Right := The_Right;
                return new Node'(Repeter, Node_Repeat => The_Repeat);
            when L_Appel_Effet =>
                The_Call_Effect.The_Token := A_Token;
                The_Call_Effect.Left := The_Left;
                The_Call_Effect.Right := The_Right;
                return new Node'(Lancereffet,
                                 Node_Call_Effect => The_Call_Effect);
            when others =>
                raise Unexist_Node;
        end case;
    end Make_Node;


    function Make_Node
                (A_Token : Token.Object; The_Time : in P_Node) return P_Node is
        The_Wait : Wait;
        The_Call_Scene : Call_Scene;
    begin
        case A_Token is
            when L_Attendre =>
                The_Wait.The_Token := A_Token;
                The_Wait.The_Id := The_Time;
                return new Node'(Attendre, Node_Wait => The_Wait);
            when L_Lancer_Scene =>
                The_Call_Scene.The_Token := A_Token;
                The_Call_Scene.The_Id := The_Time;
                return new Node'(Lancerscene,
                                 Node_Call_Scene => The_Call_Scene);
            when others =>
                raise Bad_Token;
        end case;
    end Make_Node;


    function Make_Node
                (A_Token : Token.Object; The_List : in P_Instruction_List)
                return P_Node is
        The_Begin : T_Begin;
    begin
        if A_Token /= L_Debut then
            raise Bad_Token;
        end if;
        The_Begin.The_Token := A_Token;
        The_Begin.A_List := The_List;
        return new Node'(Debut, Node_Begin => The_Begin);
    end Make_Node;


    function Make_Node (A_Token : Token.Object;
                        First_Term, The_Relation, Second_Term : in P_Node;
                        The_List : in P_Instruction_List) return P_Node is
        The_While : T_While;
    begin
        if A_Token /= L_Tantque then
            raise Bad_Token;
        end if;
        The_While.The_Token := A_Token;
        The_While.First_Condition := First_Term;
        The_While.Relation := The_Relation;
        The_While.Second_Condition := Second_Term;
        The_While.A_List := The_List;
        return new Node'(Tant_Que, Node_While => The_While);
    end Make_Node;


    function Make_Node
                (A_Token : Token.Object;
                 The_Class, The_Actor, The_Value : in P_Node) return P_Node is
        The_Change : Change;
    begin
        if A_Token /= L_Changer then
            raise Bad_Token;
        end if;
        The_Change.The_Token := A_Token;
        The_Change.The_Class := The_Class;
        The_Change.The_Actor := The_Actor;
        The_Change.Value := The_Value;
        return new Node'(Changer, Node_Change => The_Change);
    end Make_Node;


    function Make_Node
                (A_Token : Token.Object;
                 The_Class, The_Actor, Initial_Value, Final_Value : in P_Node)
                return P_Node is
        The_Evolution : Evolution;
    begin
        if A_Token /= L_Evoluer then
            raise Bad_Token;
        end if;
        The_Evolution.The_Token := A_Token;
        The_Evolution.The_Class := The_Class;
        The_Evolution.The_Actor := The_Actor;
        The_Evolution.First_Value := Initial_Value;
        The_Evolution.Second_Value := Final_Value;
        return new Node'(Evoluer, Node_Evolution => The_Evolution);
    end Make_Node;


    function Make_Node
                (A_Token : Token.Object;
                 The_Time : P_Node;
                 First_List, Second_List : P_Instruction_List) return P_Node is
        The_Block_Time : Block_Time;
    begin
        if A_Token /= L_Dans then
            raise Bad_Token;
        end if;
        The_Block_Time.The_Token := A_Token;
        The_Block_Time.The_Time := The_Time;
        The_Block_Time.The_List := First_List;
        The_Block_Time.The_Next_List := Second_List;
        return new Node'(Dans, Node_Block_Time => The_Block_Time);
    end Make_Node;


    function Empty_Node return P_Node is
    begin
        return new Node (Empty);
    end Empty_Node;


    function Make_Foliage
                (A_Token : Token.Object; A_Name : String) return P_Node is
    begin
        if A_Token = L_Id then
            return new Node'(Id,
                             The_Name => Normaliser (A_Name, Max_Character));
        else
            raise Bad_Token;
        end if;
    end Make_Foliage;


    function Make_Foliage
                (A_Token : Token.Object; Value : Natural) return P_Node is
    begin
        if A_Token = L_Nbr then
            return new Node'(Nbr, The_Value => Value);
        else
            raise Bad_Token;
        end if;
    end Make_Foliage;


    function Make_Foliage (A_Token : Token.Object) return P_Node is
    begin
        case A_Token is
            when L_Inf | L_Sup | L_Egal | L_Pas_Egal |
                 L_Sup_Ou_Egal | L_Inf_Ou_Egal =>
                return new Node'(Inf, The_Token => A_Token);
            when others =>
                raise Bad_Token;
        end case;
    end Make_Foliage;


    procedure Create_List (My_List : out P_Instruction_List) is
        Tmp_List : P_Instruction_List;
    begin
        Tmp_List := new Instruction_List;
        List.Initialize (Tmp_List.The_List);
        My_List := Tmp_List;
    end Create_List;


    procedure Next_List (My_List : in out P_Instruction_List) is
    begin
        List.Next (List.Iterator (My_List.The_Iterator));
    end Next_List;


    procedure Init (My_List : in out P_Instruction_List) is
    begin
        List.Init (My_List.The_Iterator, My_List.The_List);
    end Init;


    procedure Add_The_List
                 (My_List : in out P_Instruction_List; A_Node : in P_Node) is
    begin
        if List.Is_Empty (My_List.The_List) then
            List.Add (My_List.The_List, A_Node);
            Init (My_List);
        else
            List.Add (My_List.The_List, A_Node);
        end if;
    end Add_The_List;


    function Value (My_List : in P_Instruction_List) return P_Node is
    begin
        return List.Value (My_List.The_Iterator);
    end Value;


    function Is_Done (My_List : P_Instruction_List) return Boolean is
    begin
        return List.Done (My_List.The_Iterator);
    end Is_Done;


    procedure Test_Kind_Node (A_Node : P_Node; The_Value : out Integer) is
        Ok : Boolean;
    begin
        if A_Node.A_Kind_Node = Nbr then
            The_Value := A_Node.The_Value;
        else
            if A_Node.A_Kind_Node = Id then
                Symbol_Table.Get_Val (A_Node.The_Name, The_Value, Ok);
            else
                The_Value := A_Node.Node_Expression.The_Value;
            end if;
        end if;
    end Test_Kind_Node;


    procedure Execute_Expression (A_Node : in out P_Node) is
        Left_Value : Integer;
        Right_Value : Integer;
        Ok : Boolean;
    begin
        if A_Node.A_Kind_Node = Plus then
            Execute_Expression (A_Node.Node_Expression.Left);
            Execute_Expression (A_Node.Node_Expression.Right);
            Test_Kind_Node (A_Node.Node_Expression.Left, Left_Value);
            Test_Kind_Node (A_Node.Node_Expression.Right, Right_Value);
            case A_Node.Node_Expression.The_Token is
                when L_Plus =>
                    A_Node.Node_Expression.The_Value :=
                       Left_Value + Right_Value;
                when L_Moins =>
                    A_Node.Node_Expression.The_Value :=
                       Left_Value - Right_Value;
                    if A_Node.Node_Expression.The_Value < 0 then
                        raise Negative_Value;
                    end if;
                when L_Mult =>
                    A_Node.Node_Expression.The_Value :=
                       Left_Value * Right_Value;
                when L_Div =>
                    A_Node.Node_Expression.The_Value :=
                       Left_Value / Right_Value;
                when L_Affect =>
                    Symbol_Table.Set_Val
                       (A_Node.Node_Expression.Left.The_Name, Right_Value, Ok);
                    A_Node.Node_Expression.The_Value := Right_Value;
                when others =>
                    raise Unexist_Node;
            end case;
        end if;
    end Execute_Expression;


    function Get_Value_Node (A_Node : P_Node) return Integer is
        Value : Integer;
        Ok : Boolean;
        Other_Node : P_Node;
    begin
        case A_Node.A_Kind_Node is
            when Id =>
                Symbol_Table.Get_Val (A_Node.The_Name, Value, Ok);
            when Nbr =>
                Value := A_Node.The_Value;
            when Plus =>
                Other_Node := A_Node;
                Execute_Expression (Other_Node);
                Value := Other_Node.Node_Expression.The_Value;
            when others =>
                Text_Io.Put_Line ("Error : " &
                                  Kind_Node'Image (A_Node.A_Kind_Node));
                raise Unexist_Node;
        end case;
        return Value;
    end Get_Value_Node;


    procedure Execute_Action (A_Node : P_Node) is
        The_Num_Station : Station_Identifier.Object;
        The_Adress : Element.Adress;
        The_Time : Natural;
        The_Actor : Element.Num_Acteur;
        The_Class : Element.Class;
        Success : Boolean;
    begin
        Symbol_Table.Get_Num_Station
           (A_Node.Node_Action.Left.The_Name, The_Num_Station, Success);
        Symbol_Table.Get_Adress
           (A_Node.Node_Action.Left.The_Name, The_Adress, Success);
        Symbol_Table.Get_Class
           (A_Node.Node_Action.Left.The_Name, The_Class, Success);

        Symbol_Table.Change_Current_Table (The_Class, Success);
        Symbol_Table.Get_Num_Acteur
           (A_Node.Node_Action.Right.The_Name, The_Actor, Success);
        Symbol_Table.Leave_Table (Success);
        The_Time := Current_Time.Get;

        case A_Node.Node_Action.The_Token is
            when L_Activer =>
                Trame_Product.Write_Activate
                   (The_Num_Station, The_Adress, The_Time, The_Actor);
            when L_Desact =>
                Trame_Product.Write_Desactivate
                   (The_Num_Station, The_Adress, The_Time, The_Actor);
            when others =>
                raise Unexist_Node;
        end case;
    end Execute_Action;


    procedure Execute_Repeat (A_Node : P_Node) is
        Ok : Boolean;
        Value : Integer;
    begin
        Value := Get_Value_Node (A_Node.Node_Repeat.Left);
        if Value /= 0 then
            for I in 1 .. Value loop
                Init (A_Node.Node_Repeat.Right);
                Execute_Code (A_Node.Node_Repeat.Right);
            end loop;
        end if;
    end Execute_Repeat;


    procedure Execute_Block_Time (A_Node : P_Node) is
        Value : Integer;
        Ok : Boolean;
    begin
        Value := Get_Value_Node (A_Node.Node_Block_Time.The_Time);
        Current_Time.Add (Natural (Value));
        Init (A_Node.Node_Block_Time.The_List);
        Execute_Code (A_Node.Node_Block_Time.The_List);
        Init (A_Node.Node_Block_Time.The_Next_List);
        Execute_Code (A_Node.Node_Block_Time.The_Next_List);
        Current_Time.Sub (Natural (Value));
    end Execute_Block_Time;


    procedure Execute_Call_Effect (A_Node : P_Node) is
    begin
        Text_Io.Put_Line ("Execution de appel_effet non implemente");
    end Execute_Call_Effect;


    procedure Execute_Wait (A_Node : P_Node) is
        Ok : Boolean;
        Value : Integer;
    begin
        Value := Get_Value_Node (A_Node.Node_Wait.The_Id);
        Current_Time.Add (Natural (Value));
    end Execute_Wait;


    procedure Execute_Call_Scene (A_Node : P_Node) is
        The_List : P_Instruction_List;
        Ok : Boolean;
        Initial_Value : Natural;
    begin  
        Initial_Value := Current_Time.Get;
        Symbol_Table.Get_Instr_List
           (A_Node.Node_Call_Scene.The_Id.The_Name, The_List, Ok);
        Symbol_Table.Change_Current_Table
           (A_Node.Node_Call_Scene.The_Id.The_Name, Ok);
        Init (The_List);
        Execute_Code (The_List);
        Symbol_Table.Leave_Table (Ok);
        Current_Time.Set (Initial_Value);  
    end Execute_Call_Scene;


    procedure Execute_While (A_Node : P_Node) is
        First_Value, Second_Value : Integer;
    begin
        loop
            First_Value := Get_Value_Node (A_Node.Node_While.First_Condition);
            Second_Value := Get_Value_Node (A_Node.Node_While.Second_Condition);
            Init (A_Node.Node_While.A_List);
            if A_Node.Node_While.Relation.A_Kind_Node = Inf then
                case A_Node.Node_While.Relation.The_Token is
                    when L_Inf =>
                        if First_Value < Second_Value then
                            Execute_Code (A_Node.Node_While.A_List);
                        else
                            exit;
                        end if;
                    when L_Sup =>
                        if First_Value > Second_Value then
                            Execute_Code (A_Node.Node_While.A_List);
                        else
                            exit;
                        end if;
                    when L_Egal =>
                        if First_Value = Second_Value then
                            Execute_Code (A_Node.Node_While.A_List);
                        else
                            exit;
                        end if;
                    when L_Sup_Ou_Egal =>
                        if First_Value >= Second_Value then
                            Execute_Code (A_Node.Node_While.A_List);
                        else
                            exit;
                        end if;
                    when L_Inf_Ou_Egal =>
                        if First_Value <= Second_Value then
                            Execute_Code (A_Node.Node_While.A_List);
                        else
                            exit;
                        end if;
                    when others =>
                        raise Bad_Token;
                end case;
            else
                raise Unexist_Node;
            end if;
        end loop;
    end Execute_While;


    procedure Execute_Change (A_Node : P_Node) is
        The_Num_Station : Station_Identifier.Object;
        The_Adress : Element.Adress;
        The_Time : Natural;
        The_Actor : Element.Num_Acteur;
        The_Value : Natural;
        The_Class : Element.Class;
        Success : Boolean;
    begin
        Symbol_Table.Get_Num_Station
           (A_Node.Node_Change.The_Class.The_Name, The_Num_Station, Success);
        Symbol_Table.Get_Adress
           (A_Node.Node_Change.The_Class.The_Name, The_Adress, Success);
        Symbol_Table.Get_Class
           (A_Node.Node_Change.The_Class.The_Name, The_Class, Success);

        Symbol_Table.Change_Current_Table (The_Class, Success);
        Symbol_Table.Get_Num_Acteur
           (A_Node.Node_Change.The_Actor.The_Name, The_Actor, Success);
        Symbol_Table.Leave_Table (Success);  
        The_Time := Current_Time.Get;
        The_Value := A_Node.Node_Change.Value.The_Value;
        Trame_Product.Write_Change (The_Num_Station, The_Adress,
                                    The_Time, The_Actor, The_Value);
    end Execute_Change;


    procedure Execute_Evolution (A_Node : P_Node) is
        The_Num_Station : Station_Identifier.Object;
        The_Adress : Element.Adress;
        The_Time : Natural;
        The_Actor : Element.Num_Acteur;
        The_Value1, The_Value2 : Natural;
        The_Class : Element.Class;
        Success : Boolean;
    begin
        Symbol_Table.Get_Num_Station
           (A_Node.Node_Evolution.The_Class.The_Name, The_Num_Station, Success);
        Symbol_Table.Get_Adress
           (A_Node.Node_Evolution.The_Class.The_Name, The_Adress, Success);
        Symbol_Table.Get_Class
           (A_Node.Node_Evolution.The_Class.The_Name, The_Class, Success);
        Symbol_Table.Change_Current_Table (The_Class, Success);
        Symbol_Table.Get_Num_Acteur
           (A_Node.Node_Evolution.The_Actor.The_Name, The_Actor, Success);
        Symbol_Table.Leave_Table (Success);  
        The_Time := Current_Time.Get;
        The_Value1 := A_Node.Node_Evolution.First_Value.The_Value;
        The_Value2 := A_Node.Node_Evolution.Second_Value.The_Value;
        Trame_Product.Write_Evoluate (The_Num_Station, The_Adress, The_Time,
                                      The_Actor, The_Value1, The_Value2);
    end Execute_Evolution;


    procedure Execute_Code (The_Instruction_List : in out P_Instruction_List) is
        A_Node : P_Node;
        Initial_Value : Natural;
    begin
        while not Is_Done (The_Instruction_List) loop
            A_Node := Value (The_Instruction_List);
            case A_Node.A_Kind_Node is
                when Debut =>
                    Init (A_Node.Node_Begin.A_List);
                    Initial_Value := Current_Time.Get;
                    Execute_Code (A_Node.Node_Begin.A_List);
                    Current_Time.Set (Initial_Value);
                when Dans =>
                    Execute_Block_Time (A_Node);
                when Repeter =>
                    Execute_Repeat (A_Node);
                when Lancereffet =>
                    Execute_Call_Effect (A_Node);
                when Attendre =>
                    Execute_Wait (A_Node);
                when Lancerscene =>
                    Execute_Call_Scene (A_Node);
                when Tant_Que =>
                    Execute_While (A_Node);
                when Plus | Moins | Mult | Div | Affect =>
                    Execute_Expression (A_Node);
                when Activer | Desact =>
                    Execute_Action (A_Node);
                when Changer =>
                    Execute_Change (A_Node);
                when Evoluer =>
                    Execute_Evolution (A_Node);
                when Id | Nbr | Inf | Sup | Egal | Pas_Egal |
                     Inf_Ou_Egal | Sup_Ou_Egal | Empty =>
                    raise Unexist_Node;
            end case;
            Next_List (The_Instruction_List);
        end loop;
    end Execute_Code;


end Abstract_Tree;
DataMuseum.dk

Rational R1000/400 Tapes

⟦e57ace238⟧ TextFile

Derivation

TextFile
