;*********************************************************************
; Módulo: IERL
; Uso:    IAAA Experimental Representation Language
; Autor:  Roberto Sobreviela Ruiz
; email:  419245@cepsz.unizar.es
;         sobreviela@teleline.es
;*********************************************************************
; Fichero: IERL Backward.lsp Fecha Creación: 25 de diciembre de 1999
; Versión: 0.0.1          Fecha Modificación: 5 de febrero de 2000
; Estado:  Desarrollo     Autor: Roberto Sobreviela Ruiz
;---------------------------------------------------------------------
; Uso: Extensión del lenguaje IERL.
; Comentarios:
;    Motor de inferencia mediante encadenamiento regresivo según la 
;   propuesta de Patrick Henry Winston [Lisp, Winston & Horn 3th ed].
; Historia:
;   Versión 0.0.1:  Implementación de las funciones del motor de
;       inferencia.
;   Version 0.0.2:  Extension para manejo de frames en las reglas.
;*********************************************************************
   
;; Funciones del motor de inferencia de encadenamiento regresivo
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Modificaciones de la version 0.0.2:
;;;
;; (defun BC-filtra-flujo-de-ligaduras (patron flujo)
;;     (concatena-flujo
;;         (transforma-flujo
;;             #'(lambda (ligaduras)
;;                 (concatena-flujo 
;;                     (construye-flujo 
;;                         (corresponde-patron-con-afirmaciones patron ligaduras)
;;                         (construye-flujo
;; 			    (corresponde-patron-con-reglas patron ligaduras)                                
;; 		            'FLUJO-VACIO)))))
;; 	    flujo)))

(defun BC-filtra-flujo-de-ligaduras (patron flujo)
;    (format t "~%Filtrando ~a con ~a" patron flujo)
    (concatena-flujo
        (transforma-flujo
            #'(lambda (ligaduras)
                (concatena-flujo 
                    (construye-flujo 
                        (corresponde-patron-con-afirmaciones patron ligaduras)
                        (construye-flujo
                            (corresponde-patron-con-frames patron ligaduras)
			    (construye-flujo 
			        (corresponde-patron-con-reglas patron ligaduras)                                
				'FLUJO-VACIO)))))
	    flujo)))
	    

(defun BC-aplica-filtros (patrones flujo-inicial-entrada)
;    (format t "~%Aplicando ~a" patrones)
    (if (endp patrones)
        flujo-inicial-entrada
        (BC-aplica-filtros
            (rest patrones)
            (BC-filtra-flujo-de-ligaduras 
                (first patrones) 
                flujo-inicial-entrada))))

(defun corresponde-patron-con-reglas (patron ligaduras)
        (concatena-flujo
            (transforma-flujo
                #'(lambda (regla)
                    (prueba-regla patron regla ligaduras))
                *reglas*)))

;;; Modificacion de la version 0.0.2:
;;;
;; (defun prueba-regla (patron regla ligaduras)
;;     (let* ((regla (haz-variables-unicas regla))
;;            (resultado (unifica patron (consecuente-de-la-regla regla) ligaduras)))
;;         (if (eq 'FALLA resultado)
;;             'FLUJO-VACIO
;;             (BC-aplica-filtros (antecedentes-de-la-regla regla)
;;                             (construye-flujo resultado 'FLUJO-VACIO)))))

(defun prueba-regla (patron regla ligaduras)
    (let* ((regla (haz-variables-unicas regla))
           (res-afirmacion (unifica patron (consecuente-de-la-regla regla) ligaduras))
	   (res-frame (unifica-frames patron (consecuente-de-la-regla regla) ligaduras)))
;    (format t "~%Probando regla ~a con ~a" regla patron)
;    (format t "~%  Resultado AF: ~a" res-afirmacion)
;    (format t "~%  Resultado FR: ~a" res-frame)
	(if (eq 'FALLA res-afirmacion)
	    (if (eq 'FALLA res-frame)
            	'FLUJO-VACIO
		(BC-aplica-filtros (antecedentes-de-la-regla regla)
                            (construye-flujo res-frame 'FLUJO-VACIO)))
	    (if (eq 'FALLA res-frame)
	        (BC-aplica-filtros (antecedentes-de-la-regla regla)
                            (construye-flujo res-afirmacion 'FLUJO-VACIO))
		(BC-aplica-filtros (antecedentes-de-la-regla regla)
                            (construye-flujo 
			        (concatena-flujo
                                    (construye-flujo
				        res-afirmacion 'FLUJO-VACIO)
				    (construye-flujo
				        res-frame 'FLUJO-VACIO))
					'FLUJO-VACIO))))))
			    
;;; Modificacion de la version 0.0.2:
;;;
;; (defun BC-particulariza-variables (patron lista-a)
;;     (cond ((atom patron) patron)
;;           ((eq '? (first patron))
;;            (let ((ligadura (encuentra-ligadura patron lista-a)))
;;                 (if ligadura
;;                     (BC-particulariza-variables (extrae-valor ligadura) lista-a) 
;;                     patron)))
;;           (t (cons (BC-particulariza-variables (first patron) lista-a)
;;                    (BC-particulariza-variables (rest patron) lista-a)))))

                    
(defun BC-particulariza-variables (patron lista-a)
;    (format t "~%Particularizando: ~a" patron)
    (cond ((atom patron) patron)
          ((eq '? (first patron))
           (let ((ligadura (encuentra-ligadura patron lista-a)))
                (if ligadura
                    (BC-particulariza-variables (extrae-valor ligadura) lista-a) 
                    patron)))
          ((eq 'objeto (first patron))
           (let ((ligadura (encuentra-ligadura patron lista-a)))
                (if ligadura
                    (BC-particulariza-variables (extrae-valor ligadura) lista-a) 
                    patron)))
          (t (cons (BC-particulariza-variables (first patron) lista-a)
                   (BC-particulariza-variables (rest patron) lista-a)))))

;;; Modificacion de la version 0.0.2:
;;;
;; (defun lista-variables (arbol &optional nombres)
;;     (cond ((atom arbol) nombres)
;;           ((eq '? (first arbol))
;; 	   (if (or (eq '_ (second arbol))
;;                    (member (second arbol) nombres))
;;                nombres
;;                (append nombres (list (second arbol)))))
;;           (t (lista-variables (rest arbol)
;;                               (lista-variables (first arbol) nombres)))))

;;; Extension de la version 0.0.3:
;;;

(defun miembro-lista (p1 p2)
    (and (eq (first p1) (first p2))
         (eq (second p1) (second p2))))
	 
(defun lista-variables (arbol &optional nombres)
;    (format t "~%Listando: ~a con ~a" arbol nombres)
    (cond ((atom arbol) nombres)
          ((eq '? (first arbol))
	   (if (or (eq '_ (second arbol))
                   (member (list (first arbol) (second arbol)) 
		           nombres :test 'miembro-lista))
               nombres
               (append nombres (list arbol))))
          ((eq 'objeto (first arbol))
           (if (or (eq '_ (second arbol))
                   (member (list (first arbol) (second arbol)) 
		           nombres :test 'miembro-lista))
               nombres
               (append nombres (list arbol))))
          (t (lista-variables (rest arbol)
                              (lista-variables (first arbol) nombres)))))

(defun haz-respuesta (variables ligaduras)
    (BC-particulariza-variables
        (mapcar #'(lambda (variable)
                    (list (second variable) (list (first variable) (second variable))))
                variables)
        ligaduras))

(defun muestra-respuestas (respuestas)
    (format t "~%-->")
    (dolist (respuesta respuestas)
        (format t " ~a = ~a" (first respuesta) (second respuesta))))
        
(defun haz-variables-unicas (regla)
    (let ((variables (lista-variables regla)))
        (dolist (variable variables regla)
            (setf regla
                (BC-particulariza-variables regla
                    (list (list (second variable) 
		                (append (list (first variable)) 
				        (list (gentemp (second variable)))
					(extrae-restricciones variable)))))))))

(defun encadenamiento-regresivo (&rest patrones)
    (let ((flujo-de-ligaduras
            (BC-aplica-filtros patrones
                               (construye-flujo nil 'FLUJO-VACIO)))
          (variables (lista-variables patrones))
          (respuestas-mostradas nil))
        (if (endp variables)
            (if (final-del-flujo-p flujo-de-ligaduras)
                'NO
                'SI)
            (do ((flujo-de-ligaduras flujo-de-ligaduras
                                     (resto-del-flujo flujo-de-ligaduras)))
                ((final-del-flujo-p flujo-de-ligaduras) 'NO-MAS)
                (let ((respuesta
                        (haz-respuesta variables (principio-del-flujo flujo-de-ligaduras))))
                    (unless (member respuesta respuestas-mostradas :test #'equal)
                        (muestra-respuestas respuesta)
                        (setf respuestas-mostradas
                            (cons respuesta respuestas-mostradas))))))))
