|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 76369 (0x12a51) Types: TextFile Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦5a81ac88f⟧ »Space Info Vol 1« └─⟦2879e02b7⟧ └─⟦this⟧
with Text_Io,Lexical,Nom_Jeu,Les_Actions,Les_Definitions,Les_Presentations; with Les_Liaisons,Les_Anims_Globales,Les_Anims_Locales,Fin_Jeu,Erreur; with Verbs_Dictionary; use Text_Io; procedure Main2 is Nomf : constant String := "Ex_Jeu"; Dict : Verbs_Dictionary.Object; begin Lexical.Init( Nomf ); Lexical.Next; Nom_jeu.Parse; Verbs_Dictionary.Create(Dict); Les_Actions.Parse(dict); Verbs_Dictionary.Dump(Dict); Les_Definitions.Parse; Les_Presentations.Parse; Les_Liaisons.Parse; Les_Anims_Globales.Parse; Les_Anims_Locales.Parse; Fin_Jeu.Parse; if Not Erreur.Is_Any then Text_Io.Put("Ok"); else Text_Io.Put("pas Ok"); end if; Lexical.Close; Exception when Erreur.Erreur_Syntaxe => Text_Io.Put_Line (" -- Erreur Fatale"); Text_Io.Put_Line ("Bye, bye..."); Verbs_Dictionary.Destroy(dict); when Verbs_Dictionary.Duplicate_Value => Text_Io.Put("Lg:"); Text_Io.Put(Natural'Image(Lexical.Get_Line)); Text_Io.Put(" Cl:"); Text_Io.Put(Natural'Image(Lexical.Get_Column)); -- when others => Text_Io.Put_Line ("Erreur inconnue"); end Main2; With Lexical,Token_List,Verbs_Dictionary,Erreur,Synonymes,Text_Io; Use Lexical,Token_List; Package body Actions is Action_First:Token_List.Object := Make(Id); Procedure Action (dict:Verbs_Dictionary.Object) is Begin if Lexical.Get_Token = Id then -- if Verbs_Dictionary.Exist(Lexical.Get_Value,dict) then -- Erreur.Parse("Verbe deja existant"); -- else Verbs_Dictionary.Add_New(Lexical.Get_Value,dict); -- end if; Lexical.Next; Synonymes.Parse (dict); else Erreur.Parse("Manque un verbe"); end if; End Action; Procedure Parse (dict:Verbs_Dictionary.Object) is Begin Action (dict); while Is_In(Lexical.Get_Token,Action_First) loop Action (dict); end loop; End Parse; End Actions; with unchecked_deallocation; Package body Binary_Trees_Pkg is --| Efficient implementation of binary trees. ---------------------------------------------------------------------------- -- Local Operations -- ---------------------------------------------------------------------------- procedure Free_Node is new unchecked_deallocation(Node, Node_Ptr); procedure Free_Tree is new unchecked_deallocation(Tree_Header, Tree); procedure Free_Iterator is new unchecked_deallocation(Iterator_Record, Iterator); ---------------------------------------------------------------------------- -- Visible Operations -- ---------------------------------------------------------------------------- Function Create --| Return an empty tree. return Tree is begin return new Tree_Header'(0, Null); end Create; ---------------------------------------------------------------------------- Procedure Insert_Node( V: Value_Type; N: in out Node_Ptr; Found: out boolean; Duplicate: out Value_Type ) is D: integer; begin Found := False; if N = null then N := new Node'(V, Null, Null); else D := Difference(V, N.Value); if D < 0 then Insert_Node(V, N.Less, Found, Duplicate); elsif D > 0 then Insert_Node(V, N.More, Found, Duplicate); else Found := True; Duplicate := N.Value; end if; end if; end Insert_Node; Procedure Replace_Node( V: Value_Type; N: in out Node_Ptr; Found: out boolean; Duplicate: out Value_Type ) is D: integer; begin Found := False; if N = null then N := new Node'(V, Null, Null); else D := Difference(V, N.Value); if D < 0 then Replace_Node(V, N.Less, Found, Duplicate); elsif D > 0 then Replace_Node(V, N.More, Found, Duplicate); else Found := True; Duplicate := N.Value; N.Value := V; end if; end if; end Replace_Node; Procedure Insert( --| Insert a value into a tree. V: Value_Type; --| Value to be inserted T: Tree --| Tree to contain the new value ) --| Raises: Duplicate_Value, Invalid_Tree. is Found: boolean; Duplicate: Value_Type; begin if T = null then raise Invalid_Tree; end if; Insert_Node(V, T.Root, Found, Duplicate); if Found then raise Duplicate_Value; end if; T.Count := T.Count + 1; end Insert; Procedure Insert_if_not_Found( --| Insert a value into a tree, provided a duplicate value is not already there V: Value_Type; --| Value to be inserted T: Tree; --| Tree to contain the new value Found: out boolean; Duplicate: out Value_Type ) --| Raises: Invalid_Tree. is was_Found: boolean; begin if T = null then raise Invalid_Tree; end if; Insert_Node(V, T.Root, was_Found, Duplicate); Found := was_Found; if not was_Found then T.Count := T.Count + 1; end if; end Insert_if_Not_Found; procedure Replace_if_Found( --| Replace a value if label exists, otherwise insert it. V: Value_Type; --| Value to be inserted T: Tree; --| Tree to contain the new value Found: out boolean; --| Becomes True iff L already in tree Old_Value: out Value_Type --| the duplicate value, if there is one ) --| Raises: Invalid_Tree. is was_Found: boolean; Duplicate: Value_Type; begin if T = null then raise Invalid_Tree; end if; Replace_Node(V, T.Root, was_Found, Duplicate); Found := was_Found; if was_Found then Old_Value := Duplicate; else T.Count := T.Count + 1; end if; end Replace_if_Found; ---------------------------------------------------------------------------- procedure Destroy_Nodes( N: in out Node_Ptr ) is begin if N /= null then Destroy_Nodes(N.Less); Destroy_Nodes(N.More); Free_Node(N); end if; end Destroy_Nodes; procedure Destroy( --| Free space allocated to a tree. T: in out Tree --| The tree to be reclaimed. ) is begin if T /= Null then Destroy_Nodes(T.Root); Free_Tree(T); end if; end Destroy; ---------------------------------------------------------------------------- procedure Destroy_Deep( --| Free all space allocated to a tree. T: in out Tree --| The tree to be reclaimed. ) is procedure Destroy_Nodes( N: in out node_Ptr ) is begin if N /= null then Free_Value(N.Value); Destroy_Nodes(N.Less); Destroy_Nodes(N.More); Free_Node(N); end if; end Destroy_Nodes; begin if T /= Null then Destroy_Nodes(T.Root); Free_Tree(T); end if; end Destroy_Deep; ---------------------------------------------------------------------------- Function Balanced_Tree( Count: natural ) return Tree is new_Tree: Tree := Create; procedure subtree(Count: natural; N: in out Node_Ptr) is new_Node: Node_Ptr; begin if Count = 1 then new_Node := new Node'(next_Value, Null, Null); elsif Count > 1 then new_node := new Node; subtree(Count/2, new_Node.Less); -- Half are less new_Node.Value := next_Value; -- Median value subtree(Count - Count/2 - 1, new_Node.More); -- Other half are more end if; N := new_Node; end subtree; begin new_Tree.Count := Count; subtree(Count, new_Tree.Root); return new_Tree; end Balanced_Tree; ---------------------------------------------------------------------------- Function Copy_Tree( T: Tree ) return Tree is I: Iterator; function next_Val return Value_type is V: Value_Type; begin Next(I, V); return copy_Value(V); end next_Val; function copy_Balanced is new Balanced_Tree(next_Val); begin I := Make_Iter(T); -- Will raise Invalid_Tree if necessary return copy_Balanced(Size(T)); end Copy_Tree; ---------------------------------------------------------------------------- Function Is_Empty( --| Check for an empty tree. T: Tree ) return boolean is begin return T = Null or else T.Root = Null; end Is_Empty; ---------------------------------------------------------------------------- procedure Find_Node( V: Value_Type; --| Value to be located N: Node_Ptr; --| subtree to be searched Match: out Value_Type; --| Matching value found in the tree Found: out Boolean --| TRUE iff a match was found ) is D: integer; begin if N = null then Found := False; return; end if; D := Difference(V, N.Value); if D < 0 then Find_Node(V, N.Less, Match, Found); elsif D > 0 then Find_Node(V, N.More, Match, Found); else Match := N.Value; Found := TRUE; end if; end Find_Node; Function Find( --| Search a tree for a value. V: Value_Type; --| Value to be located T: Tree --| Tree to be searched ) return Value_Type --| Raises: Not_Found. is Found: Boolean; Match: Value_Type; begin if T = Null then raise Invalid_Tree; end if; Find_Node(V, T.Root, Match, Found); if Found then return Match; else raise Not_Found; end if; end Find; Procedure Find( --| Search a tree for a value. V: Value_Type; --| Value to be located T: Tree; --| Tree to be searched Found: out Boolean; --| TRUE iff a match was found Match: out Value_Type --| Matching value found in the tree ) is begin if T = Null then raise Invalid_Tree; end if; Find_Node(V, T.Root, Match, Found); end Find; ---------------------------------------------------------------------------- function is_Found( --| Check a tree for a value. V: Value_Type; --| Value to be located T: Tree --| Tree to be searched ) return Boolean is Found: Boolean; Match: Value_Type; begin if T = Null then raise Invalid_Tree; end if; Find_Node(V, T.Root, Match, Found); return Found; end is_Found; ---------------------------------------------------------------------------- function Size( --| Return the count of values in T. T: Tree --| a tree ) return natural is begin if T = Null then Return 0; else Return T.Count; end if; end Size; ---------------------------------------------------------------------------- procedure Visit( T: Tree; Order: Scan_Kind ) is procedure visit_Inorder(N: Node_Ptr) is begin if N.Less /= null then visit_Inorder(N.Less); end if; Process(N.Value); if N.More /= null then visit_Inorder(N.More); end if; end visit_Inorder; procedure visit_preorder(N: Node_Ptr) is begin Process(N.Value); if N.Less /= null then visit_preorder(N.Less); end if; if N.More /= null then visit_preorder(N.More); end if; end visit_preorder; procedure visit_postorder(N: Node_Ptr) is begin if N.Less /= null then visit_postorder(N.Less); end if; if N.More /= null then visit_postorder(N.More); end if; Process(N.Value); end visit_postorder; begin if T = Null then raise Invalid_Tree; else case Order is when inorder => Visit_Inorder(T.Root); when preorder => Visit_preorder(T.Root); when postorder => Visit_postorder(T.Root); end case; end if; end Visit; ---------------------------------------------------------------------------- function subtree_Iter( --| Create an iterator over a subtree N: Node_Ptr; P: Iterator ) return Iterator is begin if N = Null then return new Iterator_Record'(State => Done, Parent => P, subtree => N); elsif N.Less = Null then return new Iterator_Record'(State => Middle, Parent => P, subtree => N); else return new Iterator_Record'(State => Left, Parent => P, subtree => N); end if; end subtree_Iter; function Make_Iter( --| Create an iterator over a tree T: Tree ) return Iterator is begin if T = Null then raise Invalid_Tree; end if; return subtree_Iter(T.Root, Null); end Make_Iter; ---------------------------------------------------------------------------- function More( --| Test for exhausted iterator I: Iterator --| The iterator to be tested ) return boolean is begin if I = Null then return False; elsif I.Parent = Null then return I.State /= Done and I.subtree /= Null; elsif I.State = Done then return More(I.Parent); else return True; end if; end More; ---------------------------------------------------------------------------- procedure pop_Iterator( I: in out Iterator ) is NI: Iterator; begin loop NI := I; I := I.Parent; Free_Iterator(NI); exit when I = Null; exit when I.State /= Done; end loop; end pop_Iterator; procedure Next( --| Scan the next value in I I: in out Iterator; --| an active iterator V: out Value_Type --| Next value scanned ) --| Raises: No_More. is NI: Iterator; begin if I = Null or I.State = Done then raise No_More; end if; case I.State is when Left => -- Return the leftmost value while I.subtree.Less /= Null loop -- Find leftmost subtree I.State := Middle; -- Middle is next at this level I := subtree_Iter(I.subtree.Less, I); end loop; V := I.subtree.Value; if I.subtree.More /= Null then -- There will be more... I.State := Right; -- ... coming from the right else -- Nothing else here pop_Iterator(I); -- Pop up to parent iterator end if; when Middle => V := I.subtree.Value; if I.subtree.More /= Null then -- There will be more... I.State := Right; -- ... coming from the right else -- Nothing else here so... pop_Iterator(I); -- ... Pop up to parent iterator end if; when Right => -- Return the value on the right I.State := Done; -- No more at this level I := subtree_Iter(I.subtree.More, I); Next(I, V); when Done => pop_Iterator(I); Next(I, V); end case; end Next; ---------------------------------------------------------------------------- end binary_trees_pkg; With Text_io; package body Bounded_String is procedure Free (The_String : in out Variable_String) is begin The_String.The_Length := void; end Free; procedure Append (Target : in out Variable_String; Source : in character) is begin If (Target.The_Length < Target.The_Content'Last) then Target.The_Length := Target.The_Length +1; Target.The_Content (Target.The_Length) := Source; end if; end Append; procedure Set (The_String : in out Variable_String; With_String : in String) is begin If (With_String'Last <= The_String.The_Content'Last) then The_String.The_Length := With_String'length; The_String.The_Content (With_String'Range) := With_String(With_String'Range); else The_String.The_Length := The_String.The_Content'Length; The_String.The_Content (The_String.The_Content'Range) := With_String(The_String.The_Content'Range); end if; end Set; procedure Copy (The_String : in out Variable_String; With_String : in String) is begin If (With_String'Last <= The_String.The_Content'Last) then The_String.The_Length := With_String'length; The_String.The_Content (With_String'Range) := With_String(With_String'Range); else The_String.The_Length := The_String.The_Content'Length; The_String.The_Content (The_String.The_Content'Range) := With_String(The_String.The_Content'Range); end if; end Copy; function Image (From_The_String : in Variable_String) return String is begin return (From_The_String.The_Content(1..From_The_String.The_Length)); end Image; end Bounded_String;With Lexical,Token_List,Erreur,Etat; Use Lexical,Token_List; Package body Connexions is Connexion_First:Token_List.Object := Make(Creer_Connexion); Procedure Connexion is Begin if Lexical.Get_Token = Creer_Connexion then Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Virgul then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Virgul then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Virgul then Lexical.Next; Etat.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Mauvais qualificateur"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Mauvais id"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Mauvais id"); end if; else Erreur.Parse("Manque ("); end if; else Erreur.Parse("Manque CREER_CONNEXION"); end if; End Connexion; Procedure Parse is Begin Connexion; while Is_In(Lexical.Get_Token,Connexion_First) loop Connexion; end loop; End Parse; End Connexions; With Lexical,Token_List,Erreur,Variable,Nom_de_variable,Etat,Nombre; Use Lexical,Token_List; Package body Corps_cond is Procedure Parse is Begin if Is_In(Lexical.Get_Token,Variable.First) then Variable.Parse; else if Is_In(Lexical.Get_Token,Etat.First) then Etat.Parse; else if Is_In(Lexical.Get_Token,Nombre.First) then Nombre.Parse; else case Lexical.Get_Token is when Existe_Connexion | Etat_Connexion | Existe_Lien | Etat_Lien => Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Virgul then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Manque ("); end if; when Vrai | Faux => Lexical.Next; when others => Erreur.Parse("Mauvaise condition"); end case; end if; end if; end if; End Parse; End Corps_cond; With Lexical,Token_List,Erreur,Definitions_simples,Noms; Use Lexical,Token_List; Package body Definitions is Definition_First:Token_List.Object := Make((Structure,Enumere)); Procedure Definition is Begin case Lexical.Get_Token is when Structure => Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Definitions_simples.Parse; If Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ("); end if; else Erreur.Parse("Manque Nom de structure"); end if; when Enumere => Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Noms.Parse; If Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ("); end if; else Erreur.Parse("Manque Nom de enumere"); end if; when others => Erreur.Parse("Manque Enumere/Structure"); end case; End Definition; Procedure Parse is Begin Definition; while Is_In(Lexical.Get_Token,Definition_First) loop Definition; end loop; End Parse; End Definitions; With Lexical,Token_List,Erreur,Nom_de_Type; Use Lexical,Token_List; Package body Definitions_simples is First_bis:Token_List.Object := Make(Virgul); Procedure Definition_simple is Begin Nom_de_Type.Parse; if Lexical.Get_Token = Id then Lexical.Next; else Erreur.Parse("Manque Id"); end if; End Definition_simple; Procedure Parse is Begin Definition_simple; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Definition_simple; end loop; End Parse; End Definitions_simples; With Lexical,Token_List,Erreur,Qualificateur,Connexions; Use Lexical,Token_List; Package body Def_Connexions is First:Token_List.Object := Qualificateur.First; Procedure Parse is Begin if Is_In(Lexical.Get_Token,First) then Qualificateur.Parse; Connexions.Parse; end if; End Parse; End Def_Connexions; With Text_Io,Lexical; Package body Erreur is Erreur_Flag:Boolean := False; Procedure Parse(message:String) is Begin Text_Io.Put(message); Text_Io.Put(" dans la ligne:"); Text_Io.Put(Natural'Image (Lexical.Get_Line)); Text_Io.Put(" dans la colone:"); Text_Io.Put(Natural'Image (Lexical.Get_Column)); Erreur_Flag:=True; raise Erreur_Syntaxe; End Parse; Function Is_Any return Boolean is Begin return Erreur_Flag; End Is_Any; End Erreur; With Lexical,Token_List,Erreur; Use Lexical,Token_List; Package body Etat is Procedure Parse is Begin if Is_In(Lexical.Get_Token,First) then Lexical.Next; else Erreur.Parse("Etat Inconnu"); end if; End Parse; End Etat; With Lexical,Token_List,Erreur,Terme; Use Lexical,Token_List; Package body Expression is First_bis:Token_List.Object := Make((Plus,Moins,Ou)); Procedure Parse is Begin Terme.Parse; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Terme.Parse; end loop; End Parse; End Expression; With Lexical,Token_List,Erreur,Terme_cond; Use Lexical,Token_List; Package body Exp_cond is First_bis:Token_List.Object := Make(Ou); Procedure Parse is Begin Terme_cond.Parse; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Terme_cond.Parse; end loop; End Parse; End Exp_cond; With Lexical,Token_List,Erreur,Expression,Facteur,Nom_de_variable; Use Lexical,Token_List; Package body Expression_Generale is Procedure Parse is Begin if Is_In(Lexical.Get_Token,Expression.First) then Expression.Parse; else if Lexical.Get_Token = Destination_Connexion then Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Virgul then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Mauvaise expression/fonction lors de l affectation"); end if; end if; End Parse; End Expression_Generale; With Lexical,Token_List,Erreur,Expression,Variable,Nombre; Use Lexical,Token_List; Package body Facteur is Procedure Parse is Begin if Is_In(Lexical.Get_Token,Nombre.First) then Nombre.Parse; else case Lexical.Get_Token is when Parnto => Lexical.Next; Expression.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; when Non => Lexical.Next; Parse; when Id | Comp => Variable.Parse; when Vrai | Faux => Lexical.Next; when others => Erreur.Parse("Facteur non valide"); end case; end if; End Parse; End Facteur; With Lexical,Token_List,Erreur,Exp_cond,Corps_cond,Test,Liste_des_entrees; Use Lexical,Token_List; Package body Facteur_cond is Procedure Parse is Begin if Is_In(Lexical.Get_Token,Corps_cond.First) then Corps_cond.Parse; Test.Parse; Corps_cond.Parse; else case Lexical.Get_Token is when Parnto => Lexical.Next; Exp_cond.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; when Crocho => Lexical.Next; Liste_des_entrees.Parse; if Lexical.Get_Token = Crochf then Lexical.Next; else Erreur.Parse("Manque ]"); end if; when others => Erreur.Parse("Condition Incorrecte"); end case; end if; End Parse; End Facteur_cond; With Lexical,Erreur; Use Lexical; Package body Fin_Jeu is Procedure Parse is Begin if Lexical.Get_Token = Fin then Lexical.Next; else Erreur.Parse ("Manque FIN"); end if; End Parse; End Fin_Jeu; With Lexical,Erreur,Init_Complexe,Init_Simple; Use Lexical; Package body Initialisation is Procedure Parse is Begin case Lexical.Get_Token is when Avec => Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Init_Complexe.Parse; If Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ("); end if; when Init => Lexical.Next; Init_Simple.Parse; when others => Erreur.Parse("Manque Avec/Init"); end case; End Parse; End Initialisation; With Lexical,Token_List,Erreur,Init_Simple; Use Lexical,Token_List; Package body Init_Complexe is First_bis:Token_List.Object := Make(Virgul); Procedure Parse is Begin Init_Simple.Parse; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Init_Simple.Parse; end loop; End Parse; End Init_Complexe; With Lexical,Token_List,Erreur,Nombre; Use Lexical,Token_List; Package body Init_Simple is First:Token_List.Object := Make((Str,Moins,Nbr,Vrai,Faux,Id)); Procedure Parse is Begin if Is_In(Lexical.Get_Token,First) then if Is_In(Lexical.Get_Token,Nombre.First) then Nombre.Parse; else Lexical.Next; end if; else Erreur.Parse("Initialisation Inconnue"); end if; End Parse; End Init_Simple; With Lexical,Token_List,Erreur,Instruction_si,Nom_de_variable,Variable,Expression_generale,Etat,Param_afficher; Use Lexical,Token_List; Package body Instructions is Instruction_First:Token_List.Object := Make((Si,Moins,Comp,Detruire_connexion,Lie_Connexion, Delie_Connexion,Detruire_Lien,Lie_Lien,Delie_Lien, Liste_Lien,Echanger_Lien,Afficher,Fin)); Procedure Instruction is Begin if Is_In(Lexical.Get_Token,Instruction_si.First) then Instruction_si.Parse; else if Is_In(Lexical.Get_Token,Variable.First) then Variable.Parse; if Lexical.Get_Token = Affect then Lexical.Next; Expression_generale.Parse; else Erreur.Parse("Manque :="); end if; else case Lexical.Get_Token is when Detruire_Connexion | Echanger_Lien => Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Virgul then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Virgul then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Manque ("); end if; when Lie_Connexion | Delie_Connexion | Detruire_Lien | Lie_Lien | Delie_Lien => Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Virgul then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Manque ("); end if; when Liste_Lien => Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Nom_de_variable.Parse; if Lexical.Get_Token = Virgul then Lexical.Next; Etat.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Manque ("); end if; when Afficher => Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Param_afficher.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ("); end if; when Fin => Lexical.Next; when others => Erreur.Parse("Mauvaise instruction"); end case; end if; end if; End Instruction; Procedure Parse is Begin Instruction; while Is_In(Lexical.Get_Token,Instruction_First) loop Instruction; end loop; End Parse; End Instructions; With Lexical,Erreur,Instructions; Use Lexical; Package body Instruction_pour is Procedure Parse is Begin if Lexical.Get_Token = Pour then Lexical.Next; if Lexical.Get_Token = Nbr then Lexical.Next; if Lexical.Get_Token = Entree then Lexical.Next; if Lexical.Get_Token = Faire then Lexical.Next; Instructions.Parse; if Lexical.Get_Token = Finpour then Lexical.Next; else Erreur.Parse ("Manque Finpour"); end if; else Erreur.Parse ("Manque Faire"); end if; else Erreur.Parse ("Manque Entree"); end if; else Erreur.Parse ("Manque le nombre d actions"); end if; else Erreur.Parse ("Manque Pour"); end if; End Parse; End Instruction_pour; With Lexical,Erreur,Exp_cond,Instructions; Use Lexical; Package body Instruction_si is Procedure Bloc_sinon is Begin if Lexical.Get_Token = Sinon then Lexical.Next; Instructions.Parse; end if; End Bloc_sinon; Procedure Parse is Begin if Lexical.Get_Token = Si then Lexical.Next; Exp_cond.Parse; if Lexical.Get_Token = Alors then Lexical.Next; Instructions.Parse; Bloc_sinon; if Lexical.Get_Token = Finsi then Lexical.Next; else Erreur.Parse ("Manque Finsi"); end if; else Erreur.Parse ("Manque Alors"); end if; else Erreur.Parse ("Manque Si"); end if; End Parse; End Instruction_si; With Lexical,Token_List,Erreur,Instruction_si,Instruction_pour; Use Lexical,Token_List; Package body Instructions_Globales is Instruction_globale_First:Token_List.Object := Make((Si,Pour)); Procedure Instruction_Globale is Begin if Is_In(Lexical.Get_Token,Instruction_si.First) then Instruction_si.Parse; else if Is_In(Lexical.Get_Token,Instruction_pour.First) then Instruction_pour.Parse; else Erreur.Parse("Mauvaise instruction globale"); end if; end if; End Instruction_Globale; Procedure Parse is Begin Instruction_Globale; while Is_In(Lexical.Get_Token,Instruction_globale_First) loop Instruction_Globale; end loop; End Parse; End Instructions_Globales; With Lexical,Token_List,Erreur,Instruction_si; Use Lexical,Token_List; Package body Instructions_Locales is Instruction_locale_First:Token_List.Object := Make(Si); Procedure Instruction_Locale is Begin Instruction_si.Parse; End Instruction_Locale; Procedure Parse is Begin Instruction_Locale; while Is_In(Lexical.Get_Token,Instruction_locale_First) loop Instruction_Locale; end loop; End Parse; End Instructions_Locales; With Lexical,Verbs_Dictionary,Erreur,Actions; Use Lexical; Package body Les_Actions is Procedure Parse (dict:Verbs_Dictionary.Object) is Begin If Lexical.Get_Token = Action Then Lexical.Next; Actions.Parse(dict); Else Erreur.Parse ("Manque ACTION"); End if; End Parse; End Les_Actions; with Bounded_String, Source, Text_Io; use Bounded_String; package body Lexical is type State is (St_Normal, St_Comment, St_Nbr, St_Debstr, St_Finstr, St_Id, St_2point, St_Affect, St_Inf, St_Infequ, St_Diffr, St_Sup, St_Supequ, St_Newlinestr, St_Found); subtype Minuscule is Character range 'a' .. 'z'; subtype Majuscule is Character range 'A' .. 'Z'; subtype Digit is Character range '0' .. '9'; subtype Keyword is Token range Jeu .. Fin; Currentvalue : Variable_String (Maxstring); Currenttoken : Token; function Iskeyword (The_String : in String) return Boolean is T : Keyword; begin T := Keyword'Value (The_String); return True; exception when Constraint_Error => return False; end Iskeyword; function Keywordtotoken (Word : in String) return Token is begin if Iskeyword (Word) then return Token'Value (Word); else return Id; end if; end Keywordtotoken; procedure Get_State_After_Inf (Astate : in out State; Achar : in Character) is begin case Achar is when '=' => Currenttoken := Infequ; when '>' => Currenttoken := Diffr; when others => Source.Unget; Currenttoken := Inf; end case; Astate := St_Found; end Get_State_After_Inf; procedure Get_State_After_Sup (Astate : in out State; Achar : in Character) is begin if (Achar = '=') then Currenttoken := Supequ; else Currenttoken := Sup; Source.Unget; end if; Astate := St_Found; end Get_State_After_Sup; procedure Get_String_After_Debstr (Astate : in out State; Achar : in Character) is begin if (Achar = '"') then Astate := St_Finstr; elsif (Achar = '\') then Astate := St_Newlinestr; elsif not (Achar = Ascii.Cr) then Bounded_String.Append (Currentvalue, Achar); end if; end Get_String_After_Debstr; procedure Get_String_After_Newlinestr (Astate : in out State; Achar : in Character) is begin if (Achar = '\') then Astate := St_Debstr; elsif (Achar = ' ' or Achar = Ascii.Cr or Achar = Ascii.Ht) then Astate := St_Newlinestr; else Currenttoken := Unk; Astate := St_Found; end if; end Get_String_After_Newlinestr; procedure Get_String_After_Finstr (Astate : in out State; Achar : in Character) is begin if (Achar = '"') then Bounded_String.Append (Currentvalue, Achar); Astate := St_Debstr; else Currenttoken := Str; Astate := St_Found; Source.Unget; end if; end Get_String_After_Finstr; procedure Get_State_After_2point (Astate : in out State; Achar : in Character) is begin if (Achar = '=') then Currenttoken := Affect; else Currenttoken := Unk; end if; Astate := St_Found; end Get_State_After_2point; procedure Get_Id (Astate : in out State; Achar : in Character) is begin if (Achar in Minuscule or Achar in Majuscule or Achar in Digit or Achar = '_') then Bounded_String.Append (Currentvalue, Achar); else Source.Unget; Astate := St_Found; Currenttoken := Keywordtotoken (Bounded_String.Image (Currentvalue)); end if; end Get_Id; procedure Get_Nbr (Astate : in out State; Achar : in Character) is begin if (Achar in Digit) then Bounded_String.Append (Currentvalue, Achar); else Source.Unget; Astate := St_Found; Currenttoken := Nbr; end if; end Get_Nbr; procedure Get_State_After_Normal (Astate : in out State; Achar : in Character) is begin case Achar is when Ascii.Cr | Ascii.Ht | ' ' => Astate := St_Normal; when '*' => Currenttoken := Mul; Astate := St_Found; when '/' => Currenttoken := Div; Astate := St_Found; when '[' => Currenttoken := Crocho; Astate := St_Found; when ']' => Currenttoken := Crochf; Astate := St_Found; when '(' => Currenttoken := Parnto; Astate := St_Found; when ')' => Currenttoken := Parntf; Astate := St_Found; when ',' => Currenttoken := Virgul; Astate := St_Found; when '+' => Currenttoken := Plus; Astate := St_Found; when '-' => Currenttoken := Moins; Astate := St_Found; when '.' => Currenttoken := Point; Astate := St_Found; when '=' => Currenttoken := Equ; Astate := St_Found; when '{' => Astate := St_Comment; when '"' => Astate := St_Debstr; when ':' => Astate := St_2point; when '<' => Astate := St_Inf; when '>' => Astate := St_Sup; when Digit => Bounded_String.Append (Currentvalue, Achar); Astate := St_Nbr; when Majuscule | Minuscule => Bounded_String.Append (Currentvalue, Achar); Astate := St_Id; when others => Bounded_String.Append (Currentvalue, Achar); Currenttoken := Unk; Astate := St_Found; end case; end Get_State_After_Normal; procedure Init (Nomf : String) is begin Source.Init(Nomf); end Init; function Get_Token return Token is begin return Currenttoken; end Get_Token; function Get_Value return String is begin return Bounded_String.Image (Currentvalue); end Get_Value; function At_End return Boolean is begin return Source.At_End; end At_End; function Get_Line return Natural is begin return Source.Get_Line; end Get_Line; function Get_Column return Natural is begin return Source.Get_Column; end Get_Column; procedure Next is Currentchar : Character; Currentstate : State; begin if not (Source.At_End) then Bounded_String.Free (Currentvalue); Currentstate := St_Normal; Search_Token: loop if not (Source.At_End) then Source.Next; Currentchar := Source.Value; else Currenttoken := Lexend; exit Search_Token; end if; case Currentstate is when St_Normal => Get_State_After_Normal (Currentstate, Currentchar); when St_Comment => if (Currentchar = '}') then Currentstate := St_Normal; end if; when St_Debstr => Get_String_After_Debstr (Currentstate, Currentchar); when St_Newlinestr => Get_String_After_Newlinestr (Currentstate, Currentchar); when St_Finstr => Get_String_After_Finstr (Currentstate, Currentchar); when St_2point => Get_State_After_2point (Currentstate, Currentchar); when St_Inf => Get_State_After_Inf (Currentstate, Currentchar); when St_Sup => Get_State_After_Sup (Currentstate, Currentchar); when St_Id => Get_Id (Currentstate, Currentchar); when St_Nbr => Get_Nbr (Currentstate, Currentchar); when others => Currenttoken := Unk; Bounded_String.Append (Currentvalue, Currentchar); Currentstate := St_Found; end case; exit when Currentstate = St_Found; end loop Search_Token; else Currenttoken := Lexend; end if; end Next; procedure Close is begin Source.Close; end Close; end Lexical; With Lexical,Erreur,Def_Connexions,Liens; Use Lexical; Package body Liaisons is Procedure Parse is Begin Def_Connexions.Parse; Liens.Parse; End Parse; End Liaisons; With Lexical,Token_List,Erreur,Etat; Use Lexical,Token_List; Package body Liens is Lien_First:Token_List.Object := Make(Creer_Lien); Procedure Lien is Begin if Lexical.Get_Token = Creer_Lien then Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Virgul then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Virgul then Lexical.Next; Etat.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Mauvais id"); end if; else Erreur.Parse("Manque ,"); end if; else Erreur.Parse("Mauvais id"); end if; else Erreur.Parse("Manque ("); end if; else Erreur.Parse("Manque CREER_LIEN"); end if; End Lien; Procedure Parse is Begin while Is_In(Lexical.Get_Token,Lien_First) loop Lien; end loop; End Parse; End Liens; With Lexical,Erreur; Use Lexical; Package body Liste_des_entrees is Procedure Parse is Begin if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; end if; else if Lexical.Get_Token = Comp then Lexical.Next; end if; end if; else if Lexical.Get_Token = Comp then Lexical.Next; else Erreur.Parse("Mauvaise expression de saisie joueur"); end if; end if; End Parse; End Liste_des_entrees; With Lexical,Token_List,Verbs_Dictionary,Erreur; Use Lexical,Token_List; Package body Liste_Synonymes is First_bis:Token_List.Object := Make(Virgul); Procedure Liste_Synonyme (dict:Verbs_Dictionary.Object) is Begin if Lexical.Get_Token = Id then -- if Verbs_Dictionary.Exist(Lexical.Get_Value,dict) then -- Erreur.Parse("Synonyme deja existant"); -- else -- Verbs_Dictionary.Add_Synonym(Lexical.Get_Value,dict); -- end if; Lexical.Next; else Erreur.Parse("Manque Id"); end if; End Liste_Synonyme; Procedure Parse (dict:Verbs_Dictionary.Object) is Begin Liste_Synonyme (dict); while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Liste_Synonyme (dict); end loop; End Parse; End Liste_Synonymes; With Lexical,Erreur,Instructions_Locales; Use Lexical; Package body Les_Anims_Locales is Procedure Parse is Begin if Lexical.Get_Token = Animation_Locale then Lexical.Next; Instructions_Locales.Parse; else Erreur.Parse ("Manque ANIMATION_LOCALE"); end if; End Parse; End Les_Anims_Locales; With Lexical,Erreur,Instructions_Globales; Use Lexical; Package body Les_Anims_Globales is Procedure Parse is Begin if Lexical.Get_Token = Animation_Globale then Lexical.Next; Instructions_Globales.Parse; else Erreur.Parse ("Manque ANIMATION_GLOBALE"); end if; End Parse; End Les_Anims_Globales; With Lexical,Erreur,Definitions; Use Lexical; Package body Les_Definitions is Procedure Parse is Begin If Lexical.Get_Token = Definition then Lexical.Next; Definitions.Parse; else Erreur.Parse ("Manque DEFINITION"); end if; End Parse; End Les_Definitions; With Lexical,Erreur,Liaisons; Use Lexical; Package body Les_Liaisons is Procedure Parse is Begin if Lexical.Get_Token = Liaison then Lexical.Next; Liaisons.Parse; else Erreur.Parse ("Manque LIAISON"); end if; End Parse; End Les_Liaisons; With Lexical,Erreur,Presentations; Use Lexical; Package body Les_Presentations is Procedure Parse is Begin if Lexical.Get_Token = Presentation then Lexical.Next; Presentations.Parse; else Erreur.Parse ("Manque PRESENTATION"); end if; End Parse; End Les_Presentations; With Lexical,Erreur; Use Lexical; Package body Nombre is Procedure Parse is Begin if Lexical.Get_Token = Moins then Lexical.Next; end if; if Lexical.Get_Token = Nbr then Lexical.Next; else Erreur.Parse("Manque un entier"); end if; End Parse; End Nombre; With Lexical,Token_List,Erreur; Use Lexical,Token_List; Package body Noms is First_bis:Token_List.Object := Make(Virgul); Procedure Nom is Begin if Lexical.Get_Token = Id then Lexical.Next; else Erreur.Parse("Manque Id"); end if; End Nom; Procedure Parse is Begin Nom; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Nom; end loop; End Parse; End Noms; With Lexical,Erreur; Use Lexical; Package body Nom_Jeu is Procedure Parse is Begin If Lexical.Get_Token = Jeu Then Lexical.Next; If Lexical.Get_Token = Id Then Lexical.Next; Else Erreur.Parse ("Manque un Identificateur"); End if; Else Erreur.Parse ("Manque JEU"); End if; End Parse; End Nom_Jeu; With Lexical,Token_List,Erreur; Use Lexical,Token_List; Package body Nom_de_Type is First:Token_List.Object := Make((Chaine,Entier,Booleen,Id)); Procedure Parse is Begin if Is_In(Lexical.Get_Token,First) then Lexical.Next; else Erreur.Parse("Type Inconnu"); end if; End Parse; End Nom_de_Type; With Lexical,Token_List,Erreur; Use Lexical,Token_List; Package body Nom_de_variable is First:Token_List.Object := Make((Id,Comp)); Procedure Parse is Begin if Is_In(Lexical.Get_Token,First) then Lexical.Next; else Erreur.Parse("Nom de variable Inconnu"); end if; End Parse; End Nom_de_variable; With Lexical,Token_List,Erreur,Variable; Use Lexical,Token_List; Package body Param_afficher is First_bis:Token_List.Object := Make(Virgul); Procedure Param is Begin case Lexical.Get_Token is when Str => Lexical.Next; when Id | Comp => Variable.Parse; when Others => Erreur.Parse("Mauvais parametre afficher"); end case; End Param; Procedure Parse is Begin Param; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Param; end loop; End Parse; End Param_afficher; With Lexical,Token_List,Erreur,Nom_De_Type,Initialisation; Use Lexical,Token_List; Package body Presentations is Presentation_First:Token_List.Object := Make(Id); Procedure Presentation is Begin if Lexical.Get_Token = Id then Lexical.Next; if Lexical.Get_Token = Objet then Lexical.Next; Nom_De_Type.Parse; Initialisation.Parse; else Erreur.Parse("Manque Objet"); end if; else Erreur.Parse("Manque Nom Objet"); end if; End Presentation; Procedure Parse is Begin Presentation; while Is_In(Lexical.Get_Token,Presentation_First) loop Presentation; end loop; End Parse; End Presentations; With Lexical,Erreur,Noms; Use Lexical; Package body Qualificateur is Procedure Parse is Begin if Lexical.Get_Token = Connexion then Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Noms.Parse; if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ("); end if; else Erreur.Parse("Manque CONNEXION"); end if; End Parse; End Qualificateur; package body Source is Currentchar : Character; Lookahead : Boolean; Currentline : Natural; Currentcol : Natural; Handle : T_File; procedure Init ( Nomf : String ) is begin Lookahead := False; Currentline := 1; Currentcol := 0; Text_Io.Open (File => Handle, Mode => Text_Io.In_File, Name => Nomf); end Init; function Get_Line return Natural is begin return Currentline; end Get_Line; function Get_Column return Natural is begin return Currentcol; end Get_Column; function Value return Character is begin return Currentchar; end Value; procedure Unget is begin Lookahead := True; end Unget; function At_End return Boolean is begin return (Text_Io.End_Of_File (Handle)); end At_End; procedure Next is begin if (Lookahead = False) then if Text_Io.End_Of_File (Handle) then Currentchar := Eof; elsif Text_Io.End_Of_Line (Handle) then Text_Io.Skip_Line (Handle); Currentchar := Ascii.Cr; Currentline := Currentline + 1; Currentcol := 0; else Text_Io.Get (Handle, Currentchar); Currentcol := Currentcol + 1; end if; else Lookahead := False; end if; end Next; function Get return Character is begin Next; return (Value); end Get; procedure Close is begin Text_Io.Close( Handle ); end Close; end Source; With Lexical,Verbs_Dictionary,Erreur,Liste_Synonymes; Use Lexical; Package body Synonymes is Procedure Parse (dict:Verbs_Dictionary.Object) is Begin if Lexical.Get_Token = Synonyme then Lexical.Next; if Lexical.Get_Token = Parnto then Lexical.Next; Liste_Synonymes.Parse (dict); if Lexical.Get_Token = Parntf then Lexical.Next; else Erreur.Parse("Manque )"); end if; else Erreur.Parse("Manque ("); end if; end if; End Parse; End Synonymes; With Lexical,Token_List,Erreur,Facteur; Use Lexical,Token_List; Package body Terme is First_bis:Token_List.Object := Make((Mul,Div,Ou)); Procedure Parse is Begin Facteur.Parse; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Facteur.Parse; end loop; End Parse; End Terme; With Lexical,Token_List,Erreur,Facteur_cond; Use Lexical,Token_List; Package body Terme_cond is First_bis:Token_List.Object := Make(Et); Procedure Parse is Begin Facteur_cond.Parse; while Is_In(Lexical.Get_Token,First_bis) loop Lexical.Next; Facteur_cond.Parse; end loop; End Parse; End Terme_cond; With Lexical,Token_List,Erreur; Use Lexical,Token_List; Package body Test is First:Token_List.Object := Make((Equ,Inf,Sup,Infequ,Supequ,Diffr)); Procedure Parse is Begin if Is_In(Lexical.Get_Token,First) then Lexical.Next; else Erreur.Parse("Operateur de test inconnu"); end if; End Parse; End Test; With Lexical; Use Lexical; Package body Token_List is Function Make (list:Tokens) return Object is local_object:Object := ( others => False ); begin for cpt in list'range loop local_object(list(cpt)) := True; end loop; return local_object; end Make; Function Make (one_token:Token) return Object is local_object:Object := ( others => False ); begin local_object(one_token):=True; return local_object; end Make; Function Is_In (one_token:Token; what:Object) return Boolean is begin return what(one_token); end Is_In; End Token_List;With Lexical,Erreur,Nom_de_variable; Use Lexical; Package body Variable is Procedure Parse is Begin Nom_de_variable.Parse; if Lexical.Get_Token = Point then Lexical.Next; if Lexical.Get_Token = Id then Lexical.Next; else Erreur.Parse("Membre incorrect"); end if; end if; End Parse; End Variable; With Binary_Trees_Pkg,Bounded_String,Text_Io; Use Bounded_String; Package body Verbs_Dictionary is Lower: Constant Integer := -1; Equal: Constant Integer := 0; Upper: Constant Integer := 1; Current_Verb: Verb; -- ---------------------------------------------------- -- Definition des fonctions pour le paquetage generique -- ---------------------------------------------------- Function Compare (a,b:Verb) return Integer is begin if Image(a.Name)<Image(b.Name) then return Lower; else if Image(a.Name)=Image(b.Name) then return Equal; else return Upper; end if; end if; end Compare; Procedure Write (scr:Verb) is begin Text_Io.Put_Line ("Name -> "&Image(scr.Name) & " / Source ->"&Image(scr.Source)); end Write; Procedure Show is new Verbs_Tree.Visit (Write); -- ------------------------------------------- -- Definition des fontions de Verbs_Dictionary -- ------------------------------------------- Function Affect_Verb (name,source:String) return Verb is tmp_verb:Verb; begin Bounded_String.Free(tmp_verb.Name); Bounded_String.Free(tmp_verb.Source); Bounded_String.Copy(tmp_verb.Name,name); Bounded_String.Copy(tmp_verb.Source,source); return tmp_verb; end Affect_Verb; Procedure Create (dict: in out Object) is begin dict.Root:=Verbs_Tree.Create; end Create; Procedure Destroy (dict: in out Object) is begin Verbs_Tree.Destroy (dict.Root); end Destroy; Procedure Add_New (new_verb:String; dict:Object) is begin Current_Verb:=Affect_Verb(new_verb,new_verb); Verbs_Tree.Insert(Affect_Verb(new_verb,new_verb),dict.Root); Exception when Verbs_Tree.Duplicate_Value => raise Duplicate_Value; end Add_New; Procedure Add_Synonym (new_syn:String; dict:Object) is begin Verbs_Tree.Insert(Affect_Verb(new_syn,Image(Current_Verb.Source)),dict.Root); Exception when Verbs_Tree.Duplicate_Value => raise Duplicate_Value; end Add_Synonym; Function Exist (scan_verb:String; dict:Object) return Boolean is begin return Verbs_Tree.Is_Found(Affect_Verb(scan_verb,scan_verb),dict.Root); end Exist; Procedure Dump (dict:Object) is begin Show(dict.Root,Verbs_Tree.InOrder); end Dump; end Verbs_Dictionary; With Verbs_Dictionary; Package Actions is Procedure Parse (dict:Verbs_Dictionary.Object); End Actions; generic type Value_Type is private; --| Type of values stored in the tree. with function Difference(P, Q: Value_Type) return integer is <>; --| Must return a value > 0 if P > Q, 0 if P = Q, and less than --| zero otherwise. package binary_trees_pkg is --| Efficient implementation of binary trees. --| OVERVIEW --| This package is an efficient implementation of unbalanced binary trees. --| These trees have the following properties: --|- --| 1. Inserting a value is cheap (log n Differences per insertion). --| 2. Finding a value is cheap (log n Differences per querey). --| 3. Can iterate over the values in sorted order in linear time. --| 4. Space overhead is moderate (2 "pointers" per value stored). --|+ --| They are thus useful both for sorting sequences of indeterminate size --| and for lookup tables. --| --| OPERATIONS --| --|-The following operations are provided: --| --| Insert Insert a node into a tree --| Insert_if_not_Found Insert a node into a tree if not there already --| Replace_if_Found Replace a node if duplicate exists, else insert. --| Destroy Destroy a tree --| Destroy_Deep* Destroy a tree and its contents --| Balanced_Tree* Create a balanced tree from values supplied in order --| Copy* Copy a tree. The copy is balanced. --| --| Queries: --| Is_Empty Return TRUE iff a tree is empty. --| Find Search tree for a node --| Is_Found Return TRUE iff tree contains specified value. --| Size Return number of nodes in the tree. --| --| Iterators: --| Visit* Apply a procedure to every node in specified order --| Make_Iter Create an iterator for ordered scan --| More Test for exhausted iterator --| Next Bump an iterator to the next element --| --| * Indicates generic subprogram --| --| USAGE --| --| The following example shows how to use this package where nodes in --| the tree are labeled with a String_Type value (for which a natural --| Difference function is not available). --|- --| package SP renames String_Pkg; --| --| type my_Value is record --| label: SP.string_type; --| value: integer; --| end record; --| --| function differ_label(P, Q: SP.string_type) return integer is --| begin --| if SP."<"(P, Q) then return -1; --| elsif SP."<"(Q, P) then return 1; --| else return 0; --| end if; --| end differ_label; --| --| package my_Tree is new Binary_Trees_pkg(my_Value, differ_Label); --| --| Note that the required Difference function may be easily written in terms --| of "<" if that is available, but that frequently two comparisons must --| be done for each Difference. However, both comparisons would have --| to be done internally by this package for every instantiation if the --| generic parameter were "<" instead of Difference. --| --| PERFORMANCE --| --| Every node can be visited in the tree in linear time. The cost --| of creating an iterator is small and independent of the size --| of the tree. --| --| Recognizing that comparing values can be expensive, this package --| takes a Difference function as a generic parameter. If it took --| a comparison function such as "<", then two comparisons would be --| made per node visited during a search of the tree. Of course this --| is more costly when "<" is a trivial operation, but in those cases, --| Difference can be bound to "-" and the overhead in negligable. --| --| Two different kinds of iterators are provided. The first is the --| commonly used set of functions Make_Iter, More, and Next. The second --| is a generic procedure called Visit. The generic parameter to Visit is --| a procedure which is called once for each value in the tree. Visit --| is more difficult to use and results in code that is not quite as clear, --| but its overhead is about 20% of the More/Next style iterator. It --| is therefore recommended for use only in time critical inner loops. ---------------------------------------------------------------------------- -- Exceptions -- ---------------------------------------------------------------------------- Duplicate_Value: exception; --| Raised on attempt to insert a duplicate node into a tree. Not_Found: exception; --| Raised on attempt to find a node that is not in a tree. No_More: exception; --| Raised on attempt to bump an iterator that has already scanned the --| entire tree. Out_Of_Order: exception; --| Raised if a problem in the ordering of a tree is detected. Invalid_Tree: exception; --| Value is not a tree or was not properly initialized. ---------------------------------------------------------------------------- -- Types -- ---------------------------------------------------------------------------- type Scan_Kind is (inorder, preorder, postorder); --| Used to specify the order in which values should be scanned from a tree: --|- --| inorder: Left, Node, Right (nodes visited in increasing order) --| preorder: Node, Left, Right (top down) --| postorder: Left, Right, Node (bottom up) type Tree is private; type Iterator is private; ---------------------------------------------------------------------------- -- Operations -- ---------------------------------------------------------------------------- Function Create --| Return an empty tree. return Tree; --| Effects: Create and return an empty tree. Note that this allocates --| a small amount of storage which can only be reclaimed through --| a call to Destroy. ---------------------------------------------------------------------------- Procedure Insert( --| Insert a value into a tree. V: Value_Type; --| Value to be inserted T: Tree --| Tree to contain the new value ); --| Raises: Duplicate_Value, Invalid_Tree. --| Effects: Insert V into T in the proper place. If a value equal --| to V (according to the Difference function) is already contained --| in the tree, the exception Duplicate_Value is raised. --| Caution: Since this package does not attempt to balance trees as --| values are inserted, it is important to remember that inserting --| values in sorted order will create a degenerate tree, where search --| and insertion is proportional to the N instead of to Log N. If --| this pattern is common, use the Balanced_Tree function below. ---------------------------------------------------------------------------- procedure Insert_if_not_Found( --| Insert a value into a tree, provided a duplicate value is not already there V: Value_Type; --| Value to be inserted T: Tree; --| Tree to contain the new value Found: out boolean; --| Becomes True iff V already in tree Duplicate: out Value_Type --| the duplicate value, if there is one ); --| Raises: Invalid_Tree. --| Effects: Insert V into T in the proper place. If a value equal --| to V (according to the Difference function) is already contained --| in the tree, Found will be True and Duplicate will be the duplicate --| value. This might be a sequence of values with the same key, and --| V can then be added to the sequence. ---------------------------------------------------------------------------- procedure Replace_if_Found( --| Replace a value if label exists, otherwise insert it. V: Value_Type; --| Value to be inserted T: Tree; --| Tree to contain the new value Found: out boolean; --| Becomes True iff L already in tree Old_Value: out Value_Type --| the duplicate value, if there is one ); --| Raises: Invalid_Tree. --| Effects: Search for V in T. If found, replace the old value with V, --| and return Found => True, Old_Value => the old value. Otherwise, --| simply insert V into T and return Found => False. ---------------------------------------------------------------------------- procedure Destroy( --| Free space allocated to a tree. T: in out Tree --| The tree to be reclaimed. ); --| Effects: The space allocated to T is reclaimed. The space occupied by --| the values stored in T is not however, recovered. ---------------------------------------------------------------------------- generic with procedure free_Value(V: in out Value_Type) is <>; procedure Destroy_Deep( --| Free all space allocated to a tree. T: in out Tree --| The tree to be reclaimed. ); --| Effects: The space allocated to T is reclaimed. The values stored --| in T are reclaimed using Free_Value, and the tree nodes themselves --| are then reclaimed (in a single walk of the tree). ---------------------------------------------------------------------------- generic with function next_Value return Value_Type is <>; --| Each call to this procedure should return the next value to be --| inserted into the balanced tree being created. If necessary, --| this function should check that each value is greater than the --| previous one, and raise Out_of_Order if necessary. If values --| are not returned in strictly increasing order, the results are --| unpredictable. Function Balanced_Tree( Count: natural ) return Tree; --| Effects: Create a balanced tree by calling next_Value Count times. --| Each time Next_Value is called, it must return a value that compares --| greater than the preceeding value. This function is useful for balancing --| an existing tree (next_Value iterates over the unbalanced tree) or --| for creating a balanced tree when reading data from a file which is --| already sorted. ---------------------------------------------------------------------------- generic with function Copy_Value(V: Value_Type) return Value_Type is <>; --| This function is called to copy a value from the old tree to the --| new tree. Function Copy_Tree( T: Tree ) return Tree; --| Raises Invalid_Tree. --| Effects: Create a balanced tree that is a copy of the tree T. --| The exception Invalid_Tree is raised if T is not a valid tree. ---------------------------------------------------------------------------- Function Is_Empty( --| Check for an empty tree. T: Tree ) return boolean; --| Effects: Return TRUE iff T is an empty tree or if T was not initialized. ---------------------------------------------------------------------------- Function Find( --| Search a tree for a value. V: Value_Type; --| Value to be located T: Tree --| Tree to be searched ) return Value_Type; --| Raises: Not_Found, Invalid_Tree. --| Effects: Search T for a value that matches V. The matching value is --| returned. If no matching value is found, the exception Not_Found --| is raised. Procedure Find( --| Search a tree for a value. V: Value_Type; --| Value to be located T: Tree; --| Tree to be searched Found: out Boolean; --| TRUE iff a match was found Match: out Value_Type --| Matching value found in the tree ); --| Raises: Invalid_Tree; --| Effects: Search T for a value that matches V. On return, if Found is --| TRUE then the matching value is returned in Match. Otherwise, Found --| is FALSE and Match is undefined. ---------------------------------------------------------------------------- function is_Found( --| Check a tree for a value. V: Value_Type; --| Value to be located T: Tree --| Tree to be searched ) return Boolean; --| Raises: Invalid_Tree; --| Effects: Return TRUE iff V is found in T. ---------------------------------------------------------------------------- function Size( --| Return the count of values in T. T: Tree --| a tree ) return natural; --| Effects: Return the number of values stored in T. ---------------------------------------------------------------------------- generic with procedure Process(V: Value_Type) is <>; procedure Visit( T: Tree; Order: Scan_Kind ); --| Raises: Invalid_Tree; --| Effects: Invoke Process(V) for each value V in T. The nodes are visited --| in the order specified by Order. Although more limited than using --| an iterator, this function is also much faster. ---------------------------------------------------------------------------- function Make_Iter( --| Create an iterator over a tree T: Tree ) return Iterator; --| Raises: Invalid_Tree; ---------------------------------------------------------------------------- function More( --| Test for exhausted iterator I: Iterator --| The iterator to be tested ) return boolean; --| Effects: Return TRUE iff unscanned nodes remain in the tree being --| scanned by I. ---------------------------------------------------------------------------- procedure Next( --| Scan the next value in I I: in out Iterator; --| an active iterator V: out Value_Type --| Next value scanned ); --| Raises: No_More. --| Effects: Return the next value in the tree being scanned by I. --| The exception No_More is raised if there are no more values to scan. ---------------------------------------------------------------------------- private type Node; type Node_Ptr is access Node; type Node is record Value: Value_Type; Less: Node_Ptr; More: Node_Ptr; end record; type Tree_Header is record Count: natural := 0; Root: Node_Ptr := Null; end record; type Tree is access Tree_Header; type Iter_State is (Left, Middle, Right, Done); type Iterator_Record; type Iterator is access Iterator_Record; type Iterator_Record is record State: Iter_State; Parent: Iterator; subtree: Node_Ptr; end record; end binary_trees_pkg; package Bounded_String is type Variable_String (Length : positive) is private; procedure Free (The_String : in out Variable_String); procedure Append (Target : in out Variable_String; Source : in character); procedure Set (The_String : in out Variable_String; With_String : in String); procedure Copy (The_String : in out Variable_String; With_String : in String); function Image (From_The_String : in Variable_String) return String; Private void : constant natural := 0; Type Variable_String (Length : positive) is record The_Length : natural := void; The_Content : string (1..Length); end record; end Bounded_String; Package Connexions is Procedure Parse; End Connexions; With Lexical,Token_List; Use Lexical,Token_List; Package Corps_cond is First:Token_List.Object := Make((Id,Comp,Existe_Connexion,Etat_Connexion, Existe_Lien,Etat_Lien,Moins,Nbr,Vrai, Faux,Lie,Delie)); Procedure Parse; End Corps_cond; Package Definitions is Procedure Parse; End Definitions; Package Definitions_simples is Procedure Parse; End Definitions_simples; Package Def_Connexions is Procedure Parse; End Def_Connexions; Package Erreur is Erreur_Syntaxe:Exception; Procedure Parse(message:String); Function Is_Any return Boolean; End Erreur; With Lexical,Token_List; Use Lexical,Token_List; Package Etat is First:Token_List.Object := Make((Lie,Delie)); Procedure Parse; End Etat; With Lexical,Token_List; Use Lexical,Token_List; Package Expression is First:Token_List.Object := Make((Parnto,Non,Moins,Nbr,Id,Comp,Vrai,Faux)); Procedure Parse; End Expression; Package Exp_cond is Procedure Parse; End Exp_cond; Package Expression_Generale is Procedure Parse; End Expression_generale; Package Facteur is Procedure Parse; End Facteur; Package Facteur_cond is Procedure Parse; End Facteur_cond; Package Fin_Jeu is Procedure Parse; End Fin_Jeu;Package Initialisation is Procedure Parse; End Initialisation; Package Init_Complexe is Procedure Parse; End Init_Complexe; Package Init_Simple is Procedure Parse; End Init_Simple; Package Instructions is Procedure Parse; End Instructions; With Lexical,Token_List; Use Lexical,Token_List; Package Instruction_pour is First:Token_List.Object := Make(Pour); Procedure Parse; End Instruction_pour; With Lexical,Token_List; Use Lexical,Token_List; Package Instruction_si is First:Token_List.Object := Make(Si); Procedure Parse; End Instruction_si; Package Instructions_Globales is Procedure Parse; End Instructions_Globales; Package Instructions_Locales is Procedure Parse; End Instructions_Locales; With Verbs_Dictionary; Package Les_Actions is Procedure Parse (dict:Verbs_Dictionary.Object); End Les_Actions; with Text_Io, Source; package Lexical is type Token is (Comment, Nbr, Str, Id, Affect, Equ, Mul, Div, Crocho, Crochf, Parnto, Parntf, Virgul, Inf, Infequ, Diffr, Sup, Supequ, Plus, Moins, Point, Unk, Lexend, Jeu, Action, Synonyme, Definition, Structure, Chaine, Booleen, Entier, Enumere, Presentation, Objet, Avec, Init, Creer_Lien, Echanger_Lien, Etat_Lien, Liste_Lien, Existe_Lien, Detruire_Lien, Lie_Lien, Delie_Lien, Liaison, Lie, Delie, Vrai, Faux, Connexion, Creer_Connexion, Existe_Connexion, Etat_Connexion, Detruire_Connexion, Destination_Connexion, Lie_Connexion, Delie_Connexion, Afficher, Pour, Entree, Faire, Finpour, Si, Alors, Sinon, Finsi, Comp, Non, Ou, Et, Animation_Globale, Animation_Locale, Fin); subtype T_File is Text_Io.File_Type; Maxstring : constant Integer := 80; procedure Init (Nomf : String); function Get_Token return Token; function Get_Value return String; function At_End return Boolean; procedure Next; function Get_Line return Natural; function Get_Column return Natural; procedure Close; end Lexical; Package Liaisons is Procedure Parse; End Liaisons; Package Liens is Procedure Parse; End Liens; Package Liste_des_entrees is Procedure Parse; End Liste_des_entrees; With Verbs_Dictionary; Package Liste_Synonymes is Procedure Parse (dict:Verbs_Dictionary.Object); End Liste_Synonymes; Package Les_Anims_Locales is Procedure Parse; End Les_Anims_Locales; Package Les_Anims_Globales is Procedure Parse; End Les_Anims_Globales; Package Les_Definitions is Procedure Parse; End Les_Definitions; Package Les_Liaisons is Procedure Parse; End Les_Liaisons; Package Les_Presentations is Procedure Parse; End Les_Presentations; With Lexical,Token_List; Use Lexical,Token_List; Package Nombre is First:Token_List.Object := Make((Moins,Nbr)); Procedure Parse; End Nombre; Package Noms is Procedure Parse; End Noms; Package Nom_Jeu is Procedure Parse; End Nom_Jeu; Package Nom_De_Type is Procedure Parse; End Nom_De_Type; Package Nom_de_variable is Procedure Parse; End Nom_de_variable; Package Param_afficher is Procedure Parse; End Param_afficher; Package Presentations is Procedure Parse; End Presentations; With Lexical,Token_List; Use Lexical,Token_List; Package Qualificateur is First:Token_List.Object := Make(Connexion); Procedure Parse; End Qualificateur; with Text_Io; package Source is subtype T_File is Text_Io.File_Type; Eof : constant Character := Ascii.Eot; procedure Init (Nomf : String); function Value return Character; procedure Unget; function At_End return Boolean; procedure Next; function Get return Character; function Get_Line return Natural; function Get_Column return Natural; procedure Close; end Source; With Verbs_Dictionary; Package Synonymes is Procedure Parse (dict:Verbs_Dictionary.Object); End Synonymes; Package Terme is Procedure Parse; End Terme; Package Terme_cond is Procedure Parse; End Terme_cond; Package Test is Procedure Parse; End Test; With Lexical; Use Lexical; Package Token_List is type Object is private; type Tokens is array (positive range <>) of Token; Function Make (list:Tokens) return Object; Function Make (one_token:Token) return Object; Function Is_In (one_token:Token; what:Object) return Boolean; Private type Object is array(Token) of Boolean; End Token_List;With Lexical,Token_List; Use Lexical,Token_List; Package Variable is First:Token_List.Object := Make((Id,Comp)); Procedure Parse; End Variable; With Binary_Trees_Pkg,Bounded_String; Use Bounded_String; Package Verbs_Dictionary is Duplicate_Value:Exception; type Object is private; Procedure Create (dict: in out Object); Procedure Destroy (dict: in out Object); Procedure Add_New (new_verb: String; dict: Object); Procedure Add_Synonym (new_syn: String; dict: Object); Function Exist (scan_verb: String; dict: Object) return Boolean; Procedure Dump (dict: Object); Private type Verb is record Name:Variable_String(32); Source:Variable_String(32); end record; Function Compare (a,b:Verb) return Integer; Package Verbs_Tree is new Binary_Trees_Pkg (Verb,Compare); type Object is record Root:Verbs_Tree.Tree; end record; end Verbs_Dictionary