ANNEXE 1
(André Brouty)
Ce programme est sous licence libre GPL.
LISTING DU PROGRAMME
;********************************************************************;
;****** L'EVALUATEUR ET LES COMBINATEURS DE BASE. ******;
(DE CI (L) ;l'evaluateur a appeler avec un combinateur en argument;
(ESCAPE RATE
(SUITE (EV L) L)))
(DE EV (L)
(LET ((L L) (GEN -1))
(COND
((NUMBP (CAR L)) (IFN (ZEROP (CAR L))
(RATE '(PAS REGULIER))
(CONTROLE (PRINT (ANALYSE L)) GEN)))
((REDEX? L) (SELF (EVAL L) GEN)) ;le combinateur est-il;
;en forme normale? si;
;oui on commence a;
;l'ecrire sous forme de;
;lambda-expression;
(T (SELF (SELECTQ (CAR L)
(B (COND
((NULL (CDR L)) (PRINT (LIST
(INCR GEN)
(LIST
(INCR GEN)
(INCR GEN)))))
((NULL (CDDR L)) (PRINT (DEP (LIST
(CADR L)
(LIST
(INCR GEN)
(INCR GEN))))))
(T (PRINT (DEP (LIST
(CADR L)
(LIST
(CADDR L)
(INCR GEN))))))))
(C (COND
((NULL (CDR L)) (PRINT (LIST
(INCR GEN)
(ADD1 (INCR GEN))
(SUB1 (INCR GEN)))))
((NULL (CDDR L)) (PRINT (DEP (LIST
(CADR L)
(ADD1 (INCR GEN))
(SUB1 (INCR GEN))))))
(T (PRINT (DEP (LIST
(CADR L)
(INCR GEN)
(CADDR L)))))))
(S (COND
((NULL (CDR L)) (PRINT (LIST
(INCR GEN)
(ADD1 (INCR GEN))
(LIST
GEN
(INCR GEN)))))
((NULL (CDDR L)) (PRINT (DEP (LIST
(CADR L)
(ADD1 (INCR GEN))
(LIST
GEN
(INCR GEN))))))
(T (PRINT (DEP (LIST
(CADR L)
(INCR GEN)
(LIST
(CADDR L)
GEN)))))))
(W (COND
((NULL (CDR L)) (PRINT (LIST
(INCR GEN)
(INCR GEN)
GEN)))
(T (PRINT (DEP (LIST
(CADR L)
(INCR GEN)
GEN))))))
(K (COND
((NULL (CDR L))
(INCR GEN)
(PRINT (LIST (SUB1 (INCR GEN)))))
(T (INCR GEN)
(PRINT (DEP (LIST (CADR L)))))))
(I (PRINT (LIST (INCR GEN))))
(T (RATE '(FONCTION INCONNUE)))) GEN)))))
(DF B (V) ;le combinateur B;
(COND
((NULL (CDDR V)) (PRINT (CONS 'B V)))
(T (PRINT (DEP (CONS (CAR V) (CONS (LIST
(CADR V)
(CADDR V)) (CDDDR V))))))))
(DF C (V) ;le combinateur C;
(COND
((NULL (CDDR V)) (PRINT (CONS 'C V)))
(T (PRINT (DEP (CONS (CAR V) (CONS (CADDR V) (CONS (CADR V) (
CDDDR V)))))))))
(DF S (V) ;le combinateur S;
(COND
((NULL (CDDR V)) (PRINT (CONS 'S V)))
(T (PRINT (DEP (CONS (CAR V) (CONS (CADDR V) (CONS (LIST
(CADR V)
(CADDR V)) (CDDDR V)))))))))
(DF K (V) ;le combinateur K;
(COND
((NULL (CDR V)) (PRINT (CONS 'K V)))
(T (PRINT (DEP (CONS (CAR V) (CDDR V)))))))
(DF W (V) ;le combinateur W;
(COND
((NULL (CDR V)) (PRINT (CONS 'W V)))
(T (PRINT (DEP (CONS (CAR V) (CONS (CADR V) (CONS (CADR V) (CDDR
V)))))))))
(DF I (V) ;le combinateur I;
(COND
((NULL V) (PRINT '(I)))
(T (PRINT (DEP V)))))
;*********************************************************************;
;****** LA FONCTION PRINCIPALE DE L'ALGORITHME. ******;
;cette fonction analyse une expression sous forme normale de tete;
;ainsi que ses sous termes pour voir si elle repond aux criteres;
;d'inversibilite;
(DE ANALYSE (L)
(COND
((NULL L)
(PRIN1 'JE 'MONTE '---->)
())
((NUMBP (CAR L)) (CONS (CAR L) (ANALYSE (CDR L))))
((ATOM (CAR L)) (RATE '(CONTIENT UN COMBINATEUR ISOLE)))
((NUMBP (CAAR L)) (IF (NULL (CDR (CAR L)))
(ANALYSE (CONS (CAAR L) (CDR L)))
(RATE '(PAS DE COMBINATEUR EN DEBUT DE LISTE))))
((NULL (CDAR L)) (ANALYSE (CONS (CAAR L) (CDR L))))
((AND
(NUMBP (LAST (CAR L)))
(FN? (CAR L)))
(PRINT 'JE 'DESCENDS '----> (CAR L))
(IF (VAR1? (CAR L))
(CONS (LAST (CAR L)) (CONS (EV (DEB (CAR L))) (ANALYSE (
PROGN
(PRINT (CADR L))
(CDR L)))))
(RATE '(HELAS TROP DE VARIABLES))))
(T (LET ((A (VAR1? (CAR L))))
(COND
((NULL A)
(PRINT 'FAUT 'ESSAYER 'DE 'METTRE 'EN 'FORME 'NORMALE)
(LET ((FN (PRINT (FN (CAR L)))))
(IF (VAR1? FN)
(ANALYSE (CONS FN (CDR L)))
(RATE '(HELAS BEAUCOUP TROP DE VARIABLES)))))
(T (PRINT 'JE 'DESCENDS '----> (CAR L))
(IF (NUMBP (LAST (CAR L)))
(CONS (LAST (CAR L)) (CONS (EV (DEB (CAR L))) (
ANALYSE (PROGN
(PRINT (CADR L))
(CDR L)))))
(PRINT 'FAUT 'FAIRE 'UNE 'ABSTRACTION 'JE 'M 'EN '
OCCUPE)
(ANALYSE (CONS (PRINT 'VOILA '----> (ABST (CAR L) A)
) (CDR L))))))))))
;********************************************************************;
;****** LES PREDICATS UTILISES. ******;
(DE REDEX? (L) ;peut-on faire une reduction externe?;
(SELECTQ (CAR L)
(I (CDR L))
((K W) (CDDR L))
((B C S) (CDDDR L))
(T ())))
(DE FN? (L) ;une expression est-elle en forme normale?;
(ESCAPE REDEX
(FNESC L)))
(DE FNESC (L)
(OR
(ATOM L)
(IF (REDEX? L)
(REDEX)
(MAPC L
'FNESC)
T)))
(DE FNEXT? (J) ;l'expression J est-elle en forme normale externe?;
(NOT (REDEX? J)))
(DE VAR1? (L) ;y a-t-il une seule variable dans l'expression L?;
(LET ((V (VARN L)))
(COND
((NULL V) (RATE '(PAS DE VARIABLE DANS UN SOUS TERME)))
((ATOM V) V)
(T ()))))
(DE VARN (L)
(IF (ATOM L)
(NUMBP L)
(LET ((X1 (VARN (CAR L))) (X2 (VARN (CDR L))))
(IFN X1
X2
(IFN X2
X1
(CONS X1 X2))))))
(DE SUPERPLAT? (L) ;la liste L est elle plate?;
(OR
(NULL L)
(AND
(ATOM (CAR L))
(SUPERPLAT? (CDR L)))))
(DE MPLAT? (L) ;la liste L est-elle plate ou contient-elle des;
(AND ;sous-listes commencant par un combinateur?;
(NUMBP (CAR L))
(MPLAT (CDR L))))
(DE MPLAT (L)
(COND
((NULL L) T)
((ATOM (CAR L)) (MPLAT (CDR L)))
(T (IF (AND
(ATOM (CAAR L))
(NOT (NUMBP (CAAR L))))
(MPLAT (CDR L))
()))))
(DE PLAT? (L) ;le car de L est-il une liste plate ou mplate?;
(AND
(LISTP (CAR L))
(OR
(SUPERPLAT? (CAR L))
(MPLAT? (CAR L)))))
(DE PERMUT? (L N) ;la liste L de longueur N correspond-elle a une;
(COND ;permutation des N premiers nombres zero compris?;
((NULL L) L)
((MEMQ N L) (PERMUT? (SUPPRIME N L) (SUB1 N)))
(T (RATE '(IL Y A UNE SUITE DE VARIABLES QUI N 'EST PAS UNE
PERMUTATION)))))
(DE SUPPRIME (N L) ;supprimer une occurrence de N dans la liste L;
(COND
((NULL L) L)
((EQ (CAR L) N) (CDR L))
(T (CONS (CAR L) (SUPPRIME N (CDR L))))))
(DE APP (X L) ;l'element X appartient-il a la liste L?;
(OR
(AND
(ATOM L)
(EQ X L))
(AND
(LISTP L)
(APP X (NEXTL L)))
(AND
(LISTP L)
(APP X L))))
(DE DABS? (L) ;la liste L a-t-elle deja ete abstraite?;
(NOT (AND
(NUMBP (CAR L))
(OR
(ZEROP (CAR L))
(CDR L)))))
;********************************************************************;
;**** LES FONCTIONS QUI METTENT UNE EXPRESSION EN FORME NORMALE. ****;
(DE FN (L)
(IF (FNEXT? L)
(FFN L)
(FFN (FNEXT L))))
(DE FFN (L)
(MAPCAR L
(LAMBDA (X)
(COND
((ATOM X) X)
(T (IF (FNEXT? X)
(FFN X)
(FFN (FNEXT X))))))))
(DE FNEXT (L)
(IF (FNEXT? L)
L
(FNEXT (EVAL L))))
;********************************************************************;
;****** LES FONCTIONS D'ABSTRACTION. ******;
(DE ABSTRACTION (L X) ;abstrait une liste-permutation a partir;
(COND ;de son plus grand element X;
((EQ X -1) L)
(T (ABSTRACTION (DEB (ABST L X)) (SUB1 X)))))
(DE ABST (L X) ;abstrait l'element X de la liste L;
(COND
((EQ X (LAST L)) L)
((MEMQ X L) (POUSSE L X))
(T (DEPA L X))))
(DE POUSSE (G X) ;met X comme atome de G et le pousse a la fin ;
(COND
((EQ X (LAST G)) G)
(T (POUSSE (IF (EQ (CADR G) X)
(CONS 'C (CONS (CAR G) (CONS (CADDR G) (CONS (CADR G) (
CDDDR G)))))
(CONS 'C (CONS (DEBUT G X) (PER2 (MEMQ X G))))) X))))
(DE PER2 (L) ;permute les deux premiers elements de la liste L;
(CONS (CADR L) (CONS (CAR L) (CDDR L))))
(DE DEBUT (L X) ;donne la liste des elements de L jusqu'a X non compris;
(REVERSE (CDR (MEMQ X (REVERSE L)))))
(DE DEPA (L X) ;deparenthese l'element X de L et l'abstrait;
(COND
((MEMQ X L) (POUSSE L X))
(T (DEPA (APPEND (DEPA1 (DEBLIST L X)) (FINLIST L X)) X))))
(DE DEPA1 (L) ;deparenthese une fois le dernier element de L;
(COND
((NULL (CDDR L)) (IF (NULL (CDDR (CADR L)))
(CONS 'B (CONS (CAR L) (CADR L)))
(CONS 'B (CONS (CAR L) (CONS (DEB (CADR L)) (LIST (LAST (CADR
L))))))))
(T (CONS 'B (CONS (DEB L) (IF (NULL (CDDR (LAST L)))
(LAST L)
(CONS (DEB (LAST L)) (LAAST L))))))))
(DE DEB (L) ;renvoie la liste L privee de son dernier element;
(REVERSE (CDR (REVERSE L))))
(DE DEBLIST (L X) ;donne la liste des premiers elements de L;
(COND ;jusqu' a l'element contenant X compris;
((NULL L) L)
((ATOM (CAR L)) (IF (EQ X (CAR L))
(LIST (CAR L))
(CONS (CAR L) (DEBLIST (CDR L) X))))
(T (IF (APP X (CAR L))
(LIST (CAR L))
(CONS (CAR L) (DEBLIST (CDR L) X))))))
(DE FINLIST (L X) ;donne la liste des elements de L a partir de l'element;
(CDR (REVERSE (DEBLIST (REVERSE L) X)))) ;contenant X non compris;
(DE LAST (L) ;donne le dernier element de la liste L;
(CAR (REVERSE L)))
(DE LAAST (L)
(LIST (LAST (LAST L))))
;********************************************************************;
;****** LES FONCTIONS QUI DEPARENTHESENT UNE EXPRESSION SUIVANT *****;
;****** LES CONVENTIONS DE LA LOGIQUE COMBINATOIRE. *****;
(DE DEP (H)
(COND
((ATOM (CAR H)) (CONS (CAR H) (DEP1 (CDR H))))
(T (DEP (APPEND (CAR H) (CDR H))))))
(DE DEP1 (H)
(COND
((NULL H) H)
((ATOM (CAR H)) (CONS (CAR H) (DEP1 (CDR H))))
((ATOM (CAAR H)) (IF (NULL (CDAR H))
(CONS (CAAR H) (DEP1 (CDR H)))
(CONS (DEP (CAR H)) (DEP1 (CDR H)))))
(T (CONS (DEP (CAR H)) (DEP1 (CDR H))))))
;*********************************************************************;
;****** RESTE A CONTROLER QUE LES LISTES RESTANTES CORRESPONDENT *****;
;****** A DES PERMUTATIONS PUIS A CONSTRUIRE L'INVERSE. *****;
(DE CONTROLE (L N) ;la liste formee des atomes de L est-elle une permutation?;
(PERMUT? (TOP L) N)
L)
(DE TOP (L) ;donne la liste des atomes de la liste L;
(COND
((NULL L) L)
((ATOM (CAR L)) (CONS (CAR L) (TOP (CDR L))))
(T (TOP (CDR L)))))
(DE SUITE (L G) ;on est maintenant pret pour recuperer l'inverse;
(PRINT 'COMBINATEUR 'INVERSIBLE)
(PRINT 'VOICI 'L 'INVERSE:)
(LET ((X (PRINT '----> (ID (SUPERABST (FORME (RECONS L (PERMUT (TOP
L)) (PERMUT (TOP L)))))))))
(PRINT 'VOULEZ-VOUS 'VERIFIER?)
(IF (EQ (READ) 'OUI)
(VERIF G X)
'OK)))
(DE SUPERABST (L) ;on fait l'abstraction de la liste representant l'inverse;
(IF (NUMBP (CAR L)) ; du combinateur sous forme de lambda-expression;
(SUPERABST (FIRSTABST L))
L))
(DE FIRSTABST (L) ;on fait l'abstraction du dernier niveau;
(COND ;de la liste L;
((NULL L) L)
((SUPERPLAT? L) (IF (DABS? L)
L
(ABSTRACTION L (SUB1 (LENGTH L)))))
((MPLAT? L) (ABSTRACTION L (SUB1 (LENGTH L))))
((ATOM (CAR L)) (CONS (CAR L) (FIRSTABST (CDR L))))
((PLAT? (CAR L)) (CONS (LET ((SAUV (ABSTRACTION (CAAR L) (SUB1 (
LENGTH (CAAR L))))))
(IF (NULL SAUV)
(CADAR L)
(APPEND SAUV (CDAR L)))) (FIRSTABST (CDR L))))
(T (CONS (FIRSTABST (CAR L)) (FIRSTABST (CDR L))))))
(DE FORME (L) ;met la liste L sous une forme representant la;
(COND ;lambda expression associee au combinateur;
((NULL L) L)
((LISTP (CAR L)) (FORME (CDR L)))
((ATOM (CADR L)) (CONS (CAR L) (FORME (CDR L))))
(T (CONS (CONS (FORME (CADR L)) (LIST (CAR L))) (FORME (CDR L)))
)))
(DE RECONS (L LI1 LI2) ;inverse L et toutes ses sous listes;
(AND
LI2
(LET ((SAUV (ASSOCIE (RANG (CAR LI2) LI1) L)))
(CONS (CAR LI2) (IFN SAUV
(RECONS L LI1 (CDR LI2))
(CONS (RECONS SAUV (PERMUT (TOP SAUV)) (PERMUT (TOP
SAUV))) (RECONS L LI1 (CDR LI2))))))))
(DE PERMUT (L) ;donne la permutation inverse de L;
(PERM (REVERSE L) 0))
(DE PERM (L X)
(COND
((EQ X (LENGTH L)) ())
(T (CONS (SUB1 (LENGTH (MEMQ X L))) (PERM L (ADD1 X))))))
(DE ASSOCIE (X L) ;donne l'element suivant X dans la liste L si celui-ci;
(LISTP (CADR (MEMQ X L)))) ;est une liste;
(DE RANG (X L) ;donne le rang de X dans la liste L;
(- (LENGTH L) (LENGTH (MEMQ X L))))
(DE ID (L) ;pour reconnaitre l'abstraction de l'identite qui est nil;
(IF (NULL L)
'(I)
L))
(DE VERIF (L1 L2) ;reste a verifier qu'on ne s'est pas trompe;
(PRINT 'VOTRE 'COMBINATEUR '----> L1)
(PRINT 'SON 'INVERSE '----> L2)
(EV (PRINT (DEP (CONS 'B (CONS L1 (LIST L2))))))
'(VOILA VOUS RECONNAISSEZ L 'IDENTITE))