;*********************************************************************
; Módulo: IERL
; Uso:    IAAA Experimental Representation Language
; Autor:  Roberto Sobreviela Ruiz
; email:  419245@cepsz.unizar.es
;         sobreviela@teleline.es
;*********************************************************************
; Fichero: IERL Matching.lsp Fecha Creación: 15 de noviembre de 1999
; Versión: 0.0.3          Fecha Modificación: 5 de febrero de 2000
; Estado:  Desarrollo     Autor: Roberto Sobreviela Ruiz
;---------------------------------------------------------------------
; Uso: Extensión del lenguaje IERL.
; Comentarios:
;    Motor de correspondencia de patrones basado en la implementación
;   propuesta por Patrick Henry Winston [Lisp, Winston & Horn 3th ed].
; Historia:
;   Versión 0.0.1:  Comienzo de la extensión del lenguaje mediante la
;	    implementación de un motor de correspondencia de patrones.
;     Extension 1: Las variables pueden tener asociados predicados,
;           que deben cumplirse para ligar el valor de la variable.
;           [Ejercicio 24-1, [Lisp]].
;   Version 0.0.2:  Implementación de la correspondencia generalizada
;       mediante la implementación de un algoritmo de unificación.
;   Version 0.0.3:  Integracion de la sintaxis de frames en los
;	patrones de correspondencia.
;*********************************************************************

;; Funciones para el manejo de variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun extrae-variable (expresion)
    (second expresion))

;; Funciones para el manejo de ligaduras
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun haz-ligadura (variable dato)
    (list variable dato))
    
(defun agrega-ligadura (expresion dato ligaduras)
    (if (eq '_ (extrae-variable expresion))
        ligaduras
        (cons (haz-ligadura (extrae-variable expresion) dato) ligaduras)))

(defun encuentra-ligadura (expresion ligadura)
    (unless (eq '_ (extrae-variable expresion))
        (assoc (extrae-variable expresion) ligadura)))

(defun extrae-clave (ligadura)
    (car ligadura))

(defun extrae-valor (ligadura)
    (second ligadura))

;; Funciones para la detección de los casos de correspondencia
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Un elemento es un átomo
(defun elementos-p (patron dato)
    (and (atom patron) (atom dato)))

;; Una variable es una lista cuyo CAR es un '?'
(defun variable-p (patron)
    (and (listp patron) (eq '? (car patron))))
    
;; Si el patron y el dato son compuestos,
;;    debe procederse de forma recursiva
(defun recursivos-p (patron dato)
    (and (listp patron) (listp dato)))

;; Funciones para el manejo de predicados
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun predicados-satisfechos-p (predicados argumento)
    (cond 
        ((endp predicados) t)
        ((funcall (car predicados) argumento)
         (predicados-satisfechos-p (cdr predicados) argumento))
        (t nil)))

(defun extrae-predicados (patron)
    (cddr patron))
    
;; Funciones de correspondencia de patrones
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun corresponde (patron dato &optional ligaduras)
    (cond ((elementos-p patron dato)
           (corresponde-atomos patron dato ligaduras))
          ((variable-p patron)
           (corresponde-variable patron dato ligaduras))
          ((recursivos-p patron dato)
           (corresponde-partes patron dato ligaduras))
          (t
           'FALLA)))

(defun corresponde-atomos (patron dato ligaduras)
    (if (eq patron dato)
        ligaduras
        'FALLA))
        
(defun corresponde-variable (patron dato ligaduras)
    (if (predicados-satisfechos-p (extrae-predicados patron) dato)
        (let ((ligadura (encuentra-ligadura patron ligaduras)))
            (if ligadura
                (corresponde (extrae-valor ligadura) dato ligaduras)
                (agrega-ligadura patron dato ligaduras)))
        'FALLA))

(defun corresponde-partes (patron dato ligaduras)
    (let ((resultado (corresponde (car patron) (car dato) ligaduras)))
        (if (eq 'FALLA resultado)
            'FALLA
            (corresponde (cdr patron) (cdr dato) resultado))))

;;; Modificacion de la version 0.0.2: Unificacion de patrones.
;; Funciones de unificación
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun unifica (patron1 patron2 &optional ligaduras)
;    (format t "~%unificar: ~a con ~a" patron1 patron2)
    (cond ((elementos-p patron1 patron2)
           (unifica-atomos patron1 patron2 ligaduras))
          ((variable-p patron1)
           (unifica-variable patron1 patron2 ligaduras))
          ((variable-p patron2)
           (unifica-variable patron2 patron1 ligaduras))
          ((recursivos-p patron1 patron2)
           (unifica-partes patron1 patron2 ligaduras))
          (t 'FALLA)))

(defun unifica-atomos (p1 p2 ligaduras)
    (if (eql p1 p2) 
        ligaduras
        'FALLA))

(defun unifica-variable (p1 p2 ligaduras)
;    (format t "~%Variable ~a, dato ~a" p1 p2)
    (if (not (listp p2))
        (if (predicados-satisfechos-p (extrae-predicados p1) p2)
            (let ((ligadura (encuentra-ligadura p1 ligaduras)))
                (if ligadura
                    (unifica (extrae-valor ligadura) p2 ligaduras)
                    (if (contenido-p p1 p2 ligaduras)
                        'FALLA
                        (agrega-ligadura p1 p2 ligaduras))))
	    'FALLA)
        (let ((ligadura (encuentra-ligadura p1 ligaduras)))
            (if ligadura
                (unifica (extrae-valor ligadura) p2 ligaduras)
                (if (contenido-p p1 p2 ligaduras)
                    'FALLA
                    (agrega-ligadura p1 p2 ligaduras))))))

(defun unifica-partes (p1 p2 ligaduras)
    (let ((resultado (unifica (car p1) (car p2) ligaduras)))
        (if (eq 'FALLA resultado)
            'FALLA
            (unifica (cdr p1) (cdr p2) resultado))))

(defun contenido-p (variable expresion ligaduras)
    (if (equal variable expresion)
        nil
        (contenido-o-igual-p variable expresion ligaduras)))

(defun contenido-o-igual-p (variable expresion ligaduras)
    (cond ((equal variable expresion) T)
          ((atom expresion) nil)
          ((eq '? (first expresion))
           (let ((ligadura (encuentra-ligadura expresion ligaduras)))
                (when ligadura
                    (contenido-o-igual-p variable (extrae-valor ligadura) ligaduras))))
          (t (or (contenido-o-igual-p variable (first expresion) ligaduras)
                (contenido-o-igual-p variable (rest expresion) ligaduras)))))


;;; Modificacion de la version 0.0.3: Integraci´on frames y reglas
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Funciones para la detección de los casos de correspondencia
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Un frame es una form del sistema IERL
(defun frames-p (patron dato)
    (and (elementos-p patron dato) 
         (and (form-p patron) 
	      (form-p dato))))
	

;; Una variable frame es una lista cuyo CAR es 'frame'
(defun variable-frame-p (patron)
    (and (listp patron) (eq 'objeto (car patron))))

;; Funciones para el manejo de restricciones
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun restricciones-satisfechas-p (restricciones frame)
    (cond 
        ((endp restricciones) t)
        ((listp (car restricciones))
	 (cond ((eq (caar restricciones) 'es)
	        (if (is-a? frame (second (car restricciones)))
		(restricciones-satisfechas-p (cdr restricciones) frame)))
    	       ((eq (caar restricciones) 'nombre)
		(if (eq frame (second (car restricciones)))
                    (restricciones-satisfechas-p (cdr restricciones) frame)))
	       (t
	        (if (eq (get-value frame (caar restricciones)) 
		        (second (car restricciones)))
		    (restricciones-satisfechas-p (cdr restricciones) frame)))))
	((funcall (car restricciones) frame)
         (restricciones-satisfechas-p (cdr restricciones) frame))
        (t nil)))


(defun extrae-restricciones (patron)
    (rest (rest patron)))

;; Funciones para la correspondencia de frames con patrones
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun corresponde-frames (patron frame &optional ligaduras)
    (cond ((frames-p patron frame)
           (corresponde-elementos-frames patron frame ligaduras))
          ((variable-frame-p patron)
           (corresponde-variable-frames patron frame ligaduras))
          ((recursivos-p patron frame)
           (corresponde-partes-frames patron frame ligaduras))
          (t
           'FALLA)))

(defun corresponde-elementos-frames (patron frame ligaduras)
    (if (eq patron frame)
        ligaduras
        'FALLA))
        
(defun corresponde-variable-frames (patron frame ligaduras)
    (if (restricciones-satisfechas-p (extrae-restricciones patron) frame)
        (let ((ligadura (encuentra-ligadura patron ligaduras)))
            (if ligadura
                (corresponde-frames (extrae-valor ligadura) frame ligaduras)
                (agrega-ligadura patron frame ligaduras)))
        'FALLA))

(defun corresponde-partes-frames (patron frame ligaduras)
    (let ((resultado (corresponde-frames (car patron) (car frame) ligaduras)))
        (if (eq 'FALLA resultado)
            'FALLA
            (corresponde-frames (cdr patron) (cdr frame) resultado))))

;; Funciones de unificación
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun unifica-frames (patron1 patron2 &optional ligaduras)
;    (format t "~%unificar: ~a con ~a" patron1 patron2)
    (cond ((elementos-p patron1 patron2)
           (unifica-atomos patron1 patron2 ligaduras))
          ((frames-p patron1 patron2)
           (unifica-elementos-frames patron1 patron2 ligaduras))
          ((variable-frame-p patron1)
           (unifica-variable-frames patron1 patron2 ligaduras))
          ((variable-frame-p patron2)
           (unifica-variable-frames patron2 patron1 ligaduras))
          ((recursivos-p patron1 patron2)
           (unifica-partes-frames patron1 patron2 ligaduras))
          (t 'FALLA)))

(defun unifica-elementos-frames (p1 p2 ligaduras)
    (if (eql p1 p2) 
        ligaduras
        'FALLA))

(defun unifica-variable-frames (p1 p2 ligaduras)
;    (format t "~%Variable frame ~a, dato ~a" p1 p2)
    (if (not (listp p2))
        (if (restricciones-satisfechas-p (extrae-predicados p1) p2)
            (let ((ligadura (encuentra-ligadura p1 ligaduras)))
	        (if ligadura
                    (unifica-frames (extrae-valor ligadura) p2 ligaduras)
                    (if (contenido-frames-p p1 p2 ligaduras)
                        'FALLA
                        (agrega-ligadura p1 p2 ligaduras))))
	    'FALLA)
        (let ((ligadura (encuentra-ligadura p1 ligaduras)))
	    (if ligadura
                (unifica-frames (extrae-valor ligadura) p2 ligaduras)
                (if (contenido-frames-p p1 p2 ligaduras)
                    'FALLA
                    (agrega-ligadura p1 p2 ligaduras))))))
	    

(defun unifica-partes-frames (p1 p2 ligaduras)
    (let ((resultado (unifica-frames (car p1) (car p2) ligaduras)))
        (if (eq 'FALLA resultado)
            'FALLA
            (unifica-frames (cdr p1) (cdr p2) resultado))))

(defun contenido-frames-p (variable expresion ligaduras)
    (if (equal variable expresion)
        nil
        (contenido-o-igual-frames-p variable expresion ligaduras)))

(defun contenido-o-igual-frames-p (variable expresion ligaduras)
    (cond ((equal variable expresion) T)
          ((atom expresion) nil)
          ((eq 'objeto (first expresion))
	   (let ((ligadura (encuentra-ligadura expresion ligaduras)))
                (when ligadura
		    (contenido-o-igual-frames-p variable (extrae-valor ligadura) ligaduras))))
          (t (or (contenido-o-igual-frames-p variable (first expresion) ligaduras)
                (contenido-o-igual-frames-p variable (rest expresion) ligaduras)))))
