;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa   ;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;            Pedro R. Muro & Jose L. Villarroel
;;;
;;;                         20-2-1991
;;;
;;;      IERL: iaaa experimental representation language
;;;
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa  iaaa   ;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;
;;;


;;; La variable *tabla-de-forms* va a contener la lista de todas las 
;;;  forms que se creen en un determinado contexto.
;;;
(defvar *tabla-de-forms* nil 
  "va a guardar la lista de todas las forms")



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Una form tiene tres partes: un IS-A, slots y metodos
;;;  esta implementada mediante la lista de propiedades del simbolo.
;;;
;;; CREATE-FORM :is-a padre :nombre nombre:: form
;;; Crea una form que es una especializacion del padre con nombre.
;;;
(defun create-form (&key is-a name)
  (let* ()
    (setf (get name 'is-a) is-a)
    (push name
          *tabla-de-forms*)
    name))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FORM :: valor
;;; Modifica los valors de una form y la crea en caso de que no exista.
;;;
;;; FORMA :: valor
;;; Hace lo mismo pero usando una macro que permite que los parametros
;;;  no sean evaluados.
;;;
(defun form (&key name is-a slots)
  (let* ((la-form (if (get name 'is-a)
                    name
                    (create-form :name name :is-a is-a)))
         )
    (dolist (slot-conten slots)
      (funcall #'set-aspect la-form 
               (car slot-conten)
               (cadr slot-conten)
               (cadr(cdr slot-conten))))
    la-form))


(defmacro forma (&key name is-a slots)
   `(let* ((la-form (if (get ',name 'is-a)
                    ',name
                    (create-form :name ',name :is-a ',is-a)))
            )
      (dolist (slot-conten ',slots)
        (funcall #'set-aspect la-form 
                 (car slot-conten)
                 (cadr slot-conten)
                 (cadr (cdr slot-conten))))
      la-form))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;(SET-ASPECT form slot aspecto valor) :: valor
;;; Guarda el valor del aspecto del slot de la form.
;;;
;;; Cada slot corresponde con una propiedad del simbolo.
;;; El contenido del slot esta formado por listas de aspectos compuestas
;;;  por un simpbolo identificador del aspecto y su contenido:
;;;          =  para el valor
;;;  IF-NEEDED  para el metodo de acceso
;;;
(defun set-aspect (form slot aspecto valor)
  (let* ((contenido (get form slot)))
    (cond (contenido
           (if (assoc aspecto contenido)
             (rplacd (assoc aspecto contenido) (list valor))
             (setq contenido (cons (list aspecto valor) contenido))))
          (t
           (setq contenido (cons (list aspecto valor) contenido))))
    (setf (get form slot) contenido)))


;;; SET-VALUE esta especializado en el aspecto =
;;;  el parametro MENSAJE no es realmente necesario si no se utiliza el modo
;;;  orientado a objeto 
;;; (en POO normalmente todos los metodos reciben al menos dos parametros,
;;;  el primero es el OBJETO y el segundo el MENSAJE.
;;;
(defun set-value (form slot valor)
  (set-aspect form slot '= valor))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Aqui comienzan las definiciones del vocabulario de acceso y
;;;  manipulacion de datos
;;;
;;;(GET-ASPECT form slot aspecto) :: valor
;;; Devuelve el valor del aspecto del slot de la form
;;;


;;;
;;; FIND-SIMPLE-ASPECT-FORM toma un aspecto de un slot sin acceder por la
;;;  jerarquia.
;;;
(defun find-simple-aspect-form (form slot aspecto)
  (cadr (assoc aspecto (get form slot))))


;;;
;;; FIND-ASPECT-FROM-SUPERS toma un aspecto de un slot accediendo por la
;;;  jerarquia.
;;;
(defun find-aspect-from-supers (form slot aspecto)
  (let* ((value (assoc aspecto (get form slot))))
    (if value 
      (cadr value)
      (if (get form 'is-a)
        (find-aspect-from-supers (get form 'is-a) slot aspecto)
        ))))

;;;
;;; FIND-SLOT-VALUE-FORM toma el aspecto = de un slot accediendo por la
;;;  jerarquia.
;;; Amplia el vocabulario para el aspecto = pues es muy utilizado.
;;;
(defun find-slot-value-form (form slot)
  (find-aspect-from-supers form slot '=))


;;;
;;; GET-VALUE obtiene el valor del aspecto = de un slot con herencia
;;;  y aplicando ademas el demond en el aspecto IF-NEEDED.
;;;
(defun get-value (form slot)
  (let ((needed (find-aspect-from-supers form slot 'if-needed)))
    (if needed
      (funcall needed form slot)
      (find-slot-value-form form slot))))

;;;
;;; FIND-SLOT-FROM-SUPERS toma el contenido entero de un slot accediendo por la 
;;;  jerarquia.
;;; Puede ser utilizado para heredar mensajes en el estilo orientado a objeto
;;;
(defun find-slot-from-supers (form slot)
  (let* ((value (get form slot)))
    (if value 
      value
      (if (get form 'is-a)
        (find-slot-from-supers (get form 'is-a) slot)
        ))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Creacion de la estructura de conocimiento para el problema de
;;;  los apartamentos.
;;; El objetivo es disponer de una representacion del conocimiento
;;;  que permita obtener informacion a una empresa inmobiliaria.
;;;  Para ello se crea una base de datos de forms con algunos metodos.
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Generacion de funciones para los demonds
;;;


;;; CALCULA-RUIDO es una funcion IF-NEEDED que calcula el nivel de ruido
;;;  de un apartamento. 
;;; Si existe un valor = lo toma, si no lo calcula dependiendo de
;;;  la altura del piso.
;;;
;;; CALCULA-RUIDO-EN-CASA lo calcula en base a la distancia 
;;;  de la casa a la carretera.
;;;
(defun calcula-ruido (form slot)
  (let* ((valor (find-aspect-from-supers form 'ruido-calle '=))
         piso)
    (cond (valor valor)
          (t (setq piso (get-value form 'piso))
             (cond ((> piso 15) 'muy-bajo)
                   ((> piso 8) 'bajo)
                   ((> piso 4) 'medio)
                   ((> piso 1) 'alto)
                   (t 'muy-alto))))))

(defun calcula-ruido-en-casa (form slot)
  (let* ((valor (find-aspect-from-supers form 'ruido-calle '=))
         distancia)
    (cond (valor valor)
          (t (setq distancia (get-value form 'distancia-carretera))
             (cond ((> distancia 1000) 'muy-bajo)
                   ((> distancia 100) 'bajo)
                   ((> distancia 30) 'medio)
                   ((> distancia 10) 'alto)
                   (t 'muy-alto))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Generacion de la jerarquia de forms
;;;
;;;   La funcion GBD genera la base de datos de las forms
;;;

(defun gbd ()
  (setq  *tabla-de-forms* nil)
  (let ()
    (create-form :is-a nil :name 'object)
    (form :name 'cosa 
          :is-a 'object)
    
    (form :name 'vivienda
          :is-a 'cosa)
    
    (form :name 'apartamento
          :is-a 'vivienda
          :slots (list (list 'ruido-calle 'if-needed #'calcula-ruido)))
    
    (form :name 'chalet
          :is-a 'vivienda
          :slots (list (list 'ruido-calle 'if-needed #'calcula-ruido-en-casa)
                       ))
    
    (form :name 'apt-breton-22
          :is-a 'apartamento
          :slots '((calle-nombre = Breton)
                   (calle-numero = 22)
                   (color-pared = blanco)
                   (material-suelo = madera)))
    
    (form :name 'apt-22-1
          :is-a 'apt-breton-22
          :slots '((numero-habitaciones = 3)
                   (piso = 2)))
    
    (form :name 'chalet-montesol-5
          :is-a 'chalet
          :slots '((calle-nombre = urbanizacion-montesol)
                   (calle-numero = 5)
                   (numero-habitaciones = 5)
                   (pisos = 2)
                   (distancia-carretera = 200)))
    ))

;;;;;;;;;;;;;;;;;;;
;;;
;;; Puedes probar a obtener valores con la funcion GET-VALUE
;;;

;(get-value 'apt-22-1 'ruido-calle)
;--> ALTO

;(get-value 'chalet-montesol-5 'ruido-calle)
;--> BAJO

;;;
;(set-value 'apt-breton-22 'ruido-calle 'muy-alto)
;(set-value 'chalet 'ruido-calle 'muy-bajo)

;(get-value 'apt-22-1 'ruido-calle)
;--> MUY-ALTO

;(get-value 'chalet-montesol-5 'ruido-calle)
;--> MUY-BAJO









;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; La funcion <-- implementa el protocolo de envio de mensajes
;;;  para simular el comportamiento orientado a objeto.
;;;
;;;  form: es el simbolo del form
;;;  mensaje: es nombre del mensaje a enviar
;;;  parms: recoge los parametros a necesarios en el metodo del mensaje
;;;
(defun <-- (form mensaje &rest parms)
  (let ((metodos (find-slot-from-supers form mensaje)))
    (cond 
     ((null metodos)
      (format t
              "ERROR: en envia no existe ningun metodo para ~A ~A"
              form mensaje))
     ((atom metodos)
      (apply metodos form mensaje parms))
     (t (mapcar #'(lambda (metodo)
                    (apply metodo form mensaje parms))
                metodos)))))

(defun create-method (form mensaje metodo)
  (setf (get form mensaje) metodo))

;;;
;;; La funcion GBDOO genera la base de datos orientada a objeto
;;;
(defun gbdoo ()
  (let ()
    (create-method 'object 'get-val #'get-value)
    (create-method 'object 'set-val #'set-value)
    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Creacion de la estructura de conocimiento para el problema de
;;;  los animales.
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Generacion de la jerarquia de forms
;;;
;;;   La funcion GBDA genera la base de datos de las forms
;;;
;;;
;;;  En la implementacion propuesta, tiene se considera un atributo mas.
;;; Su contenido sera una lista de listas con dos elementos: el objeto que 
;;; tiene y la cantidad.
;;;
(defun gbda ()
  (setq  *tabla-de-forms* nil)
  (let ()
    (create-form :is-a nil :name 'object)

    (form :name 'espina
          :is-a 'object)
    
    (form :name 'digito
          :is-a 'object)
    
    (form :name 'dedo-pie
          :is-a 'digito)
    
    (form :name 'dedo-mano
          :is-a 'digito)
    
    (form :name 'pie 
          :is-a 'object
          :slots '((tiene = ((dedo-pie 5)))))
    
    (form :name 'mano 
          :is-a 'object
          :slots '((tiene = ((dedo-mano 5)))))
    
    (form :name 'vertebrado 
          :is-a 'object
          :slots '((tiene = ((espina 1)))))
    
    (form :name 'mamifero
          :is-a 'vertebrado)
    
    (form :name 'persona
          :is-a 'mamifero
          :slots '((tiene = ((pie 2)(mano 2)))))
      
    (form :name 'hombre
          :is-a 'persona)
    
    (form :name 'mujer
          :is-a 'persona)
    
    (form :name 'paco
          :is-a 'hombre)
    ))

;;;
;;; La pregunta es-un? es facil de contestar sin mas que acceder verticalmente 
;;;  por la jerarquia y comprobar si alguno de los padres, o el objeto mismo, 
;;;  es el objeto buscado.
;;;

(defun es-un? (form es)
  (if (eql form es) es
      (if (get form 'is-a) 
        (es-un? (get form 'is-a) es))))


;;; Para contestar a preguntas sobre tiene primero es preciso poder
;;;  contestar a lo que-tiene? considerando unicamente el objeto mismo.
;;; Dada la implementacion utilizada es preciso crear una herencia especial
;;;  para tiene.
;;; 

;;; (QUE-TIENE? form) --> lista de listas con pares objeto que tiene 
;;;  cantidad de dicho objeto.
;;;
(defun que-tiene? (form)
  (let* ((aspecto-a-este-nivel (assoc '= (get form 'tiene)))
         (tiene-a-este-nivel (if aspecto-a-este-nivel 
                               (cadr aspecto-a-este-nivel)))
         (padre (get form 'is-a))
         (tiene-a-nivel-superior (if padre (que-tiene? padre))))
    (dolist (algo tiene-a-nivel-superior)
      (if (null (assoc (car algo) tiene-a-este-nivel))
        (push algo tiene-a-este-nivel)))
    tiene-a-este-nivel))


;;; (TIENE-PARTE? form parte) --> T o NIL 
                             
(defun tiene-parte? (form la-parte)
  (let* ((partes-local (que-tiene? form)))
    (if partes-local
      (do* ((partes partes-local (cdr partes))
            (parte (car partes) (car partes))
            (la-tiene (or (es-un? (car parte) la-parte)
                          (tiene-parte? (car parte) la-parte))
                      (or (es-un? (car parte) la-parte)
                          (tiene-parte? (car parte) la-parte))))
           ((or (null (cdr partes))
                la-tiene)
            (if la-tiene t))
        ))))
            


(defun cuantos? (form la-parte)
  (let* ((partes-local (que-tiene? form))
         (valor 0))
    (if partes-local
      (dolist (parte partes-local)
        (setq valor 
              (if (es-un? (car parte) la-parte)
                (+ valor (cadr parte))
                (+ valor (* (cuantos? (car parte) la-parte) 
                            (cadr parte)))))))
    valor))


(defun tiene-parte2? (form la-parte)
  (null (equal 0 (cuantos? form la-parte))))