;*********************************************************************
; Módulo: IERL
; Uso:    IAAA Experimental Representation Language
; Autor:  Pedro R. Muro
;         Roberto Sobreviela Ruiz
; email:  419245@cepsz.unizar.es
;         sobreviela@teleline.es
;*********************************************************************
; Fichero: IERL Frames.lsp Fecha Creación: 5 de julio de 1999
; Versión: 1.0.1        Fecha Modificación: 12 de enero del 2000
; Estado:  Desarrollo   Autor: Roberto Sobreviela Ruiz
;---------------------------------------------------------------------
; Uso: Extensión del lenguaje IERL.
; Comentarios:
; Historia:
;    Versión 0.0.1:  Comienzo de la extensión del lenguaje.
;       Extensión 1: Información sobre los descendientes.
;       Extensión 2: Demon IF-ADDED.
;    Versión 0.0.2:  Orientación a Objetos.
;       Extensión 3: Implementación del soporte al paso de mensajes.
;       Extensión 4: Implementación de las funciones de acceso y 
;         modificación como métodos propios de cada form.
;    Versión 0.0.3:  Modificaciones de los algoritmos de herencia.
;       Extensión 5: Algoritmos de herencia parametrizable a nivel de
;         slot según el aspecto INHERITANCE.
;    Versión 0.0.4:  Extensión de los aspectos adicionales de un slot.
;       Extensión 6: Implementación del aspecto de documentación DOC.
;       Extensión 7: Implementación de los aspectos MIN, MAX y TYPE
;         para cada slot de la form. Implementación de los métodos
;         que los modifican.
;       Extensión 8: Implementación de la función de información sobre
;         una form.
;    Versión 0.0.5:  Extensión al mecanismo de herencia.
;       Extensión 9: Implementación de la herencia múltiple. Sólo
;         existe un único algoritmo en este caso.
;       Extensión 10: Implementación de relaciones de herencia 
;         ortogonal.
;    Version 1.0.0:  Primera version operativa del sistema de frames
;    Version 1.0.1:  Comienzo de la extension del lenguaje para su
;	  integracion con la extension IERL para reglas
;	Extension 11: Implementacion del mecanismo de activacion del
;	  sistema de frames para su integracion con el sistema de
;	  reglas.
;*********************************************************************

;;;
;;; Una form tiene tres partes: un IS-A, slots y metodos
;;;  esta implementada mediante la lista de propiedades del símbolo.
;;;
;;;
;;; FORM :: valor
;;; Modifica los valors de una form y la crea en caso de que no 
;;;   exista.
;;;
;;; Extensión 1:
;;; Se agnade a la función form la posibilidad de mantener una 
;;; referencia directa con los descendientes de la form. Se almacena 
;;; en el slot 'offspring'.
;;; Extensión 4:
;;; Las antíguas funciones SET-VALUE, SET-ASPECT, GET-VALUE y 
;;; GET-ASPECT son ahora métodos propios de cada form.
;;; Extensión 10:
;;; La herencia ortogonal se implementa mediante el slot 'has'.
;;; dicho slot contiene una lista de pares (objeto valor) que
;;; representa las relaciones ortogonales con otras forms.
;;; Inicialmente esta lista está vacía.
;;; Extension 11:
;;; Implementacion del mecanismo de activacion del sistema de frames 
;;; para su integracion con el sistema de reglas. Esta implementacion 
;;; se realiza mediante la variable global 'form-sensitive'

(defvar *form-sensitive* nil)

(defun form (&key name is-a slots)
   (let* ((the-form (if (get name 'is-a)
                       name
                       (progn 
                         (setf (get name 'is-a) 
                               (if (atom is-a)
                                  (list is-a)
                                  is-a))
                         (dolist (father (get name 'is-a))
                               (setf (get father 'offspring)
                                     (cons name 
                                       (get father 'offspring))))
                         (setf (get name 'offspring) nil)
                         (setf (get name 'has) nil)
                         name))))
      (dolist (slot-content slots)
         (funcall #'method-set-aspect the-form 
           (car  slot-content)
           (cadr slot-content)
           (cadr (cdr slot-content))))
      (if *form-sensitive*
      	  (recuerda-frame the-form)
	  nil)
      the-form))

;;; Funcion para saber si algo es una form
;;;

(defun form-p (form)
  (or (get form 'is-a)
      (get form 'offspring)))

;;; Variable de documentación
;;;

(defvar *documentation* nil)

;;;
;;; Extensión 8:
;;; GET-SLOTS-AT-THIS-LEVEL es la función que muestra información sobre los 
;;; slots de la form que se pasa por parámetro, devolviéndolos en una 
;;; lista.
;;; GET-SLOTS es la función que muestra la información sobre los slots
;;; de la form que se pasa como parámetro incluyendo aquellos que hereda.
;;; 
;;; Extensión 9:
;;; Adaptados para herencia múltiple.

(defun get-slots-at-this-level (form)
   (let ((properties (symbol-plist form))
         (slots nil))
      (do ((prop (car properties) (car properties)))
          ((null properties) slots)
          (case prop 
            ((is-a offspring has) nil)
            (otherwise (setq slots (append slots (list prop))))) 
          (remf properties prop))))

(defun get-slots (form)
   (let ((slots (get-slots-at-this-level form)))
      (if (get form 'is-a)
         (union 
           slots 
           (mapcan #'(lambda (father)
                       (get-slots father))
             (get form 'is-a)))
         slots)))

;;; Extensión 10:
;;; La función WHAT-DOES-IT-HAVE-AT-THIS-LEVEL? devuelve una lista con las forms que
;;; 'tiene' la form.

(defun what-does-it-have-at-this-level? (form)
   (let ((having (mapcar #'(lambda(having) (car having)) (get form 'has))))
      (if (listp having)
         having
         (list having))))

;;; La función WHAT-DOES-IT-HAVE? devuelve una lista con las forms que
;;; 'tiene' la form, buscando a través de la herencia, tanto la
;;; normal como la ortogonal.

(defun what-does-it-have? (form)
   (remove-duplicates
    (append
     (what-does-it-have-at-this-level? form)
     (mapcan #'(lambda(father)
                 (what-does-it-have? father))
       (get form 'is-a)))))

;;; La función WHAT-IS-THIS-FORM? devuelve una lista con todos los ascendientes 
;;; directos de la form.

(defun what-is-this-form? (form)
   (let ((is (get form 'is-a)))
      (if (car is)
         is
         nil)))

;;; La función WHAT-IS-IT? devuelve una lista con todos los ascendientes 
;;; de la form.

(defun what-is-it? (form)
   (remove-duplicates
    (append
     (what-is-this-form? form)
     (mapcan #'(lambda(father)
                 (what-is-it? father))
       (get form 'is-a)))))

;;; La funcion IS-A? comprueba si la form es descendiente del tipo.
;;; Se emplea para el aspecto TYPE y es recursiva. Devuelve cierto
;;; si es descendiente del tipo. Falso en caso contrario.
;;; Extensión 9:
;;; Adaptado para herencia múltiple.

(defun is-a? (form type)
   (or (eq form type)
       (member type (get form 'is-a))
       (mapcan #'(lambda (father)
                   (is-a? father type))
         (get form 'is-a))))

;;; la funcion HOW-MANY-DOES-THIS-FORM-HAVE-AT-THIS-LEVEL? devuelve 
;;; cuantas unidades de la form indicada tiene la form.

(defun how-many-does-this-form-have-at-this-level? (form object)
   (let ((having (cadr (assoc object (get form 'has)))))
      (if having having 0)))

;;; la función WHAT-DOES-IT-HAVE-WITH-VALUES? devuelve los pares objeto número
;;; que tiene una form y sus antecesores. Es una función auxiliar para la función
;;; HOW-MANY-DOES-IT-HAVE?

(defun what-does-it-have-with-values? (form)
   (remove-duplicates 
    (append
     (get form 'has)
     (mapcan #'(lambda(father)
                 (what-does-it-have-with-values? father))
       (get form 'is-a)))
     :key #'car))

;;; la función HOW-MANY-DOES-IT-HAVE? devuelve cuantas unidades de la form indicada
;;; tiene la form buscando en la jerarquía.

(defun how-many-does-it-have? (form object)
   (apply #'+
     (if (member object (what-does-it-have-at-this-level? form))
        (list (how-many-does-this-form-have-at-this-level? form object))
        (mapcar #'(lambda (have)
                    (let ((obj (car have)))
                       (if (is-a? obj object)
                          (cadr have)
                          (* (cadr have) (how-many-does-it-have? obj object)))))
          (what-does-it-have-with-values? form)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definición del algoritmo de herencia.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; La función INHERITANCE-FUNCTION realiza la herencia de slots
;;; según el valor del aspecto INHERITANCE. En caso de que el slot
;;; carezca de este aspecto, la función aplicará una de las formas de
;;; herencia por defecto.
;;;
;;; La función de herencia es capaz de realizar 4 tipos de herencias:
;;;    Herencia por defecto (INHERITANCE OVERRIDE)
;;;    Herencia por unión   (INHERITANCE UNION)
;;;    Herencia por máximo  (INHERITANCE MAXIMUN)
;;;    Herencia por mínimo  (INHERITANCE MINIMUN)
;;; La elección de un método u otro se hace en función del aspecto 
;;; INHERITANCE del slot.

;;; Extensión 5: 
;;; Algoritmo de herencia parametrizable a nivel de slot según el 
;;; aspecto INHERITANCE.
;;; Extensión 9:
;;; Algoritmo de herencia permite herencia múltiple. EL algoritmo
;;; seguido es búsqueda en profundidad y recorriendo la lista de
;;; ascendientes por orden de introducción.

(defun f-general (form slot aspect)
   (do* ((fathers (get form 'is-a))
         (father  (car fathers) (car fathers-list))
         (fathers-list fathers (cdr fathers-list))
         (value   (cadr (assoc aspect (get form slot)))
                  (f-general father slot aspect)))
        ((or value (null fathers-list)) value)))

(defun f-override (form slot)
   (do* ((fathers (get form 'is-a))
         (father  (car fathers) (car fathers-list))
         (fathers-list fathers (cdr fathers-list))
         (value   (cadr (assoc '= (get form slot)))
            (f-override father slot)))
         ((or value (null fathers-list)) value)))

(defun f-union (form slot)
   (remove-duplicates 
     (append 
       (if (not (null (cadr (assoc '= (get form slot)))))          
          (list (cadr (assoc '= (get form slot)))))
       (mapcan #'(lambda (father)
                   (f-union father slot))
         (get form 'is-a)))))

(defun f-maximun (form slot)
   (apply #'max
      (append 
          (if (not (null (cadr (assoc '= (get form slot)))))          
             (list (cadr (assoc '= (get form slot)))))
          (mapcan #'(lambda (father)
                      (f-union father slot))
            (get form 'is-a)))))

(defun f-minimun (form slot)
   (apply #'min
      (append 
          (if (not (null (cadr (assoc '= (get form slot)))))          
             (list (cadr (assoc '= (get form slot)))))
          (mapcan #'(lambda (father)
                      (f-union father slot))
            (get form 'is-a)))))

(defun inheritance-function (form slot aspect &optional type)
   (let ((the-type (if type type
          (f-general form slot 'inherited))))
      (if (eq aspect '=)
        (case the-type
          ((nil override)
           (f-override form slot))
          ((maximun)
           (f-maximun form slot))
          ((minimun)
           (f-minimun form slot))
          ((union)
           (f-union form slot)))
         (f-general form slot aspect))))
                                        
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definiciones del vocabulario de manipulación de datos
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; (METHOD-SET-ASPECT form slot aspecto valor) :: valor
;;; Guarda el valor del aspecto del slot de la form.
;;;
;;; Cada slot corresponde con una propiedad del símbolo.
;;; El contenido del slot esta formado por listas de aspectos 
;;; compuestas por un símbolo identificador del aspecto y 
;;; su contenido:
;;;      =       para el valor
;;;  IF-NEEDED   para el método de acceso
;;;  IF-ADDED    para el método de modificación (Extensión 2)
;;;  INHERITED   para el tipo de herencia (Extensión 5)
;;;  DOC         para la documentación de la form (Extensión 6)
;;;  MIN         para el límite inferior (Extensión 7)
;;;  MAX         para el límite superior (Extensión 7)
;;;  TYPE        para la comprobación de tipos (Extensión 7)

(defun method-set-aspect (form slot aspect value)
   (let* ((content (get form slot)))
      (cond (content
             (if (assoc aspect content)
                (rplacd (assoc aspect content) (list value))
                (setq content (cons (list aspect value) content))))
            (t
             (setq content (cons (list aspect value) content))))
      (setf (get form slot) content)))
    
;;; METHOD-SET-VALUE está especializado en el aspecto =
;;; Extensión 2:
;;; Existe un nuevo demon: IF-ADDED, que se activa en la 
;;; modificación del valor de un slot.
;;; Extension 7:
;;; El valor introducido con METHOD-SET-VALUE se comprueba según los 
;;; aspectos MIN, MAX y TYPE si están definidos

(defun method-set-value (form slot value)
   (let ((added (method-get-aspect form slot 'if-added))
         (min   (method-get-aspect form slot 'min))
         (max   (method-get-aspect form slot 'max))
         (type  (method-get-aspect form slot 'type))
         (error nil))
      (if added
         (funcall added form slot value)
         (progn
          (when (and min (< value min))
               (format *documentation* "No se cumple el valor minimo~%")
               (setq error t))   
          (when (and max (> value max))
               (format *documentation* "No se cumple el valor maximo~%")
               (setq error t))
          (when (and type (is-a? value type))
               (format *documentation* "El valor no es del tipo indicado~%")
               (setq error t))
          (if (not error)
             (method-set-aspect form slot '= value)
             nil)))))
                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definiciones del vocabulario de relación de herencia ortogonal
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; (METHOD-SET-HAVE form have-list)
;;; Esta función establece la relación de tener de una form.
;;; La lista have-list debe ser una lista de pares (nombre valor).
;;; La form pierde sus antiguas relaciones de 'has' y adquiere
;;; las nuevas de have-list.

(defun method-set-have (form have-list)
   (setf (get form 'has) have-list))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definición de las funciones de modificación de los aspectos MAX,
;;;  MIN y TYPE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Estas funciones son las funciones que llaman los métodos de cada
;;; objeto.

(defun method-set-minimun (form slot value)
   (let ((min (method-get-aspect form slot 'min)))
      (if min
         (if (> value min)
            (method-set-aspect form slot 'min value)
            (format *documentation* 
              "No cumple la restricción de valor minimo heredado~%"))
         (method-set-aspect form slot 'min value))))
            
(defun method-set-maximun (form slot value)
   (let ((max (method-get-aspect form slot 'max)))
      (if max
         (if (< value max)
            (method-set-aspect form slot 'max value)
            (format *documentation* 
              "No cumple la restricción de valor maximo heredado~%"))
         (method-set-aspect form slot 'max value))))

(defun method-set-type (form slot value)
   (let ((type (method-get-aspect form slot 'type)))
      (if type
         (if (is-a? value type)
            (method-set-aspect form slot 'type value)
            (format *documentation* 
              "No cumple la restricción de tipo heredado~%"))
         (method-set-aspect form slot 'type value))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definiciones del vocabulario de acceso de datos
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;(METHOD-GET-ASPECT form slot aspecto) :: valor
;;; Devuelve el valor del aspecto del slot de la form accediendo por 
;;; la jerarquía.
;;;
;;; Extensión 5: 
;;; Algoritmo de herencia parametrizable a nivel de slot según el 
;;; aspecto INHERITANCE con la funcion INHERITANCE-FUNCTION.

(defun method-get-aspect (form slot aspect)
   (inheritance-function form slot aspect))

;;;
;;; METHOD-GET-VALUE está especializado en el aspecto = 
;;; Obtiene el valor del aspecto = de un slot con herencia
;;; aplicando el demon IF-NEEDED.
;;;

(defun method-get-value (form slot)
   (let ((needed (method-get-aspect form slot 'if-needed)))
      (if needed
         (funcall needed form slot)
         (method-get-aspect form slot '=))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definiciones del vocabulario de relación de herencia ortogonal
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Extensión 10:
;;; La herencia ortogonal se implementa mediante el slot 'has'.
;;; dicho slot contiene una lista de pares (objeto valor) que
;;; representa las relaciones ortogonales con otras forms.
;;; Inicialmente esta lista está vacía.
;;;
;;; (METHOD-GET-HAVE form)
;;; Esta función muestra las relación de tener de una form.
;;; La lista have-list debe ser una lista de pares (nombre valor).
;;; La form pierde sus antiguas relaciones de 'has' y adquiere
;;; las nuevas de have-list.

(defun method-get-have (form have-list)
   (get form 'has))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definición de las funciones de acceso de los aspectos MAX, MIN y 
;;; TYPE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Estas funciones son las funciones que llaman los métodos de cada
;;; objeto.

(defun method-get-minimun (form slot)
   (method-get-aspect form slot 'min))

(defun method-get-maximun (form slot)
   (method-get-aspect form slot 'max))

(defun method-get-type (form slot)
   (method-get-aspect form slot 'type))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Extensión 3:
;;; Implementación del protocolo de envío de mensajes y el empleo de
;;; métodos propios de cada form. Los métodos se heredan mediante el
;;; mecanismo normal de herencia de aspectos.
;;;
;;; La función <-- implementa el protocolo de envio de mensajes
;;;  para simular el comportamiento orientado a objeto.
;;;
;;;  form: es el símbolo del form
;;;  mensaje: es nombre del mensaje a enviar (método a ejecutar)
;;;  parms: recoge los parámetros a necesarios en el método 
;;;      del mensaje
;;;
;;; CREATE-METHOD es una función que añade un metodo a una form. 
;;; El almacenamiento de los métodos se realiza en los slots, 
;;; almacenando el par (method función), de tal forma que cuando se 
;;; envía a la form un mensaje (nombre del slot), la form ejecute la 
;;; función asociada a ese mensaje (slot).

(defun create-method (form method-name method-function)
   (method-set-aspect form method-name 'method method-function))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; <-- es la función que permite invocar un método de una form. La
;;; función simplemente recoge del slot correspondiente al mensaje 
;;; el método, ejecutándolo con los parámetros especificados en el 
;;; paso de mensajes. El mecanismo de herencia de metodos se 
;;; implementa igual que cualquier slot mediante el método get-aspect.

(defun <-- (form message &rest parms)
   (let* ((method-function (method-get-aspect form message 'method)))
      (if method-function 
         (apply method-function form parms))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Existen sinónimos de los métodos de acceso y modificación de los
;;; slots. Estos sinónimos simplemente llaman al método apropiado.
;;; Extensión 4:
;;; Las antíguas funciones SET-VALUE, SET-ASPECT, GET-VALUE y 
;;; GET-ASPECT son ahora métodos propios de cada form.

(defun set-aspect (form slot aspect value)
   (<-- form 'set-aspect slot aspect value))

(defun set-value (form slot value)
   (<-- form 'set-value slot value))

(defun set-minimun (form slot value)
   (<-- form 'set-minimun slot value))

(defun set-maximun (form slot value)
   (<-- form 'set-maximun slot value))

(defun set-type (form slot value)
   (<-- form 'set-type slot value))

(defun set-have (form have-list)
   (<-- form 'set-have have-list))

(defun get-aspect (form slot aspect)
   (<-- form 'get-aspect slot aspect))

(defun get-value (form slot)
   (<-- form 'get-value slot))

(defun get-minimun (form slot)
   (<-- form 'get-minimun slot))

(defun get-maximun (form slot)
   (<-- form 'get-maximun slot))

(defun get-type (form slot)
   (<-- form 'get-type slot))

(defun get-have (form)
   (<-- form 'get-have))


;; Funcion para definir la base del sistema de forms

(defun base-form (name)
   (form :name name
         :is-a nil)
   (create-method name 'set-value   #'method-set-value)
   (create-method name 'set-aspect  #'method-set-aspect)
   (create-method name 'set-minimun #'method-set-minimun)
   (create-method name 'set-maximun #'method-set-maximun)
   (create-method name 'set-type    #'method-set-type)
   (create-method name 'set-have    #'method-set-have)
   (create-method name 'get-value   #'method-get-value)
   (create-method name 'get-aspect  #'method-get-aspect)
   (create-method name 'get-minimun #'method-get-minimun)
   (create-method name 'get-maximun #'method-get-maximun)
   (create-method name 'get-type    #'method-get-type)
   (create-method name 'get-have    #'method-get-have))
