File : interpreteur_prolog.adb
1 -- Fichier INTERPRE.ADB
2 -- Corps du package de l'interpréteur PROLOG.
3 -- Algorithmes extraits de "L'ANATOMIE DE PROLOG" par Michel Van Caneghem.
4
5
6 with Text_Io; use Text_Io;
7 with Int32_Io; use Int32_Io;
8 with Objets_Prolog; use Objets_Prolog;
9 with Es_Prolog; use Es_Prolog;
10 with Infos;
11
12
13 ----------------------------------------------------------------------------------------------------------------------------------
14
15
16 package body Interpreteur_Prolog is
17
18
19 ----------------------------------------
20 -- Les chaines de caracteres constantes.
21 ----------------------------------------
22 Point : constant String := ".";
23 Virgule : constant String := ",";
24 Parenthese_Gauche_Espace : constant String := "( ";
25 Point_Virgule_Espace : constant String := "; ";
26 Parenthese_Droite : constant String := ")";
27 Espace_2points_Moins : constant String := " :-";
28 Virgule_Espace : constant String := ", ";
29 Espace_Egal_Espace : constant String := " = ";
30 Indicateur_Gele : constant String := "???";
31 Ansi_Cursor_Up : constant String := Ascii.Esc & "[1A";
32 Traits_H : constant String := "------------------------------------------------------------------------------";
33
34
35 --------------------------
36 -- Les messages constants.
37 --------------------------
38 Yes : constant String := "yes";
39 No : constant String := "no";
40 Recorded : constant String := "Recorded";
41 Illegal_Rule : constant String := "Illegal rule";
42 Titre1 : constant String := "Interpreteur PROLOG avec syntaxe 'Edimbourg'.";
43 Titre2 : constant String := "Algorithmes du PROLOG II de Marseille.";
44 Messagefin : constant String := "halt.......";
45 Chargefichier : constant String := "Loading file PROLOG.SYS...";
46 Effacechargefichier : constant String := " ";
47 Cannot_Load_Prolog_Sys : constant String := "Can't load PROLOG.SYS - Aborting...";
48 Xstorage_Error : constant String := "Not enough memory in CPU stack";
49 Xtable_Doublets_Pleine : constant String := "Not enough memory in nodes space";
50 Xtable_Symb_Pleine : constant String := "Not enough memory in names space";
51 Xtable_Var_Pleine : constant String := "Not enough memory in variables table";
52 Xpile_Subst_Pleine : constant String := "Not enough memory for substitutions";
53 Xpile_Sauve_Pleine : constant String := "Not enough memory for saving substitutions";
54 Xpile_Nomvar_Pleine : constant String := "Not enough memory for saving variables names";
55 Xpile_Eq_Pleine : constant String := "Not enough memory in equations space";
56 Xpile_Etape_Pleine : constant String := "Not enough memory in goals stack";
57 Xpile_Choix_Pleine : constant String := "Not enough memory in choices stack";
58 Xpile_Ren_Pleine : constant String := "Not enough memory for renaming variables";
59 Aborting : constant String := "Aborting current evaluation...";
60
61
62 --------------------------------------------
63 -- Les symboles utilisés par l'interpréteur.
64 --------------------------------------------
65 Liste_Vide : constant Mot := Cree_Symbole("[]");
66 Vecteur_Vide : constant Mot := Cree_Symbole("()");
67 S_Point_Virgule : constant Mot := Cree_Symbole(";");
68 S_2points_Moins : constant Mot := Cree_Symbole(":-");
69 S_Moins : constant Mot := Cree_Symbole("-");
70 S_Plus : constant Mot := Cree_Symbole("+");
71 S_Etoile : constant Mot := Cree_Symbole("*");
72 S_Slash : constant Mot := Cree_Symbole("/");
73 S_Mod : constant Mot := Cree_Symbole("mod");
74 S_Puissance : constant Mot := Cree_Symbole("^");
75 S_Regle_Predefinie : constant Mot := Cree_Symbole("internal_call");
76 S_Err : constant Mot := Cree_Symbole("err");
77 S_Fail : constant Mot := Cree_Symbole("fail");
78 S_Cut : constant Mot := Cree_Symbole("!");
79 S_Prolog_Sys : constant Mot := Cree_Symbole("PROLOG.SYS");
80 S_Abs : constant Mot := Cree_Symbole("abs");
81 S_Yes_No : constant Mot := Cree_Symbole("yes_no");
82 S_First : constant Mot := Cree_Symbole("first");
83 S_All : constant Mot := Cree_Symbole("all");
84 S_On : constant Mot := Cree_Symbole("on");
85 S_Off : constant Mot := Cree_Symbole("off");
86
87
88 ------------------------------------
89 -- Pile des substitutions (valeurs).
90 ------------------------------------
91 -- La pile des substitutions contient les valeurs des variables.
92 -- Une variable étant codée par un numéro relatif, il faut fournir la base de l'environnement courant dans PILE_SUBST pour
93 -- pouvoir accéder à la valeur correspondante : Adresse = Environnement + numéro relatif.
94
95 Taille_Pile_Subst : constant := 8100;
96 subtype Indice_Pile_Subst is Positive range 1..Taille_Pile_Subst;
97 subtype Indice_Pile_Subst_Etendu is Natural range 0..Taille_Pile_Subst;
98
99 Sp_Subst : Indice_Pile_Subst; -- Pointe sur le 1er emplacement libre.
100 Sp_Subst_Max : Indice_Pile_Subst := Indice_Pile_Subst'First;
101
102 type Type_Equation is (
103 Libre, -- La variable est libre.
104 Gele, -- La variable est rattachée à un processus gelé.
105 Lie, -- La variable est liée à un objet PROLOG (elle a une valeur).
106 Ref); -- La variable pointe sur une autre variable plus ancienne.
107
108 type P_Subst is record
109 Stype : Type_Equation;
110 Sub : Indice_Pile_Subst;
111 Ter : Mot;
112 end record;
113
114 -- SUB : Si STYPE = LIE ou GELE alors SUB = base de l'environnement des variables du terme.
115 -- Si STYPE = REF alors SUB = position absolue dans PILE_SUBST de la variable pointée.
116 -- TER : Si STYPE = LIE alors TER = l'objet PROLOG correspondant à la valeur de la variable.
117 -- Si STYPE = GELE alors TER = le processus gelé (qui est un objet PROLOG).
118
119 Sub_Vide : constant Indice_Pile_Subst := Indice_Pile_Subst'First; -- Valeur de remplissage.
120 Ter_Vide : constant Mot := Liste_Vide; -- idem.
121
122 type T_Pile_Subst is array(Indice_Pile_Subst) of P_Subst;
123 type A_Pile_Subst is access T_Pile_Subst;
124 Pile_Subst : constant A_Pile_Subst := new T_Pile_Subst;
125
126 Indice_Variable_Muette : constant Indice_Pile_Subst_Etendu := Indice_Pile_Subst_Etendu'First; -- Adresse absolue de variable '_'
127
128
129 ---------------------------------------------------
130 -- Pile de sauvegarde (restauration des variables).
131 ---------------------------------------------------
132 -- Pile associée à PILE_SUBST pour pouvoir restaurer les valeurs des variables lors d'un retour en arriere.
133
134 Taille_Pile_Sauve : constant := 5000;
135 subtype Indice_Pile_Sauve is Positive range 1..Taille_Pile_Sauve;
136 Sp_Sauve : Indice_Pile_Sauve; -- Pointe sur le 1er emplacement libre.
137 Sp_Sauve_Max : Indice_Pile_Sauve := Indice_Pile_Sauve'First;
138
139 type P_Sauve is record
140 Ptr_Pile_Subst : Indice_Pile_Subst; -- Position absolue dans PILE_SUBST pour restaurer TYPE, SUB et TER.
141 Stype : Type_Equation;
142 Sub : Indice_Pile_Subst;
143 Ter : Mot;
144 end record;
145
146 type T_Pile_Sauve is array(Indice_Pile_Sauve) of P_Sauve;
147 type A_Pile_Sauve is access T_Pile_Sauve;
148 Pile_Sauve : constant A_Pile_Sauve := new T_Pile_Sauve;
149
150
151 -------------------------------
152 -- Pile des noms des variables.
153 -------------------------------
154 -- Pile contenant les noms des variables de l'environnement initial, pour chaque niveau de driver.
155
156 Taille_Pile_Nomvar : constant := 2 * Nbre_Max_Var_Par_Regle;
157 subtype Indice_Pile_Nomvar is Positive range 1..Taille_Pile_Nomvar;
158 Sp_Nomvar : Indice_Pile_Nomvar;
159 Sp_Nomvar_Max : Indice_Pile_Nomvar := Indice_Pile_Nomvar'First;
160
161 type T_Pile_Nomvar is array(Indice_Pile_Nomvar) of Mot;
162 type A_Pile_Nomvar is access T_Pile_Nomvar;
163 Pile_Nomvar : constant A_Pile_Nomvar := new T_Pile_Nomvar;
164
165
166 --------------------------------------------------------
167 -- Pile des équations (utilisée lors de l'unification ).
168 --------------------------------------------------------
169 -- La pile de substitution permet de représenter des équations de la forme "variable = terme".
170 -- La pile des équations permet de représenter des équations de la forme "terme = terme".
171
172 Taille_Pile_Eq : constant := 5000;
173 subtype Indice_Pile_Eq is Positive range 1..Taille_Pile_Eq;
174 Sp_Eq : Indice_Pile_Eq; -- Pointe sur le 1er emplacement libre.
175 Sp_Eq_Max : Indice_Pile_Eq := Indice_Pile_Eq'First;
176
177 type P_Eq is record
178 Terme1 : Mot; -- L'objet PROLOG représentant le 1er terme
179 Env1 : Indice_Pile_Subst; -- et son environnement.
180 Terme2 : Mot; -- L'objet PROLOG représentant le 2nd terme
181 Env2 : Indice_Pile_Subst; -- et son environnement.
182 end record;
183
184 type T_Pile_Eq is array(Indice_Pile_Eq) of P_Eq;
185 type A_Pile_Eq is access T_Pile_Eq;
186 Pile_Eq : constant A_Pile_Eq := new T_Pile_Eq;
187
188
189 ------------------------------------------------------------------
190 -- Pile des étapes (contient la liste des buts restant à effacer).
191 ------------------------------------------------------------------
192
193 Taille_Pile_Etape : constant := 8000;
194 subtype Indice_Pile_Etape is Positive range 1..Taille_Pile_Etape;
195 Sp_Etape : Indice_Pile_Etape; -- Pointe juste avant le 1er emplacement libre.
196 Sp_Etape_Max : Indice_Pile_Etape := Indice_Pile_Etape'First;
197
198 type P_Etape is record
199 Reste_Sous_Buts : Mot; -- Reste des sous-buts du but courant à effacer.
200 Reste_Buts : Indice_Pile_Etape; -- Reste des buts à effacer.
201 Environnement : Indice_Pile_Subst; -- Environnement associé.
202 end record;
203
204 type T_Pile_Etape is array(Indice_Pile_Etape) of P_Etape;
205 type A_Pile_Etape is access T_Pile_Etape;
206 Pile_Etape : constant A_Pile_Etape := new T_Pile_Etape;
207
208
209 ----------------------------------------------
210 -- Pile des choix (pour le retour en arriere).
211 ----------------------------------------------
212
213 Taille_Pile_Choix : constant := 5000;
214 subtype Indice_Pile_Choix is Positive range 1..Taille_Pile_Choix;
215 Sp_Choix : Indice_Pile_Choix; -- Pointe juste avant le 1er emplacement libre.
216 Sp_Choix_Max : Indice_Pile_Choix := Indice_Pile_Choix'First;
217
218 type P_Choix is record
219 Regles_Restantes : Mot;
220 Etape_Retour : Indice_Pile_Etape;
221 Env_Retour : Indice_Pile_Subst;
222 Sauve_Retour : Indice_Pile_Sauve;
223 But_Retour : Mot;
224 Env_But_Retour : Indice_Pile_Subst;
225 Reste_Retour : Indice_Pile_Etape;
226 end record;
227
228 type T_Pile_Choix is array(Indice_Pile_Choix) of P_Choix;
229 type A_Pile_Choix is access T_Pile_Choix;
230 Pile_Choix : constant A_Pile_Choix := new T_Pile_Choix;
231
232
233 -----------------------------------
234 -- Pile de renommage des variables.
235 -----------------------------------
236
237 subtype Indice_Pile_Ren is Positive range 1..Nbre_Max_Var_Par_Regle;
238 Sp_Ren : Indice_Pile_Ren;
239 Sp_Ren_Max : Indice_Pile_Ren := Indice_Pile_Ren'First;
240
241 type T_Pile_Ren is array(Indice_Pile_Ren) of Natural;
242 type A_Pile_Ren is access T_Pile_Ren;
243 Pile_Ren : constant A_Pile_Ren := new T_Pile_Ren;
244
245
246 -----------------------------------------------
247 -- Variables globales de l'interpréteur PROLOG.
248 -----------------------------------------------
249
250 But_Courant : Mot;
251 Env_Courant : Indice_Pile_Subst;
252 Nb_Var_But : Natural;
253
254 Reste_De_Buts : Indice_Pile_Etape;
255
256 Buts_Geles : Mot; -- Vecteur des processus gelés.
257 Env_Geles : Indice_Pile_Subst; -- Environnement des processus gelés.
258
259 Liste_Regles : Mot; -- Pour PROLOG : Liste des regles rattachées à identif courant.
260
261 Env_Echec : Indice_Pile_Subst;
262
263 X, X1, X2 : Indice_Pile_Subst_Etendu; -- Utilisé par unification. Déclaré global pour économiser pile CPU.
264
265 X_Point_Y : constant Mot := Cree_Doublet_V(Cree_Variable(1),
266 Cree_Variable(2)); -- Utilisé pour relancer des processus gelés (réunion de vecteurs)
267
268 Compteur_Reponses : Natural;
269 Reponse_Affirmative : Boolean; -- C'est la réponse à la question posée.
270 Fini : Boolean;
271
272 Sp_Subst_Initial : Indice_Pile_Subst; -- Pour les appels récursifs de l'interpréteur.
273 Sp_Sauve_Initial : Indice_Pile_Sauve;
274 Sp_Nomvar_Initial : Indice_Pile_Nomvar;
275 Sp_Etape_Initial : Indice_Pile_Etape;
276 Sp_Choix_Initial : Indice_Pile_Choix;
277
278 type Fonctionnement is (Interrogation, Consultation, Reconsultation); -- Le mode de fonctionnement de l'interpréteur.
279 Mode_F : Fonctionnement;
280
281 subtype Reponse is Natural; -- Le mode de réponse de l'interpréteur.
282 Oui_Non : constant := 0;
283 Premiere_Reponse : constant := 1;
284 Toutes_Reponses : constant := Natural'Last;
285 Mode_R : Reponse;
286
287 type Mode_Ajout is (Debut, Fin); -- Pour les primitives assert, asserta et assertz.
288
289 Liste_Def : Mot := Liste_Vide; -- Liste des identifs avec une regle rattachée, dans l'ordre de saisie
290 Liste_System : Mot := Liste_Vide; -- Liste des identifs avec une regle prédéfinie rattachée (PROLOG.SYS)
291
292
293 ----------------
294 -- Informations.
295 ----------------
296
297
298 procedure Informations is
299 Taille : Integer;
300 begin
301 Taille := P_Subst'Size / 8;
302 Infos("Pile des substitutions",
303 Int32(Taille), Int32(Sp_Subst), Int32(Sp_Subst_Max),
304 Int32(Taille_Pile_Subst), Int32(Taille_Pile_Subst) * Int32(Taille));
305 Taille := P_Sauve'Size / 8;
306 Infos("Pile de sauvegarde",
307 Int32(Taille), Int32(Sp_Sauve), Int32(Sp_Sauve_Max),
308 Int32(Taille_Pile_Sauve), Int32(Taille_Pile_Sauve) * Int32(Taille));
309 Taille := Mot'Size / 8;
310 Infos("Pile des noms de variables",
311 Int32(Taille), Int32(Sp_Nomvar), Int32(Sp_Nomvar_Max),
312 Int32(Taille_Pile_Nomvar), Int32(Taille_Pile_Nomvar) * Int32(Taille));
313 Taille := P_Eq'Size / 8;
314 Infos("Pile des equations",
315 Int32(Taille), Int32(Sp_Eq), Int32(Sp_Eq_Max),
316 Int32(Taille_Pile_Eq), Int32(Taille_Pile_Eq) * Int32(Taille));
317 Taille := P_Etape'Size / 8;
318 Infos("Pile des etapes",
319 Int32(Taille), Int32(Sp_Etape), Int32(Sp_Etape_Max),
320 Int32(Taille_Pile_Etape), Int32(Taille_Pile_Etape) * Int32(Taille));
321 Taille := P_Choix'Size / 8;
322 Infos("Pile des choix",
323 Int32(Taille), Int32(Sp_Choix), Int32(Sp_Choix_Max),
324 Int32(Taille_Pile_Choix), Int32(Taille_Pile_Choix) * Int32(Taille));
325 Taille := Natural'Size / 8;
326 Infos("Pile de renommage des variables",
327 Int32(Taille), Int32(Sp_Ren), Int32(Sp_Ren_Max),
328 Int32(Nbre_Max_Var_Par_Regle), Int32(Nbre_Max_Var_Par_Regle) * Int32(Taille));
329 end Informations;
330
331
332 ---------------------------------------------
333 -- Manipulation de la pile des substitutions.
334 ---------------------------------------------
335
336
337 function Libre(Ptr : Indice_Pile_Subst) return Boolean is -- Vrai si substitution de type LIBRE.
338 begin
339 return Pile_Subst(Ptr).Stype = Libre;
340 end Libre;
341
342
343 function Gele(Ptr : Indice_Pile_Subst) return Boolean is -- Vrai si substitution de type GELE.
344 begin
345 return Pile_Subst(Ptr).Stype = Gele;
346 end Gele;
347
348
349 function Lie(Ptr : Indice_Pile_Subst) return Boolean is -- Vrai si substitution de type LIE.
350 begin
351 return Pile_Subst(Ptr).Stype = Lie;
352 end Lie;
353
354
355 function Ref(Ptr : Indice_Pile_Subst) return Boolean is -- Vrai si substitution de type REF.
356 begin
357 return Pile_Subst(Ptr).Stype = Ref;
358 end Ref;
359
360 function Stype(Ptr : Indice_Pile_Subst) return Type_Equation is -- Renvoie le champ TYPE.
361 begin
362 return Pile_Subst(Ptr).Stype;
363 end Stype;
364
365
366 function Sub(Ptr : Indice_Pile_Subst) return Indice_Pile_Subst is -- Renvoie le champ SUB.
367 begin
368 return Pile_Subst(Ptr).Sub;
369 end Sub;
370
371
372 function Ter(Ptr : Indice_Pile_Subst) return Mot is -- Renvoie le champ TER.
373 begin
374 return Pile_Subst(Ptr).Ter;
375 end Ter;
376
377
378 -----------------------------------------
379 -- Manipulation de la pile de sauvegarde.
380 -----------------------------------------
381
382
383 procedure Sauve_Subst(Ptr : Indice_Pile_Subst) is -- Sauvegarde la substitution indiquée.
384 begin
385 if Ptr < Env_Echec then
386 Pile_Sauve(Sp_Sauve) := (Ptr, Stype(Ptr), Sub(Ptr), Ter(Ptr));
387 if Sp_Sauve /= Pile_Sauve'Last then
388 Sp_Sauve := Sp_Sauve + 1;
389 if Sp_Sauve > Sp_Sauve_Max then Sp_Sauve_Max := Sp_Sauve; end if;
390 else
391 raise Pile_Sauve_Pleine;
392 end if;
393 end if;
394 end Sauve_Subst;
395
396
397 procedure Restaure_Subst is -- Restauration de la derniere substitution empilée.
398 begin
399 Sp_Sauve := Sp_Sauve - 1;
400 Pile_Subst(Pile_Sauve(Sp_Sauve).Ptr_Pile_Subst) :=
401 (Pile_Sauve(Sp_Sauve).Stype,
402 Pile_Sauve(Sp_Sauve).Sub,
403 Pile_Sauve(Sp_Sauve).Ter);
404 end Restaure_Subst;
405
406
407 -------------------------------------------------
408 -- Manipulation de la pile des noms de variables.
409 -------------------------------------------------
410
411 procedure Empile_Nomvar(Objet : Mot) is
412 begin
413 Pile_Nomvar(Sp_Nomvar) := Objet;
414 if Sp_Nomvar /= Pile_Nomvar'Last then
415 Sp_Nomvar := Sp_Nomvar + 1;
416 if Sp_Nomvar > Sp_Nomvar_Max then Sp_Nomvar_Max := Sp_Nomvar; end if;
417 else
418 raise Pile_Nomvar_Pleine;
419 end if;
420 end Empile_Nomvar;
421
422
423 function Nom_Global(Numvar : Positive) return Mot is
424 begin
425 return Pile_Nomvar(Sp_Nomvar_Initial + Numvar - 1);
426 end Nom_Global;
427
428
429 --------------------------------------
430 -- Manipulation de la pile des étapes.
431 --------------------------------------
432 -- Pas de dépilage car un retour en arriere peut faire sauter de nombreuses étapes.
433
434
435 procedure Empile_Etape(Terme : Mot; Env : Indice_Pile_Subst) is -- Empile la liste des buts restants à effacer.
436 begin
437 if Sp_Etape /= Pile_Etape'Last then
438 Sp_Etape := Sp_Etape + 1;
439 if Sp_Etape > Sp_Etape_Max then Sp_Etape_Max := Sp_Etape; end if;
440 else
441 raise Pile_Etape_Pleine;
442 end if;
443 Pile_Etape(Sp_Etape) := (Terme, Reste_De_Buts, Env);
444 Reste_De_Buts := Sp_Etape;
445 end Empile_Etape;
446
447
448 -----------------------------------------
449 -- Manipulation de la pile des équations.
450 -----------------------------------------
451
452 procedure Nouvelle_Equation(Terme1 : Mot; Env1 : Indice_Pile_Subst;
453 Terme2 : Mot; Env2 : Indice_Pile_Subst) is -- Ajoute une equation <TERME1, ENV1> = <TERME2, ENV2>
454 begin
455 Pile_Eq(Sp_Eq) := (Terme1, Env1, Terme2, Env2);
456 if Sp_Eq /= Pile_Eq'Last then
457 Sp_Eq := Sp_Eq + 1;
458 if Sp_Eq > Sp_Eq_Max then Sp_Eq_Max := Sp_Eq; end if;
459 else
460 raise Pile_Eq_Pleine;
461 end if;
462 end Nouvelle_Equation;
463
464
465 procedure Nouvelle_Liste(Objet : Mot; Env_Objet : Indice_Pile_Subst) is -- Pour la sortie des arbres infinis.
466 begin
467 Pile_Eq(Sp_Eq).Terme1 := Objet;
468 Pile_Eq(Sp_Eq).Env1 := Env_Objet;
469 if Sp_Eq /= Pile_Eq'Last then
470 Sp_Eq := Sp_Eq + 1;
471 if Sp_Eq > Sp_Eq_Max then Sp_Eq_Max := Sp_Eq; end if;
472 else
473 raise Pile_Eq_Pleine;
474 end if;
475 end Nouvelle_Liste;
476
477
478 procedure Position_Liste(Objet : in Mot; Env_Objet : in Indice_Pile_Subst;
479 Position : out Indice_Pile_Eq; Trouve : out Boolean) is
480 begin
481 Trouve := False;
482 for I in Pile_Eq'First..Sp_Eq-1 loop
483 if Egalite_Mot(Pile_Eq(I).Terme1, Objet) and then Pile_Eq(I).Env1 = Env_Objet then
484 Position := I;
485 Trouve := True;
486 return;
487 end if;
488 end loop;
489 end Position_Liste;
490
491
492 -------------------------------------
493 -- Manipulation de la pile des choix.
494 -------------------------------------
495
496 procedure Empile_Choix(Regles_Restantes : Mot;
497 Etape_Retour : Indice_Pile_Etape;
498 Env_Retour : Indice_Pile_Subst;
499 Sauve_Retour : Indice_Pile_Sauve;
500 But_Retour : Mot;
501 Env_But_Retour : Indice_Pile_Subst;
502 Reste_Retour : Indice_Pile_Etape) is
503 begin
504 if Sp_Choix /= Pile_Choix'Last then
505 Sp_Choix := Sp_Choix + 1;
506 if Sp_Choix > Sp_Choix_Max then Sp_Choix_Max := Sp_Choix; end if;
507 else
508 raise Pile_Choix_Pleine;
509 end if;
510 Pile_Choix(Sp_Choix) := (Regles_Restantes,
511 Etape_Retour,
512 Env_Retour,
513 Sauve_Retour,
514 But_Retour,
515 Env_But_Retour,
516 Reste_Retour);
517 end Empile_Choix;
518
519
520 procedure Depile_Choix(Regles_Restantes : out Mot;
521 Etape_Retour : out Indice_Pile_Etape;
522 Env_Retour : out Indice_Pile_Subst;
523 Sauve_Retour : out Indice_Pile_Sauve;
524 But_Retour : out Mot;
525 Env_But_Retour : out Indice_Pile_Subst;
526 Reste_Retour : out Indice_Pile_Etape) is
527 begin
528 Regles_Restantes := Pile_Choix(Sp_Choix).Regles_Restantes;
529 Etape_Retour := Pile_Choix(Sp_Choix).Etape_Retour;
530 Env_Retour := Pile_Choix(Sp_Choix).Env_Retour;
531 Sauve_Retour := Pile_Choix(Sp_Choix).Sauve_Retour;
532 But_Retour := Pile_Choix(Sp_Choix).But_Retour;
533 Env_But_Retour := Pile_Choix(Sp_Choix).Env_But_Retour;
534 Reste_Retour := Pile_Choix(Sp_Choix).Reste_Retour;
535 Sp_Choix := Sp_Choix - 1;
536 end Depile_Choix;
537
538
539 ----------------------------------------
540 -- Manipulation de la pile de renommage.
541 ----------------------------------------
542
543 procedure Empile_Ren(Numvar : Natural) is
544 begin
545 Pile_Ren(Sp_Ren) := Numvar;
546 if Sp_Ren /= Pile_Ren'Last then
547 Sp_Ren := Sp_Ren + 1;
548 if Sp_Ren > Sp_Ren_Max then Sp_Ren_Max := Sp_Ren; end if;
549 else
550 raise Pile_Ren_Pleine;
551 end if;
552 end Empile_Ren;
553
554
555 ----------------------------------------------------------------------------
556 -- Les routines d'écriture d'un objet PROLOG avec les valeurs des variables.
557 ----------------------------------------------------------------------------
558
559
560 procedure Rep(Terme : in out Mot; -- L'objet PROLOG.
561 Env : in out Indice_Pile_Subst; -- L'environnement associé au terme.
562 Indice : in out Indice_Pile_Subst_Etendu; -- Adresse absolue dans PILE_SUBST ou dans PILE_EQ. (ne sert que si
563 Recherche_Eq : in Boolean := True); -- TERME en sortie est une variable).
564
565
566 procedure Write(Objet : Mot; Env_Objet : Indice_Pile_Subst; Avec_Quote : Boolean) is
567
568 Position : Positive; -- Pour les arbres infinis.
569 Niveau : Positive := 1; -- Idem.
570 Trouve, Flagvar : Boolean; -- Idem.
571
572
573 -- Inclus dans WRITE.
574 procedure Write_Obj(Objet : Mot; Env_Objet : Indice_Pile_Subst);
575
576
577 -- Inclus dans WRITE.
578 procedure Write_Liste(Objet : Mot; Env_Objet : Indice_Pile_Subst) is
579 Obj : Mot := Objet;
580 Env : Indice_Pile_Subst := Env_Objet;
581 begin
582 Niveau := Niveau + 1;
583 Put('[');
584 loop
585 Flagvar := False; -- On le met à faux, mais PREMIER(OBJ) peut etre une variable.
586 Write_Obj(Premier(Obj), Env);
587 Obj := Reste(Obj);
588 Flagvar := Variable(Obj); -- Va servir pour le prochain WRITE_OBJ.
589 Rep(Obj, Env, X, False);
590 if not Doublet_L(Obj) then
591 if not Egalite_Mot(Obj, Liste_Vide) then Put('|'); Write_Obj(Obj, Env); end if;
592 exit;
593 else
594 Put(Virgule_Espace);
595 end if;
596 end loop;
597 Put(']');
598 Niveau := Niveau - 1;
599 end Write_Liste;
600
601
602 -- Inclus dans WRITE.
603 procedure Write_Vecteur(Objet : Mot; Env_Objet : Indice_Pile_Subst) is
604 Obj : Mot := Objet;
605 Env : Indice_Pile_Subst := Env_Objet;
606 begin
607 Niveau := Niveau + 1;
608 Put('(');
609 loop
610 Flagvar := False; -- On le met à faux, mais PREMIER(OBJ) peut etre une variable.
611 Write_Obj(Premier(Obj), Env);
612 Obj := Reste(Obj);
613 Rep(Obj, Env, X, False);
614 exit when not Doublet_V(Obj);
615 Put(Virgule_Espace);
616 end loop;
617 Put(')');
618 Niveau := Niveau - 1;
619 end Write_Vecteur;
620
621
622 -- Inclus dans WRITE.
623 procedure Write_Obj(Objet : Mot; Env_Objet : Indice_Pile_Subst) is
624 Obj : Mot := Objet;
625 Env : Indice_Pile_Subst := Env_Objet;
626 Sauve_Sp_Eq : Indice_Pile_Eq := Sp_Eq;
627 begin
628 Flagvar := Variable(Obj) or Flagvar;
629 Rep(Obj, Env, X, False); -- FALSE pour ne pas parcourir la pile des équations.
630 if Atome(Obj) then
631 Ecrit(Obj, Avec_Quote);
632 elsif Variable(Obj) then
633 if Gele(X) then Put(Indicateur_Gele);
634 elsif X - Sp_Subst_Initial <= Nb_Var_But then Ecrit(Nom_Global(X - Sp_Subst_Initial));
635 else Ecrit(Cree_Variable(X));
636 end if;
637 else
638 if Flagvar then
639 -- Ici OBJ est un doublet correspondant à la valeur d'une variable. Attention aux arbres infinis.
640 Position_Liste(Obj, Env, Position, Trouve);
641 if Trouve then
642 Put('*'); Ecrit(Cree_Entier(Niveau - Position));
643 goto Restaure_Sp_Eq;
644 else
645 Nouvelle_Liste(Obj, Env);
646 end if;
647 end if;
648 if Doublet_L(Obj) then Write_Liste(Obj, Env);
649 elsif Doublet_V(Obj) then Write_Vecteur(Obj, Env);
650 elsif Doublet_F(Obj) then
651 Flagvar := False; -- On le met à faux, mais PREMIER(OBJ) peut etre une variable.
652 Write_Obj(Premier(Obj), Env);
653 Obj := Reste(Obj);
654 Rep(Obj, Env, X, False);
655 if Doublet(Obj) then
656 Flagvar := False;
657 Write_Obj(Obj, Env);
658 else
659 Ecrit(Vecteur_Vide);
660 end if;
661 end if;
662 end if;
663 <<Restaure_Sp_Eq>>
664 Sp_Eq := Sauve_Sp_Eq;
665 end Write_Obj;
666
667
668 begin -- WRITE
669 Sp_Eq := Pile_Eq'First; -- Pour les arbres infinis.
670 Flagvar := False; -- On le met à faux, mais OBJET peut etre une variable.
671 Write_Obj(Objet, Env_Objet);
672 end Write;
673
674
675 function Echo_Actif return Boolean is
676 begin
677 return Echo or else Entree_Depuis_Standard;
678 end Echo_Actif;
679
680
681 procedure Imprimer_Reponse is
682 begin
683 Reponse_Affirmative := True;
684 if Mode_R /= Oui_Non and Nb_Var_But /= 0 and Echo_Actif then
685 Put("[");
686 Put(Compteur_Reponses);
687 Put("] ");
688 for I in 1..Nb_Var_But loop
689 Ecrit(Nom_Global(I));
690 Put(Espace_Egal_Espace);
691 Write(Cree_Variable(I), Sp_Subst_Initial, True); -- surround by quote
692 if I /= Nb_Var_But then Put(Virgule_Espace); end if;
693 end loop;
694 New_Line;
695 end if;
696 if Compteur_Reponses >= Mode_R then
697 -- We have reached the maximum number of solutions to display.
698 -- Maybe more solutions exist, display "..." to indicate that.
699 Put("...");
700 New_Line;
701 end if;
702 end Imprimer_Reponse;
703
704
705 ---------------------------------------------------------------------
706 -- Acces à la tete, à la queue et au nombre de variables d'une regle.
707 ---------------------------------------------------------------------
708
709
710 function Tete(Regle : Mot) return Mot is
711 begin
712 return Premier(Reste(Regle));
713 end Tete;
714
715
716 function Queue(Regle : Mot) return Mot is
717 begin
718 return Reste(Reste(Regle));
719 end Queue;
720
721
722 function Nb_Var(Regle : Mot) return Natural is
723 begin
724 return Entier_Val(Premier(Regle));
725 end Nb_Var;
726
727
728 ----------------------
729 -- Listage des regles.
730 ----------------------
731
732 procedure Listage_Queue(Queue : Mot; Indent : Positive_Count) is
733 Q : Mot := Queue;
734 begin
735 if Doublet_V(Q) then
736 loop
737 Listage_Queue(Premier(Q), Indent);
738 Q := Reste(Q);
739 exit when not Doublet_V(Q);
740 Put_Line(Virgule);
741 end loop;
742 elsif Doublet_F(Q) and then Egalite_Mot(Premier(Q), S_Point_Virgule) and then Doublet_V(Reste(Q)) then
743 Set_Col(Indent);
744 Put(Parenthese_Gauche_Espace);
745 Q := Reste(Q); -- Le vecteur des arguments de ';'
746 loop
747 Listage_Queue(Premier(Q), Indent+2);
748 New_Line;
749 Set_Col(Indent);
750 Q := Reste(Q);
751 if Doublet_V(Q) then
752 Put(Point_Virgule_Espace);
753 else
754 Put(Parenthese_Droite);
755 exit;
756 end if;
757 end loop;
758 else
759 Set_Col(Indent);
760 Ecrit(Q);
761 end if;
762 end Listage_Queue;
763
764
765 procedure Listage(Symb : Mot) is
766 Liste_Regles, Regle : Mot;
767 begin
768 if Symbole(Symb) then
769 Liste_Regles := Id_Liste_Regles(Symb);
770 while Doublet_L(Liste_Regles) loop
771 Regle := Premier(Liste_Regles);
772 Ecrit(Tete(Regle));
773 if not Egalite_Mot(Queue(Regle), Vecteur_Vide) then
774 Put_Line(Espace_2points_Moins);
775 Listage_Queue(Queue(Regle), 4);
776 end if;
777 Put_Line(Point);
778 Liste_Regles := Reste(Liste_Regles);
779 if not Doublet_L(Liste_Regles) then New_Line; end if;
780 end loop;
781 end if;
782 end Listage;
783
784
785 procedure Listing(Objet : Mot) is
786 Obj : Mot := Objet;
787 begin
788 if Symbole(Obj) then
789 Listage(Obj);
790 else
791 while Doublet_L(Obj) loop
792 Listage(Premier(Obj));
793 Obj := Reste(Obj);
794 end loop;
795 end if;
796 end Listing;
797
798
799 -------------------------------------------------
800 -- Mise à jour des regles associées à un symbole.
801 -------------------------------------------------
802
803
804 procedure Maj_Liste_Def(Identif : Mot) is
805 -- Recherche si l'identif est dans la liste des définitions.
806 Liste : Mot := Liste_Def;
807 Doublet_Precedent : Mot := Liste_Vide;
808 begin
809 while Doublet_L(Liste) loop
810 if Egalite_Mot(Premier(Liste), Identif) then return; end if;
811 Doublet_Precedent := Liste;
812 Liste := Reste(Liste);
813 end loop;
814 -- Ici DOUBLET_PRECEDENT est le dernier doublet de la liste des symboles.
815 if Egalite_Mot(Doublet_Precedent, Liste_Vide) then -- Si la liste des symboles est vide
816 Liste_Def := Cree_Liste(Identif);
817 else
818 Call(Concatene(Doublet_Precedent, Cree_Liste(Identif)));
819 end if;
820 end Maj_Liste_Def;
821
822
823 procedure Ajout_Regle(Identif : Mot; Mode_A : Mode_Ajout; Regle : Mot) is -- Rajoute la regle à la liste des regles de IDENTIF.
824 begin
825 if Doublet_L(Id_Liste_Regles(Identif)) then
826 case Mode_A is
827 when Debut =>
828 Id_Liste_Regles(Identif,
829 Cree_Doublet_L(Regle,
830 Id_Liste_Regles(Identif)));
831 when Fin =>
832 Id_Liste_Regles(Identif,
833 Concatene(Id_Liste_Regles(Identif),
834 Cree_Liste(Regle)));
835 end case;
836 else
837 Id_Liste_Regles(Identif, Cree_Liste(Regle));
838 end if;
839 Maj_Liste_Def(Identif);
840 end Ajout_Regle;
841
842
843 ---------------------------------------------
844 -- Assertion statique (en mode consultation).
845 ---------------------------------------------
846 -- Ici les variables n'ont pas de valeur associée.
847
848
849 procedure Assert_Statique(Objet : Mot; Mode_A : Mode_Ajout) is
850
851 -- Inclus dans ASSERT_STATIQUE.
852 procedure Ajout_Regle_Statique(Identif, Tete, Queue : Mot) is
853 begin
854 Ajout_Regle(Identif, Mode_A,
855 Cree_Doublet_L(Cree_Entier(Nb_Var_But),
856 Cree_Doublet_L(Tete, Queue)));
857 end Ajout_Regle_Statique;
858
859
860 -- Inclus dans ASSERT_STATIQUE.
861 function Assertion_Statique(Tete, Queue : Mot) return Boolean is
862 Obj : Mot := Tete;
863 begin
864 if Vect1(Obj) then Obj := Premier(Obj); end if; -- (expr) équivalent à expr.
865 if Symbole(Obj) then
866 Ajout_Regle_Statique(Obj, Obj, Queue);
867 return True;
868 elsif Doublet_F(Obj) then
869 declare
870 Functor : Mot := Premier(Obj);
871 begin
872 if Symbole(Functor) then
873 Ajout_Regle_Statique(Functor, Obj, Queue);
874 return True;
875 end if;
876 end;
877 end if;
878 return False;
879 end Assertion_Statique;
880
881
882 -- Inclus dans ASSERT_STATIQUE.
883 function Assertion_Statique(Objet : Mot) return Boolean is
884 Obj : Mot := Objet;
885 begin
886 if Vect1(Obj) then Obj := Premier(Obj); end if; -- (expr) équivalent à expr.
887 if Doublet_F(Obj) then
888 declare
889 Functor : Mot := Premier(Obj);
890 Arg : Mot := Reste(Obj);
891 begin
892 if Egalite_Mot(Functor, S_2points_Moins) and then Vect2(Arg) then -- Si forme :-(tete, queue).
893 return Assertion_Statique(Premier(Arg),
894 Premier(Reste(Arg)));
895 end if;
896 end;
897 end if;
898 return Assertion_Statique(Obj, Vecteur_Vide);
899 end Assertion_Statique;
900
901 begin -- ASSERT_STATIQUE
902 if Assertion_Statique(Objet) then
903 if Echo_Actif then Put_Line(Recorded); end if;
904 else
905 Put_Line(Illegal_Rule);
906 end if;
907 end Assert_Statique;
908
909
910 ---------------------------------------------------
911 -- Assertion dynamique (en cours d'interprétation).
912 ---------------------------------------------------
913 -- Ici les variables peuvent avoir des valeurs rattachées. Il faut tenir compte de la possibilité d'arbres infinis.
914
915
916 procedure Assert_Dynamique(Objet : Mot; Env_Objet : Indice_Pile_Subst; Mode_A : Mode_Ajout) is
917
918
919 -- Inclus dans ASSERT_DYNAMIQUE.
920 function Renomme(Numvar : Natural) return Natural is
921 begin
922 if Numvar = 0 then return 0; end if; -- La variable muette n'est pas renommée.
923 for I in Pile_Ren'First..Sp_Ren - 1 loop
924 if Pile_Ren(I) = Numvar then return I; end if;
925 end loop;
926 Empile_Ren(Numvar);
927 return Sp_Ren - 1;
928 end Renomme;
929
930
931 -- Inclus dans ASSERT_DYNAMIQUE.
932 function Expansion(Objet : Mot; Env_Objet : Indice_Pile_Subst) return Mot is
933 -- Renvoie l'expression OBJ apres avoir remplacé les variables par leurs valeurs.
934 begin
935 if Variable(Objet) then
936 declare
937 Obj : Mot := Objet;
938 Env : Indice_Pile_Subst := Env_Objet;
939 begin
940 Rep(Obj, Env, X);
941 if Variable(Obj) then -- Si la variable est libre.
942 return Cree_Variable(Renomme(X)); -- alors on renomme la variable.
943 else
944 return Expansion(Obj, Env);
945 end if;
946 end;
947 elsif Doublet_L(Objet) then
948 return Cree_Doublet_L(Expansion(Premier(Objet), Env_Objet),
949 Expansion(Reste(Objet), Env_Objet));
950 elsif Doublet_V(Objet) then
951 return Cree_Doublet_V(Expansion(Premier(Objet), Env_Objet),
952 Expansion(Reste(Objet), Env_Objet));
953 elsif Doublet_F(Objet) then
954 return Cree_Doublet_F(Expansion(Premier(Objet), Env_Objet),
955 Expansion(Reste(Objet), Env_Objet));
956 else
957 return Objet; -- C'est un atome.
958 end if;
959 end Expansion;
960
961
962 -- Inclus dans ASSERT_DYNAMIQUE.
963 procedure Ajout_Regle_Dynamique(Identif, Tete : Mot; Env_Tete : Indice_Pile_Subst;
964 Queue : Mot; Env_Queue : Indice_Pile_Subst) is
965 Tete_Queue : Mot;
966 begin
967 Sp_Ren := Pile_Ren'First;
968 Tete_Queue := Cree_Doublet_L(Expansion(Tete, Env_Tete),
969 Expansion(Queue, Env_Queue));
970 Ajout_Regle(Identif, Mode_A,
971 Cree_Doublet_L(Cree_Entier(Sp_Ren - 1), Tete_Queue));
972 end Ajout_Regle_Dynamique;
973
974
975 -- Inclus dans ASSERT_DYNAMIQUE.
976 function Assertion_Dynamique(Tete : Mot; Env_Tete : Indice_Pile_Subst;
977 Queue : Mot; Env_Queue : Indice_Pile_Subst) return Boolean is
978 Obj : Mot := Tete;
979 begin
980 if Vect1(Obj) then Obj := Premier(Obj); end if; -- (expr) équivalent à expr.
981 if Symbole(Obj) then
982 Ajout_Regle_Dynamique(Obj, Obj, Env_Tete, Queue, Env_Queue);
983 return True;
984 elsif Doublet_F(Obj) then
985 declare
986 Functor : Mot := Premier(Obj);
987 Env_Functor : Indice_Pile_Subst := Env_Tete;
988 begin
989 Rep(Functor, Env_Functor, X);
990 if Symbole(Functor) then
991 Ajout_Regle_Dynamique(Functor, Obj, Env_Tete, Queue, Env_Queue);
992 return True;
993 end if;
994 end;
995 end if;
996 return False;
997 end Assertion_Dynamique;
998
999
1000 -- Inclus dans ASSERT_DYNAMIQUE.
1001 function Assertion_Dynamique(Objet : Mot; Env_Objet : Indice_Pile_Subst) return Boolean is
1002 Obj : Mot := Objet;
1003 begin
1004 if Vect1(Obj) then Obj := Premier(Obj); end if; -- (expr) équivalent à expr.
1005 if Doublet_F(Obj) then
1006 declare
1007 Functor : Mot := Premier(Obj);
1008 Arg : Mot := Reste(Obj);
1009 Env_Functor, Env_Arg : Indice_Pile_Subst := Env_Objet;
1010 begin
1011 Rep(Functor, Env_Functor, X);
1012 Rep(Arg, Env_Arg, X);
1013 if Egalite_Mot(Functor, S_2points_Moins) and then Vect2(Arg) then -- Si forme :-(tete, queue).
1014 declare
1015 Tete : Mot := Premier(Arg);
1016 Queue : Mot := Premier(Reste(Arg));
1017 Env_Tete, Env_Queue : Indice_Pile_Subst := Env_Arg;
1018 begin
1019 Rep(Tete, Env_Tete, X);
1020 Rep(Queue, Env_Queue, X);
1021 return Assertion_Dynamique(Tete, Env_Tete, Queue, Env_Queue);
1022 end;
1023 end if;
1024 end;
1025 end if;
1026 return Assertion_Dynamique(Obj, Env_Objet, Vecteur_Vide, Sub_Vide);
1027 end Assertion_Dynamique;
1028
1029 begin -- ASSERT_DYNAMIQUE
1030 if Assertion_Dynamique(Objet, Env_Objet) then
1031 But_Courant := Vecteur_Vide; -- L'assertion s'est bien passée, donc le but s'efface.
1032 else
1033 But_Courant := S_Fail; -- L'assertion ne peut pas se faire, donc échec.
1034 end if;
1035 end Assert_Dynamique;
1036
1037
1038 ---------------------------
1039 -- Chargement d'un fichier.
1040 ---------------------------
1041
1042 procedure Driver(Mode_Fonctionnement : Fonctionnement; Mode_Reponse : Reponse);
1043
1044
1045 procedure Charge_Fichier(Objet : Mot; Env_Objet : Indice_Pile_Subst) is
1046 -- En entrée OBJET est une liste.
1047 Liste : Mot := Objet;
1048 Env_Liste : Indice_Pile_Subst := Env_Objet;
1049 Fichier_Courant : Mot;
1050 Env_Fichier_Courant : Indice_Pile_Subst;
1051 Mode_F : Fonctionnement;
1052 begin
1053 But_Courant := Vecteur_Vide; -- A priori on considere que ce but va s'effacer.
1054 while Doublet_L(Liste) and not Egalite_Mot(But_Courant, S_Fail) loop
1055 Fichier_Courant := Premier(Liste);
1056 Env_Fichier_Courant := Env_Liste;
1057 Rep(Fichier_Courant, Env_Fichier_Courant, X);
1058 Mode_F := Consultation; -- Mode consultation si [fichier...].
1059 if Func1(Fichier_Courant) and then Egalite_Mot(Premier(Fichier_Courant), S_Moins) then
1060 Fichier_Courant := Premier(Reste(Fichier_Courant)); -- L'argument du moins unaire.
1061 Rep(Fichier_Courant, Env_Fichier_Courant, X);
1062 Mode_F := Reconsultation; -- Mode reconsultation si [-fichier...].
1063 end if;
1064 if Symbole(Fichier_Courant) then
1065 if Entree_Fichier(Fichier_Courant) then
1066 Driver(Mode_F, Oui_Non);
1067 Entree_Standard;
1068 else
1069 But_Courant := S_Fail;
1070 end if;
1071 else
1072 But_Courant := S_Fail;
1073 end if;
1074 Liste := Reste(Liste); -- Passe au fichier suivant.
1075 end loop;
1076 end Charge_Fichier;
1077
1078
1079 -----------------
1080 -- L'unification.
1081 -----------------
1082
1083
1084 procedure Rep(Terme : in out Mot; -- L'objet PROLOG.
1085 Env : in out Indice_Pile_Subst; -- L'environnement associé au terme.
1086 Indice : in out Indice_Pile_Subst_Etendu; -- Adresse absolue dans PILE_SUBST ou dans PILE_EQ. (ne sert que si
1087 Recherche_Eq : in Boolean := True) is -- TERME en sortie est une variable).
1088 begin
1089 if Variable(Terme) then
1090 if Variable_Rang(Terme) = 0 then -- Si variable muette '_'
1091 Indice := Indice_Variable_Muette; -- Cet indice se situe en dehors de l'étendue de PILE_SUBST.
1092 return;
1093 end if;
1094 Indice := Env + Variable_Rang(Terme);
1095 while Ref(Indice) loop Indice := Sub(Indice); end loop;
1096 if Lie(Indice) then -- Si INDICE pointe sur une liaison à un objet PROLOG alors
1097 Env := Sub(Indice); -- fait pointer ENV et TERME sur l'objet lié.
1098 Terme := Ter(Indice);
1099 end if;
1100 end if;
1101 if not Recherche_Eq then return; end if;
1102 if Doublet(Terme) then
1103 for I in Pile_Eq'First..Sp_Eq-1 loop
1104 if Egalite_Mot(Terme, Pile_Eq(I).Terme1) and Env = Pile_Eq(I).Env1 then
1105 Terme := Pile_Eq(I).Terme2;
1106 Env := Pile_Eq(I).Env2;
1107 end if;
1108 end loop;
1109 end if;
1110 end Rep;
1111
1112
1113 procedure Relancer(Buts : in out Mot;
1114 Env_Buts : in out Indice_Pile_Subst;
1115 Subst : in Indice_Pile_Subst) is -- Construit la liste des processus à relancer.
1116 begin
1117 if not Egalite_Mot(Buts, Vecteur_Vide) then
1118 if Pile_Subst'Last - Sp_Subst < 2 then
1119 raise Pile_Subst_Pleine;
1120 else
1121 Pile_Subst(Sp_Subst) := (Lie, Env_Buts, Buts); -- Variable 1 de l'environnement.
1122 Pile_Subst(Sp_Subst + 1) := (Lie, Sub(Subst), Ter(Subst)); -- Variable 2 de l'environnement.
1123 Buts := X_Point_Y;
1124 Env_Buts := Sp_Subst - 1; -- Pour respecter convention '/'
1125 Sp_Subst := Sp_Subst + 2;
1126 if Sp_Subst > Sp_Subst_Max then Sp_Subst_Max := Sp_Subst; end if;
1127 end if;
1128 else
1129 Buts := Ter(Subst);
1130 Env_Buts := Sub(Subst);
1131 end if;
1132 end Relancer;
1133
1134
1135 function Unifiable(Terme1 : in Mot; Env1 : in Indice_Pile_Subst;
1136 Terme2 : in Mot; Env2 : in Indice_Pile_Subst) return Boolean is
1137 Pas_Unifiable : exception; -- Retour brutal des qu'on sait qu'on ne peut pas unifier.
1138
1139 procedure Unifier(Terme1 : in Mot; Env1 : in Indice_Pile_Subst;
1140 Terme2 : in Mot; Env2 : in Indice_Pile_Subst) is
1141 T1 : Mot := Terme1;
1142 E1 : Indice_Pile_Subst := Env1;
1143 T2 : Mot := Terme2;
1144 E2 : Indice_Pile_Subst := Env2;
1145 begin
1146 loop
1147 Rep(T1, E1, X1);
1148 Rep(T2, E2, X2);
1149 if Variable(T1) then
1150 if Variable(T2) then
1151 -- Ici X1 et X2 sont des pointeurs dans PILE_SUBST.
1152 if X1 = Indice_Variable_Muette
1153 or else X2 = Indice_Variable_Muette then
1154 return;
1155 end if;
1156 if X1 = X2 then return; end if; -- X = X toujours effacé.
1157 if X2 < X1 then
1158 X := X1; X1 := X2; X2 := X; -- Ordre chronologique (important pour éviter les bouclages).
1159 end if;
1160 Sauve_Subst(X2);
1161 if Gele(X2) then Relancer(Buts_Geles, Env_Geles, X2); end if;
1162 Pile_Subst(X2) := (Ref, X1, Ter_Vide); -- Fait pointer la variable la plus récente vers la plus ancienne.
1163 return;
1164 else
1165 -- Ici T1 est une variable mais pas T2. X1 est un pointeur dans PILE_SUBST.
1166 if X1 /= Indice_Variable_Muette then
1167 Sauve_Subst(X1);
1168 if Gele(X1) then Relancer(Buts_Geles, Env_Geles, X1); end if;
1169 Pile_Subst(X1) := (Lie, E2, T2); -- Rattache la valeur à la variable.
1170 end if;
1171 return;
1172 end if;
1173 elsif Variable(T2) then
1174 -- Ici T2 est une variable, mais pas T1. X2 est un pointeur dans PILE_SUBST.
1175 if X2 /= Indice_Variable_Muette then
1176 Sauve_Subst(X2);
1177 if Gele(X2) then Relancer(Buts_Geles, Env_Geles, X2); end if;
1178 Pile_Subst(X2) := (Lie, E1, T1); -- Rattache la valeur à la variable.
1179 end if;
1180 return;
1181 -- A partir d'ici aucun des termes n'est une variable.
1182 elsif E1 = E2 and then Egalite_Mot(T1, T2) then
1183 return; -- Egalité stricte.
1184 elsif Atome(T1) and then Egalite_Mot(T1, T2) then
1185 return; -- Si T1 et T2 atomes, l'environnement n'a pas d'importance.
1186 else
1187 if (Doublet_L(T1) and Doublet_L(T2)) or else
1188 (Doublet_V(T1) and Doublet_V(T2)) or else
1189 (Doublet_F(T1) and Doublet_F(T2)) then
1190 Nouvelle_Equation(T1, E1, T2, E2);
1191 Unifier(Premier(T1), E1, Premier(T2), E2);
1192 T1 := Reste(T1);
1193 T2 := Reste(T2);
1194 else
1195 raise Pas_Unifiable; -- Echec, retour brutal.
1196 end if;
1197 end if;
1198 end loop;
1199 end Unifier;
1200
1201 begin -- UNIFIABLE
1202 Sp_Eq := Pile_Eq'First; -- Vide la pile des equations.
1203 Unifier(Terme1, Env1, Terme2, Env2);
1204 Sp_Eq := Pile_Eq'First; -- La pile des équations ne sert plus, une fois l'unification réalisée
1205 return True;
1206 exception
1207 when Pas_Unifiable => Sp_Eq := Pile_Eq'First; -- Meme remarque.
1208 return False;
1209 end Unifiable;
1210
1211
1212 --------------------
1213 -- Le moteur PROLOG.
1214 --------------------
1215
1216
1217 procedure Regles_Accessibles(Objet : Mot; Env_Objet : Indice_Pile_Subst) is
1218 -- En entrée OBJET est soit un atome, soit une fonction.
1219 Obj : Mot := Objet;
1220 Env : Indice_Pile_Subst := Env_Objet;
1221 begin
1222 if Symbole(Obj) then
1223 Liste_Regles := Id_Liste_Regles(Obj);
1224 elsif Doublet_F(Obj) then
1225 Obj := Premier(Obj); -- Le functor
1226 if Variable(Obj) then Rep(Obj, Env, X); end if; -- Si forme X(...)
1227 if Symbole(Obj) then
1228 Liste_Regles := Id_Liste_Regles(Obj);
1229 else
1230 Liste_Regles := Liste_Vide;
1231 end if;
1232 else -- Si OBJ est un entier
1233 Liste_Regles := Liste_Vide;
1234 end if;
1235 end Regles_Accessibles;
1236
1237
1238 procedure Regle_Predefinie(Num_Regle : Mot; Env_Regle : Indice_Pile_Subst);
1239
1240
1241 function Avancer return Boolean is
1242 begin
1243 loop
1244 if Egalite_Mot(But_Courant, Vecteur_Vide) then
1245 if Reste_De_Buts = Sp_Etape_Initial then
1246 return False;
1247 else
1248 But_Courant := Pile_Etape(Reste_De_Buts).Reste_Sous_Buts;
1249 Env_Courant := Pile_Etape(Reste_De_Buts).Environnement;
1250 Reste_De_Buts := Pile_Etape(Reste_De_Buts).Reste_Buts;
1251 end if;
1252 end if;
1253 if Variable(But_Courant) then
1254 Rep(But_Courant, Env_Courant, X);
1255 end if;
1256 while Doublet_V(But_Courant) loop
1257 if not Egalite_Mot(Reste(But_Courant), Vecteur_Vide) then
1258 Empile_Etape(Reste(But_Courant), Env_Courant);
1259 end if;
1260 But_Courant := Premier(But_Courant);
1261 if Variable(But_Courant) then
1262 Rep(But_Courant, Env_Courant, X);
1263 end if;
1264 end loop;
1265 if Doublet_L(But_Courant) then
1266 Charge_Fichier(But_Courant, Env_Courant);
1267 elsif Egalite_Mot(But_Courant, S_Cut) then -- Le cut
1268 But_Courant := Vecteur_Vide;
1269 Sp_Choix := Sub(Env_Courant);
1270 if Sp_Choix /= Sp_Choix_Initial and then
1271 Pile_Choix(Sp_Choix).Env_Retour = Env_Courant then -- Tient compte du fait que le choix à supprimer peut etre
1272 Sp_Choix := Sp_Choix -1; -- au niveau de la regle contenant le cut.
1273 end if;
1274 elsif Doublet_F(But_Courant) and then
1275 Egalite_Mot(Premier(But_Courant), S_Regle_Predefinie) and then
1276 Vect1(Reste(But_Courant)) then -- Si forme internal_call(arg).
1277 Regle_Predefinie(Premier(Reste(But_Courant)), Env_Courant);
1278 else -- Ici BUT_COURANT est soit un atome, soit une fonction.
1279 Regles_Accessibles(But_Courant, Env_Courant);
1280 return True;
1281 end if;
1282 end loop;
1283 end Avancer;
1284
1285
1286 procedure Preparer_Unification(Liste_Regles : in Mot;
1287 Nouvel_Env : out Indice_Pile_Subst;
1288 Tete_Regle : out Mot;
1289 Base_Pile_Sauve : out Indice_Pile_Sauve) is
1290 Nbre_Var : Natural;
1291 begin
1292 Tete_Regle := Tete(Premier(Liste_Regles));
1293 Nbre_Var := Nb_Var(Premier(Liste_Regles));
1294 Nouvel_Env := Sp_Subst;
1295 if Pile_Subst'Last - Sp_Subst < 1 + Nbre_Var then
1296 raise Pile_Subst_Pleine;
1297 else
1298 Sp_Subst := Sp_Subst + 1 + Nbre_Var;
1299 if Sp_Subst > Sp_Subst_Max then Sp_Subst_Max := Sp_Subst; end if;
1300 end if;
1301 for I in 1..Nbre_Var loop
1302 Pile_Subst(Nouvel_Env + I) := (Libre, Sub_Vide, Ter_Vide);
1303 end loop;
1304 Base_Pile_Sauve := Sp_Sauve;
1305 if Egalite_Mot(Reste(Liste_Regles), Liste_Vide) then
1306 Env_Echec := Pile_Choix(Sp_Choix).Env_Retour;
1307 else
1308 Env_Echec := Nouvel_Env;
1309 end if;
1310 Buts_Geles := Vecteur_Vide;
1311 end Preparer_Unification;
1312
1313
1314 procedure Effacer_Suite_De_Buts is
1315 Base_Pile_Sauve : Indice_Pile_Sauve;
1316 Env_Regle : Indice_Pile_Subst;
1317 Tete_Regle : Mot;
1318 begin
1319 if not Avancer then
1320 -- Si la suite des buts initiaux ne comportait que des regles prédéfinies, alors elles ont été effacés directement depuis
1321 -- AVANCER. BUT_COURANT va nous indiquer si les buts ont pu etre effacés.
1322 Reponse_Affirmative := (But_Courant = Vecteur_Vide);
1323 return;
1324 end if;
1325 loop
1326 loop
1327 if Egalite_Mot(Liste_Regles, Liste_Vide) then goto Backtracking; end if;
1328 Preparer_Unification(Liste_Regles, Env_Regle, Tete_Regle, Base_Pile_Sauve);
1329 while not Unifiable(But_Courant, Env_Courant, Tete_Regle, Env_Regle) loop
1330 while Sp_Sauve /= Base_Pile_Sauve loop Restaure_Subst; end loop;
1331 Sp_Subst := Env_Regle;
1332 Liste_Regles := Reste(Liste_Regles);
1333 if Egalite_Mot(Liste_Regles, Liste_Vide) then goto Backtracking; end if;
1334 Preparer_Unification(Liste_Regles, Env_Regle, Tete_Regle, Base_Pile_Sauve);
1335 end loop;
1336 if not Egalite_Mot(Reste(Liste_Regles), Liste_Vide) then
1337 Empile_Choix(Reste(Liste_Regles),
1338 Sp_Etape,
1339 Env_Regle,
1340 Base_Pile_Sauve,
1341 But_Courant,
1342 Env_Courant,
1343 Reste_De_Buts);
1344 end if;
1345 Pile_Subst(Env_Regle) := (Libre, Sp_Choix, Liste_Regles); -- Attention à SP_CHOIX
1346 if not Egalite_Mot(Buts_Geles, Vecteur_Vide) then
1347 But_Courant := Buts_Geles;
1348 Env_Courant := Env_Geles;
1349 if not Egalite_Mot(Queue(Premier(Liste_Regles)), Vecteur_Vide) then
1350 Empile_Etape(Queue(Premier(Liste_Regles)), Env_Regle);
1351 end if;
1352 else
1353 But_Courant := Queue(Premier(Liste_Regles));
1354 Env_Courant := Env_Regle;
1355 end if;
1356 exit when not Avancer;
1357 end loop;
1358 ---------------------------
1359 -- Affichage de la réponse.
1360 ---------------------------
1361 Compteur_Reponses := Compteur_Reponses + 1;
1362 Imprimer_Reponse;
1363 if Compteur_Reponses >= Mode_R then return; end if;
1364 ---------------------
1365 -- Retour en arriere.
1366 ---------------------
1367 <<Backtracking>>
1368 if Sp_Choix = Sp_Choix_Initial then return;
1369 else
1370 Depile_Choix(Liste_Regles,
1371 Sp_Etape,
1372 Sp_Subst,
1373 Base_Pile_Sauve,
1374 But_Courant,
1375 Env_Courant,
1376 Reste_De_Buts);
1377 while Sp_Sauve /= Base_Pile_Sauve loop Restaure_Subst; end loop;
1378 end if;
1379 end loop;
1380 end Effacer_Suite_De_Buts;
1381
1382
1383 procedure Effacer(Expression : in Mot; Nb_Var : in Natural) is
1384 -- Sauve les variables globales de l'interpréteur.
1385 Sauve_But_Courant : Mot := But_Courant;
1386 Sauve_Env_Courant : Indice_Pile_Subst := Env_Courant;
1387 Sauve_Nb_Var_But : Natural := Nb_Var_But;
1388 Sauve_Reste_De_Buts : Indice_Pile_Etape := Reste_De_Buts;
1389 Sauve_Buts_Geles : Mot := Buts_Geles;
1390 Sauve_Env_Geles : Indice_Pile_Subst := Env_Geles;
1391 Sauve_Liste_Regles : Mot := Liste_Regles;
1392 Sauve_Env_Echec : Indice_Pile_Subst := Env_Echec;
1393 Sauve_Reponse_Affirmative : Boolean := Reponse_Affirmative;
1394 -- Sauve les pointeurs des différentes piles (sauf PILE_EQ qui est une pile temporaire).
1395 Sauve_Sp_Subst : Indice_Pile_Subst := Sp_Subst;
1396 Sauve_Sp_Sauve : Indice_Pile_Sauve := Sp_Sauve;
1397 Sauve_Sp_Etape : Indice_Pile_Etape := Sp_Etape;
1398 Sauve_Sp_Choix : Indice_Pile_Choix := Sp_Choix;
1399 -- Sauve les pointeurs de base initiaux des différentes piles. (Sauf PILE_EQ qui est une pile temporaire).
1400 Sauve_Sp_Subst_Initial : Indice_Pile_Subst := Sp_Subst_Initial;
1401 Sauve_Sp_Sauve_Initial : Indice_Pile_Sauve := Sp_Sauve_Initial;
1402 Sauve_Sp_Etape_Initial : Indice_Pile_Etape := Sp_Etape_Initial;
1403 Sauve_Sp_Choix_Initial : Indice_Pile_Choix := Sp_Choix_Initial;
1404 begin
1405 -- Initialise les nouveaux pointeurs de base initiaux.
1406 Sp_Subst_Initial := Sp_Subst;
1407 Sp_Sauve_Initial := Sp_Sauve;
1408 Sp_Etape_Initial := Sp_Etape;
1409 Sp_Choix_Initial := Sp_Choix;
1410 -- Initialise certaines variables globales de l'interpréteur.
1411 But_Courant := Expression; -- Le vecteur des buts à effacer.
1412 Nb_Var_But := Nb_Var; -- Le nombre de variables dans cette suite de buts.
1413 Reste_De_Buts := Sp_Etape_Initial;
1414 Reponse_Affirmative := False;
1415 -- Préparation de l'environnement.
1416 Env_Courant := Sp_Subst;
1417 if Pile_Subst'Last - Sp_Subst < 1 + Nb_Var_But then
1418 raise Pile_Subst_Pleine;
1419 else
1420 Pile_Subst(Sp_Subst) := (Libre, Sp_Choix_Initial, Liste_Vide); -- Attention à SP_CHOIX_INITIAL.
1421 for I in 1..Nb_Var_But loop
1422 Pile_Subst(Sp_Subst + I) := (Libre, Sub_Vide, Ter_Vide);
1423 end loop;
1424 Sp_Subst := Sp_Subst + 1 + Nb_Var_But;
1425 if Sp_Subst > Sp_Subst_Max then Sp_Subst_Max := Sp_Subst; end if;
1426 end if;
1427 -- Effacement des buts saisis.
1428 Effacer_Suite_De_Buts;
1429 if not Fini and Echo_Actif then
1430 if Reponse_Affirmative then Put_Line(Yes); else Put_Line(No); end if;
1431 end if;
1432 -- Restaure les variables globales de l'interpréteur.
1433 But_Courant := Sauve_But_Courant;
1434 Env_Courant := Sauve_Env_Courant;
1435 Nb_Var_But := Sauve_Nb_Var_But;
1436 Reste_De_Buts := Sauve_Reste_De_Buts;
1437 Buts_Geles := Sauve_Buts_Geles;
1438 Env_Geles := Sauve_Env_Geles;
1439 Liste_Regles := Sauve_Liste_Regles;
1440 Env_Echec := Sauve_Env_Echec;
1441 Reponse_Affirmative := Sauve_Reponse_Affirmative;
1442 -- Restaure les pointeurs des différentes piles.
1443 Sp_Subst := Sauve_Sp_Subst;
1444 Sp_Sauve := Sauve_Sp_Sauve;
1445 Sp_Etape := Sauve_Sp_Etape;
1446 Sp_Choix := Sauve_Sp_Choix;
1447 -- Restaure les pointeurs de base initiaux.
1448 Sp_Subst_Initial := Sauve_Sp_Subst_Initial;
1449 Sp_Sauve_Initial := Sauve_Sp_Sauve_Initial;
1450 Sp_Etape_Initial := Sauve_Sp_Etape_Initial;
1451 Sp_Choix_Initial := Sauve_Sp_Choix_Initial;
1452 end Effacer;
1453
1454
1455 --------------------------
1456 -- Les regles prédéfinies.
1457 --------------------------
1458 -- REMARQUE IMPORTANTE : Toutes les regles prédéfinies sont appelées par :
1459 -- regle(X1...Xn) :- internal_call(num).
1460 -- Donc les arguments sont dans PILE_SUBST lors de l'effacement de internal_call(num).
1461
1462
1463 function Eval(Expr : Mot; Env_Expr : Indice_Pile_Subst) return Mot is
1464 Erreur_Evaluation : exception;
1465 type Func1arg is (V_Abs, Moins_Unaire, Div_Unaire);
1466 type Func2arg is (Modulo, Puissance);
1467 type Funcnarg is (Plus, Moins, Mult, Div);
1468
1469 function Evaluation(Expression : Mot; Env_Expression : Indice_Pile_Subst) return Mot;
1470
1471 function Apply1(Func : Func1arg; Args : Mot; Env_Args : Indice_Pile_Subst) return Mot is
1472 Arg : Mot_Valeur;
1473 begin
1474 if not Vect1(Args) then raise Erreur_Evaluation; end if;
1475 Arg := Entier_Val(Evaluation(Premier(Args), Env_Args));
1476 case Func is
1477 when V_Abs => Arg := abs Arg;
1478 when Moins_Unaire => Arg := -Arg;
1479 when Div_Unaire => Arg := 1 / Arg;
1480 end case;
1481 return Cree_Entier(Arg);
1482 end Apply1;
1483
1484 function Apply2(Func : Func2arg; Args : Mot; Env_Args : Indice_Pile_Subst) return Mot is
1485 Arg1, Arg2 : Mot_Valeur;
1486 begin
1487 if not Vect2(Args) then raise Erreur_Evaluation; end if;
1488 Arg1 := Entier_Val(Evaluation(Premier(Args), Env_Args));
1489 Arg2 := Entier_Val(Evaluation(Premier(Reste(Args)), Env_Args));
1490 case Func is
1491 when Modulo => Arg1 := Arg1 mod Arg2;
1492 when Puissance => Arg1 := Arg1 ** Arg2;
1493 end case;
1494 return Cree_Entier(Arg1);
1495 end Apply2;
1496
1497 function Apply(Func : Funcnarg; Args : Mot; Env_Args : Indice_Pile_Subst; Initial : Mot_Valeur) return Mot is
1498 Passe1 : Boolean := True;
1499 Result : Mot_Valeur := Initial;
1500 Vectarg : Mot := Args;
1501
1502 function Next return Mot_Valeur is
1503 V : Mot_Valeur := Entier_Val(Evaluation(Premier(Vectarg), Env_Args));
1504 begin
1505 Passe1 := False;
1506 Vectarg := Reste(Vectarg);
1507 return V;
1508 end Next;
1509
1510 begin -- APPLY
1511 case Func is
1512 when Plus =>
1513 while Doublet_V(Vectarg) loop Result := Result + Next; end loop;
1514 when Moins =>
1515 while Doublet_V(Vectarg) loop
1516 if Passe1 then Result := Next; else Result := Result - Next; end if;
1517 end loop;
1518 when Mult =>
1519 while Doublet_V(Vectarg) loop Result := Result * Next; end loop;
1520 when Div =>
1521 while Doublet_V(Vectarg) loop
1522 if Passe1 then Result := Next; else Result := Result / Next; end if;
1523 end loop;
1524 end case;
1525 return Cree_Entier(Result);
1526 end Apply;
1527
1528 function Evaluation(Expression : Mot; Env_Expression : Indice_Pile_Subst) return Mot is
1529 Func, Args : Mot;
1530 Expr : Mot := Expression;
1531 Env_Expr : Indice_Pile_Subst := Env_Expression;
1532 begin
1533 if Vect1(Expr) then Expr := Premier(Expr); end if;
1534 if Variable(Expr) then Rep(Expr, Env_Expr, X); end if;
1535 if Entier(Expr) then
1536 return Expr;
1537 elsif Doublet_F(Expr) then
1538 Func := Premier(Expr);
1539 Args := Reste(Expr);
1540 if Egalite_Mot(Func, S_Plus) then
1541 return Apply(Plus, Args, Env_Expr, 0);
1542 elsif Egalite_Mot(Func, S_Moins) then
1543 if Vect1(Args) then return Apply1(Moins_Unaire, Args, Env_Expr);
1544 else return Apply(Moins, Args, Env_Expr, 0);
1545 end if;
1546 elsif Egalite_Mot(Func, S_Etoile) then
1547 return Apply(Mult, Args, Env_Expr, 1);
1548 elsif Egalite_Mot(Func, S_Slash) then
1549 if Vect1(Args) then return Apply1(Div_Unaire, Args, Env_Expr);
1550 else return Apply(Div, Args, Env_Expr, 1);
1551 end if;
1552 elsif Egalite_Mot(Func, S_Mod) then
1553 return Apply2(Modulo, Args, Env_Expr);
1554 elsif Egalite_Mot(Func, S_Puissance) then
1555 return Apply2(Puissance, Args, Env_Expr);
1556 elsif Egalite_Mot(Func, S_Abs) then
1557 return Apply1(V_Abs, Args, Env_Expr);
1558 else
1559 raise Erreur_Evaluation;
1560 end if;
1561 else
1562 raise Erreur_Evaluation;
1563 end if;
1564 end Evaluation;
1565
1566 begin -- EVAL
1567 return Evaluation(Expr, Env_Expr);
1568 exception
1569 when Erreur_Evaluation | Numeric_Error => return S_Err;
1570 end Eval;
1571
1572
1573 procedure Regle_Predefinie(Num_Regle : Mot; Env_Regle : Indice_Pile_Subst) is
1574 Subst: Indice_Pile_Subst;
1575 Arg1 : Mot := Cree_Variable(1);
1576 Arg2 : Mot := Cree_Variable(2);
1577 Env_Arg1, Env_Arg2 : Indice_Pile_Subst := Env_Regle;
1578
1579 procedure Put_Arg(Num_Arg : Positive; Substitution : P_Subst) is
1580 Resultat : Mot := Cree_Variable(Num_Arg);
1581 Env_Resultat : Indice_Pile_Subst := Env_Regle;
1582 begin
1583 Rep(Resultat, Env_Resultat, X);
1584 if Variable(Resultat) then
1585 Sauve_Subst(X);
1586 if Gele(X) then Relancer(But_Courant, Env_Courant, X); end if;
1587 Pile_Subst(X) := Substitution;
1588 else -- Ici la variable est liée à une valeur.
1589 if Substitution.Stype = Ref or else
1590 (Substitution.Stype = Lie and then not Egalite_Mot(Resultat, Substitution.Ter)) then
1591 But_Courant := S_Fail;
1592 end if;
1593 end if;
1594 end Put_Arg;
1595
1596 begin
1597 But_Courant := Vecteur_Vide; -- A priori, on suppose que regle s'efface
1598 if not Entier(Num_Regle) then
1599 But_Courant := S_Fail;
1600 return;
1601 end if;
1602 case Entier_Val(Num_Regle) is
1603 -------------------- Controle de l'interpréteur -----------------------
1604 when 0 => -- answer(X)
1605 Rep(Arg1, Env_Arg1, X);
1606 if Variable(Arg1) then
1607 case Mode_R is
1608 when Oui_Non => Arg1 := S_Yes_No;
1609 when Premiere_Reponse => Arg1 := S_First;
1610 when Toutes_Reponses => Arg1 := S_All;
1611 when others => Arg1 := Cree_Entier(Mode_R);
1612 end case;
1613 Put_Arg(1, (Lie, Sub_Vide, Arg1)); -- Pas besoin d'env. pour atome.
1614 elsif Egalite_Mot(Arg1, S_Yes_No) then
1615 Mode_R := Oui_Non;
1616 elsif Egalite_Mot(Arg1, S_First) then
1617 Mode_R := Premiere_Reponse;
1618 elsif Egalite_Mot(Arg1, S_All) then
1619 Mode_R := Toutes_Reponses;
1620 elsif Entier(Arg1) and Entier_Val(Arg1) >= 0 then
1621 Mode_R := Entier_Val(Arg1);
1622 else
1623 But_Courant := S_Fail;
1624 end if;
1625 when 1 => -- true
1626 null; -- true s'efface toujours.
1627 when 2 => -- statistics
1628 New_Line;
1629 Objets_Prolog.Types_Informations;
1630 Put_Line(Traits_H);
1631 Put('|'); Set_Col(38); Put('|'); Put("TAILLE "); Put('|'); Put("POSITION"); Put('|'); Put("COURANT"); Put('|');
1632 Put(" MAXI "); Put('|'); Put("MEMOIRE"); Put('|'); New_Line;
1633 Put('|'); Set_Col(38); Put('|'); Put("ELEMENT"); Put('|'); Put("COURANTE"); Put('|'); Put(" MAXI "); Put('|');
1634 Put("ALLOUE"); Put('|'); Put("ALLOUEE"); Put('|'); New_Line;
1635 Put_Line(Traits_H);
1636 Objets_Prolog.Informations;
1637 Es_Prolog.Informations;
1638 Interpreteur_Prolog.Informations;
1639 Put_Line(Traits_H);
1640 New_Line;
1641 --------------------- Les prédicats d'écriture ------------------------
1642 when 10 => -- write(X)
1643 Rep(Arg1, Env_Arg1, X);
1644 Write(Arg1, Env_Arg1, False); -- free variables denoted by name, strings not surrounded by quotes
1645 when 11 => -- display(X)
1646 Rep(Arg1, Env_Arg1, X);
1647 Ecrit(Arg1, True); -- free variables denoted by number, strings surrounded by quotes
1648 when 12 => -- nl
1649 New_Line;
1650 --------------- Les prédicats de reconnaissance de type ---------------
1651 when 20 => -- atom(X)
1652 Rep(Arg1, Env_Arg1, X);
1653 if not Symbole(Arg1) then
1654 But_Courant := S_Fail;
1655 end if;
1656 when 21 => -- integer(X)
1657 Rep(Arg1, Env_Arg1, X);
1658 if not Entier(Arg1) then
1659 But_Courant := S_Fail;
1660 end if;
1661 when 22 => -- atomic(X)
1662 Rep(Arg1, Env_Arg1, X);
1663 if not Atome(Arg1) then
1664 But_Courant := S_Fail;
1665 end if;
1666 when 23 => -- var(X)
1667 Rep(Arg1, Env_Arg1, X);
1668 if not Variable(Arg1) then
1669 But_Courant := S_Fail;
1670 end if;
1671 when 24 => --list(X)
1672 Rep(Arg1, Env_Arg1, X);
1673 if not (Doublet_L(Arg1) or else Egalite_Mot(Arg1, Liste_Vide)) then
1674 But_Courant := S_Fail;
1675 end if;
1676 when 25 => -- vector(X)
1677 Rep(Arg1, Env_Arg1, X);
1678 if not (Doublet_V(Arg1) or else Egalite_Mot(Arg1, Vecteur_Vide)) then
1679 But_Courant := S_Fail;
1680 end if;
1681 when 26 => -- function(X)
1682 Rep(Arg1, Env_Arg1, X);
1683 if not (Doublet_F(Arg1)) then
1684 But_Courant := S_Fail;
1685 end if;
1686 -------------- Effacement retardé et contrainte différée --------------
1687 when 30 => -- freezeA(Var, But)
1688 Subst := Env_Regle + 1;
1689 if Lie(Subst) then
1690 But_Courant := Ter(Env_Regle + 2);
1691 Env_Courant := Sub(Env_Regle + 2);
1692 else
1693 Subst := Sub(Subst);
1694 Sauve_Subst(Subst);
1695 if Gele(Subst) then
1696 if Pile_Subst'Last - Sp_Subst < 2 then
1697 raise Pile_Subst_Pleine;
1698 else
1699 Pile_Subst(Sp_Subst) := (Lie, Sub(Subst), Ter(Subst));
1700 Pile_Subst(Sp_Subst + 1) := (Stype(Env_Regle + 2), Sub(Env_Regle + 2), Ter(Env_Regle + 2));
1701 Pile_Subst(Subst) := (Gele, Sp_Subst - 1, X_Point_Y);
1702 Sp_Subst := Sp_Subst + 2;
1703 if Sp_Subst > Sp_Subst_Max then Sp_Subst_Max := Sp_Subst; end if;
1704 end if;
1705 else
1706 Pile_Subst(Subst) := (Gele, Sub(Env_Regle + 2), Ter(Env_Regle + 2));
1707 end if;
1708 end if;
1709 when 31 => -- reduce(Arg1, Arg2, Var)
1710 declare
1711 type Result_Reduce is (Differents, Identiques, Hypothese);
1712 Result : Result_Reduce;
1713 Base_Pile_Sauve : Indice_Pile_Sauve := Sp_Sauve;
1714 begin
1715 Buts_Geles := Vecteur_Vide;
1716 Env_Echec := Sp_Subst;
1717 if Unifiable(Cree_Variable(1), Env_Regle, Cree_Variable(2), Env_Regle) then
1718 if Sp_Sauve /= Base_Pile_Sauve then
1719 Subst := Pile_Sauve(Base_Pile_Sauve).Ptr_Pile_Subst;
1720 Result := Hypothese; -- Il faut faire une hypothese sur une var
1721 else
1722 Result := Identiques; -- Les deux termes sont identiques.
1723 end if;
1724 else
1725 Result := Differents;
1726 end if;
1727 while Sp_Sauve /= Base_Pile_Sauve loop Restaure_Subst; end loop;
1728 case Result is
1729 when Differents => But_Courant := S_Fail;
1730 when Identiques => Put_Arg(3, (Lie, Sub_Vide, Cree_Entier(1))); -- Pas besoin d'env. pour atome.
1731 when Hypothese => Put_Arg(3, (Ref, Subst, Ter_Vide)); -- Pas besoin de terme pour variable.
1732 end case;
1733 end;
1734 -------------------------- Listage des regles -------------------------
1735 when 40 => -- listing
1736 Listing(Liste_Def);
1737 when 41 => -- listing(Arg)
1738 Rep(Arg1, Env_Arg1, X);
1739 Listing(Arg1);
1740 when 42 => -- system
1741 Listing(Liste_System);
1742 ------------------------- Evaluation numérique ------------------------
1743 when 50 => -- is
1744 Rep(Arg2, Env_Arg2, X);
1745 Put_Arg(1, (Lie, Sub_Vide, Eval(Arg2, Env_Arg2))); -- Pas besoin d'env. pour atome.
1746 ------------------------ Comparaison numérique ------------------------
1747 when 60 => -- <
1748 Rep(Arg1, Env_Arg1, X);
1749 Rep(Arg2, Env_Arg2, X);
1750 if Entier(Arg1) and then Entier(Arg2) then
1751 if not (Entier_Val(Arg1) < Entier_Val(Arg2)) then But_Courant := S_Fail; end if;
1752 else
1753 But_Courant := S_Fail;
1754 end if;
1755 when 61 => -- =<
1756 Rep(Arg1, Env_Arg1, X);
1757 Rep(Arg2, Env_Arg2, X);
1758 if Entier(Arg1) and then Entier(Arg2) then
1759 if not (Entier_Val(Arg1) <= Entier_Val(Arg2)) then But_Courant := S_Fail; end if;
1760 else
1761 But_Courant := S_Fail;
1762 end if;
1763 when 62 => -- >
1764 Rep(Arg1, Env_Arg1, X);
1765 Rep(Arg2, Env_Arg2, X);
1766 if Entier(Arg1) and then Entier(Arg2) then
1767 if not (Entier_Val(Arg1) > Entier_Val(Arg2)) then But_Courant := S_Fail; end if;
1768 else
1769 But_Courant := S_Fail;
1770 end if;
1771 when 63 => -- >=
1772 Rep(Arg1, Env_Arg1, X);
1773 Rep(Arg2, Env_Arg2, X);
1774 if Entier(Arg1) and then Entier(Arg2) then
1775 if not (Entier_Val(Arg1) >= Entier_Val(Arg2)) then But_Courant := S_Fail; end if;
1776 else
1777 But_Courant := S_Fail;
1778 end if;
1779 -------------- Les prédicats de manipulation des regles ---------------
1780 when 70 => -- asserta
1781 Rep(Arg1, Env_Arg1, X);
1782 Assert_Dynamique(Arg1, Env_Arg1, Debut);
1783 when 71 => -- assert et assertz
1784 Rep(Arg1, Env_Arg1, X);
1785 Assert_Dynamique(Arg1, Env_Arg1, Fin);
1786 -------------------------- Controle de l'echo -------------------------
1787 when 80 => -- echo(X)
1788 Rep(Arg1, Env_Arg1, X);
1789 if Variable(Arg1) then
1790 if Echo then Arg1 := S_On; else Arg1 := S_Off; end if;
1791 Put_Arg(1, (Lie, Sub_Vide, Arg1));
1792 elsif Egalite_Mot(Arg1, S_On) then
1793 Echo := True;
1794 elsif Egalite_Mot(Arg1, S_Off) then
1795 Echo := False;
1796 else
1797 But_Courant := S_Fail;
1798 end if;
1799 ------------------------ Décomposition d'objets -----------------------
1800 when 90 => -- arg2(N, T1, T2)
1801
1802 -- arg2(N, T1, T2)
1803 -- Unifie T2 avec la longueur ou l'élément de rang n d'un entier, d'un symbole, d'une liste, d'un vecteur ou d'une fonction.
1804 --
1805 -- (1) Si T1 est un entier ou un symbole alors si
1806 -- n=0, T2 = longueur(T1)
1807 -- n≠0, T2 = nième caractère de T1.
1808 --
1809 -- (2) Si T1 est une liste ou un vecteur ou une fonction alors si
1810 -- n=0, T2 = nombre d'éléments de T1
1811 -- n≠0, T2 = nième élément de T1.
1812
1813 declare
1814 Item: Mot := Mot_Nul;
1815 begin
1816 Rep(Arg1, Env_Arg1, X);
1817 Rep(Arg2, Env_Arg2, X);
1818 if Entier(Arg1) then
1819 if Entier(Arg2) then Item := Decompose_Entier(Arg1, Arg2); end if;
1820 if Symbole(Arg2) then Item := Decompose_Symbole(Arg1, Arg2); end if;
1821 if Doublet(Arg2) then Item := Decompose_Doublet(Arg1, Arg2); end if;
1822 if Egalite_Mot(Item, Mot_Nul) then
1823 But_Courant := S_Fail;
1824 else
1825 Put_Arg(3, (Lie, Sub_Vide, Item));
1826 end if;
1827 else
1828 But_Courant := S_Fail;
1829 end if;
1830 end;
1831 ------------------------ Quitter l'interpréteur -----------------------
1832 when 1000 => -- halt
1833 Fini := True;
1834 --------------------------------- Autres ------------------------------
1835 when others =>
1836 But_Courant := S_Fail;
1837 end case;
1838 end Regle_Predefinie;
1839
1840
1841 --------------------
1842 -- Le driver PROLOG.
1843 --------------------
1844
1845 procedure Prompt is
1846 begin
1847 if Echo_Actif and Entree_Depuis_Standard then
1848 if Mode_F = Interrogation then
1849 Put("?- ");
1850 else
1851 Put("assert- ");
1852 end if;
1853 end if;
1854 end Prompt;
1855
1856
1857 procedure Driver(Mode_Fonctionnement : Fonctionnement; Mode_Reponse : Reponse) is
1858 Expression : Mot;
1859 Sauve_Mode_F : Fonctionnement := Mode_F;
1860 Sauve_Mode_R : Reponse := Mode_R;
1861 Sauve_Compteur_Reponses : Natural := Compteur_Reponses;
1862 Sauve_Sp_Nomvar : Indice_Pile_Nomvar := Sp_Nomvar;
1863 Sauve_Sp_Nomvar_Initial : Indice_Pile_Nomvar := Sp_Nomvar_Initial;
1864 Sauve_Nb_Var_But : Natural := Nb_Var_But;
1865 begin
1866 Mode_F := Mode_Fonctionnement;
1867 Mode_R := Mode_Reponse;
1868 Sp_Nomvar_Initial := Sp_Nomvar;
1869 while not Fini loop
1870 begin
1871 if not Entree_Depuis_Standard then
1872 Carac_Lu := Caractere_Significatif(Carac_Lu);
1873 end if;
1874 exit when Carac_Lu = Fin_De_Fichier;
1875 Raz_Variables;
1876 Compteur_Reponses := 0;
1877 Prompt;
1878 Expression := Analyse_Complete(Lit_Token);
1879 Nb_Var_But := Nbre_De_Variables;
1880 Sp_Nomvar := Sp_Nomvar_Initial; -- Vide la pile des noms de variables
1881 for I in 1..Nb_Var_But loop -- Sauve les noms des variables.
1882 Empile_Nomvar(Variable_Nom(I));
1883 end loop;
1884 if Vect1(Expression) then Expression := Premier(Expression); end if; -- (expr) équivalent à expr.
1885 if Mode_F = Interrogation then
1886 if Func1(Expression) and then Egalite_Mot(Premier(Expression), S_2points_Moins) then -- Si :-(arg).
1887 Mode_R := Oui_Non;
1888 Effacer(Reste(Expression), Nb_Var_But);
1889 Mode_R := Mode_Reponse;
1890 elsif Func2(Expression) and then Egalite_Mot(Premier(Expression), S_2points_Moins) then -- Si :-(arg1, arg2).
1891 Assert_Statique(Expression, Fin);
1892 else
1893 Effacer(Expression, Nb_Var_But);
1894 end if;
1895 else
1896 if Func1(Expression) and then Egalite_Mot(Premier(Expression), S_2points_Moins) then -- Si :-(arg).
1897 Mode_R := Oui_Non;
1898 Effacer(Reste(Expression), Nb_Var_But);
1899 Mode_R := Mode_Reponse;
1900 else
1901 Assert_Statique(Expression, Fin);
1902 end if;
1903 end if;
1904 exception
1905 when Erreur_De_Syntaxe => null;
1906 end;
1907 end loop;
1908 Mode_F := Sauve_Mode_F;
1909 Mode_R := Sauve_Mode_R;
1910 Compteur_Reponses := Sauve_Compteur_Reponses;
1911 Sp_Nomvar := Sauve_Sp_Nomvar;
1912 Sp_Nomvar_Initial := Sauve_Sp_Nomvar_Initial;
1913 Nb_Var_But := Sauve_Nb_Var_But;
1914 end Driver;
1915
1916
1917 procedure Driver_Prolog is
1918
1919 Premiere_Passe : Boolean := True;
1920
1921 procedure Traite_Exception(Msg : in String) is
1922 begin
1923 New_Line;
1924 Put_Line(Msg);
1925 if Premiere_Passe then -- Si pas possible de charger le fichier PROLOG.SYS
1926 Put_Line(Cannot_Load_Prolog_Sys);
1927 Fini := True; -- alors il faut tout arreter et revenir au systeme.
1928 else
1929 Put_Line(Aborting);
1930 end if;
1931 end Traite_Exception;
1932
1933 begin
1934 Fini := False;
1935 while not Fini loop
1936 begin
1937 Sp_Etape := Pile_Etape'First;
1938 Sp_Choix := Pile_Choix'First;
1939 Sp_Subst := Pile_Subst'First;
1940 Sp_Sauve := Pile_Sauve'First;
1941 Sp_Nomvar := Pile_Nomvar'First;
1942 Echo := False;
1943 Carac_Lu := ' ';
1944 if Premiere_Passe then
1945 Put_Line(Titre1);
1946 Put_Line(Titre2);
1947 -- Lecture du fichier PROLOG.SYS.
1948 Put_Line(Chargefichier);
1949 if not Entree_Fichier(S_Prolog_Sys) then return; end if;
1950 Driver(Consultation, Oui_Non);
1951 --Put(Ansi_Cursor_Up);
1952 Put_Line(Effacechargefichier);
1953 Premiere_Passe := False; -- IMPORTANT ! On ne le met à faux qu'apres avoir chargé PROLOG.SYS
1954 Liste_System := Liste_Def; -- Pour pouvoir ne lister que les regles prédéfinies.
1955 Liste_Def := Liste_Vide; -- Pour ne pas lister les regles prédéfinies avec les regles normales.
1956 end if;
1957 -- Lecture depuis console.
1958 Entree_Standard;
1959 Driver(Interrogation, Toutes_Reponses);
1960 Put_Line(Messagefin);
1961 exception
1962 when Storage_Error => Traite_Exception(Xstorage_Error);
1963 when Table_Doublets_Pleine => Traite_Exception(Xtable_Doublets_Pleine);
1964 when Table_Symb_Pleine => Traite_Exception(Xtable_Symb_Pleine);
1965 when Table_Var_Pleine => Traite_Exception(Xtable_Var_Pleine);
1966 when Pile_Subst_Pleine => Traite_Exception(Xpile_Subst_Pleine);
1967 when Pile_Sauve_Pleine => Traite_Exception(Xpile_Sauve_Pleine);
1968 when Pile_Nomvar_Pleine => Traite_Exception(Xpile_Nomvar_Pleine);
1969 when Pile_Eq_Pleine => Traite_Exception(Xpile_Eq_Pleine);
1970 when Pile_Etape_Pleine => Traite_Exception(Xpile_Etape_Pleine);
1971 when Pile_Choix_Pleine => Traite_Exception(Xpile_Choix_Pleine);
1972 when Pile_Ren_Pleine => Traite_Exception(Xpile_Ren_Pleine);
1973 end;
1974 end loop;
1975 end Driver_Prolog;
1976
1977 begin
1978
1979 --------------------------
1980 -- Pour la mise au point :
1981 --------------------------
1982
1983 --PUT_LINE("Elaboration du package INTERPRETEUR_PROLOG------------------------");
1984
1985 null;
1986
1987 end Interpreteur_Prolog;