;*********************************************************************
; Módulo: IERL
; Uso:    IAAA Experimenal Representation Language
; Autor:  Pedro R. Muro
;         Roberto Sobreviela Ruiz
; email:  419245@cepsz.unizar.es
;         sobreviela@teleline.es
;*********************************************************************
; Fichero: BDC.lsp      Fecha Creación: 8 de julio de 1999
; Versión: 0.0.1        Fecha Modificación: 12 de julio de 1999
; Estado:  Desarrollo   Autor: Roberto Sobreviela Ruiz
;---------------------------------------------------------------------
; Uso: Base de conocimiento para la prueba de IERL.
; Comentarios:
; Historia:
;*********************************************************************

(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))

(defun prueba-herencia ()
   (let ()
      (base-form 'a)
      (form :name 'b :is-a 'a)
      (form :name 'k :is-a 'a)      
      (form :name 'c :is-a 'b)
      (form :name 'j :is-a 'b)
      (form :name 'd :is-a 'c)
      (form :name 'e :is-a 'c)
      (form :name 'f :is-a 'c)
      (form :name 'g :is-a '(d e f))
      (form :name 'l :is-a '(j k))
      (form :name 'h :is-a 'g)
      (form :name 'i :is-a '(g l))
      
      (set-value 'd 'prop1  1)
      (set-value 'e 'prop2  11)
      (set-value 'l 'prop3  111)
      (set-value 'd 'propmin 10)
      (set-value 'e 'propmin 20)
      (set-value 'f 'propmin 30)
      (set-value 'd 'propmax 10)
      (set-value 'e 'propmax 20)
      (set-value 'f 'propmax 30)      
      (set-value 'd 'propunion 'aaa)
      (set-value 'e 'propunion 'bbb)
      (set-value 'f 'propunion 'ccc)
      (set-aspect 'g 'propunion 'inherited 'union)
      (set-aspect 'g 'propmin 'inherited 'minimun)     
      (set-aspect 'g 'propmax 'inherited 'maximun)))

(defun animales ()
   (let ()
      (base-form 'objeto)
      (form :name 'vertebrado :is-a 'objeto)
      (form :name 'mamifero   :is-a 'vertebrado)
      (form :name 'persona    :is-a 'mamifero)
      (form :name 'hombre     :is-a 'persona)
      (form :name 'mujer      :is-a 'persona)
      (form :name 'paco       :is-a 'hombre)
      
      (form :name 'espina    :is-a 'objeto)
      (form :name 'digito    :is-a 'objeto)
      (form :name 'dedo-mano :is-a 'digito)
      (form :name 'dedo-pie  :is-a 'digito)
      (form :name 'pie       :is-a 'objeto)
      (form :name 'mano      :is-a 'objeto)
      
      (set-have 'vertebrado (list '(espina 1)))
      (set-have 'persona    (list '(pie 2) '(mano 2)))
      (set-have 'pie        (list '(dedo-pie 5)))
      (set-have 'mano       (list '(dedo-mano 5)))))
 
;;; Ejercicios de comprobación de las extensiones:
;;; Primera parte: Comprobación de la herencia múltiple.
;;; 1. Cargar la base de conocimiento prueba de herencia
;;;

(prueba-herencia)

;;; 2. Comprobar el funcionamiento de las funciones 
;;;    de acceso como métodos

(get-value 'd 'prop1)
(get-value 'e 'prop2)

;;; 3. Comprobar la herencia múltiple por defecto
;;;

(get-value 'h 'prop1)
(get-value 'h 'prop2)
(get-value 'h 'prop3) ;;; No tiene acceso
(get-value 'i 'prop1)
(get-value 'i 'prop2)
(get-value 'i 'prop3)

;;; 4. Comprobar la herencia múltiple por unión
;;;

(get-value 'h 'propunion)

;;; 5. Comprobar la herencia múltiple por máximo
;;;

(get-value 'h 'propmax)

;;; 6. Comprobar la herencia múltiple por mínimo
;;;

(get-value 'h 'propmin)

;;; 7. Comprobar todos los slots de una form,
;;;    incluyendo los heredados

(get-slots 'h)

;;; 8. Comprobar el funcionamiento de los aspectos restrictivos
;;;    max, min y type

(setq *documentation* t)

(set-maximun 'g 'pp1 10)
(get-maximun 'g 'pp1)
(set-value   'g 'pp1 20)
(set-maximun 'h 'pp1 20)
(set-maximun 'h 'pp1 5)
(set-value   'h 'pp1 3)

(set-minimun 'g 'pp2 1)
(get-minimun 'g 'pp2)
(set-value   'g 'pp2 0)
(set-minimun 'h 'pp2 0)
(set-minimun 'h 'pp2 2)
(set-value   'h 'pp2 1)

(set-type  'g 'pp3 'd)
(get-type  'g 'pp3)
(set-value 'g 'pp3 'h)
(set-type  'h 'pp3 'c)
(set-type  'h 'pp3 'g)
(set-value 'h 'pp3 'h)

;;; Segunda Parte: Comprobación de la herencia ortogonal
;;; 1. Cargar la base de conocimiento de herencia ortogonal

(animales)

;;; 2. Comprobar el acceso a las partes de una form
;;;

(what-does-it-have-at-this-level? 'paco)
(what-does-it-have-at-this-level? 'persona)

;;; 3. Comprobar la herencia de partes por herencia normal
;;;

(what-does-it-have? 'mamifero)
(what-does-it-have? 'paco)

;;; 4. Comprobar los ascendientes de una form
;;;

(what-is-this-form? 'paco)
(what-is-this-form? 'dedo-pie)

;;; 5. Comprobar todos los ascendientes de una form
;;;

(what-is-it? 'paco)
(what-is-it? 'dedo-mano)

;;; 6. Preguntar si una form tiene un ascendiente
;;;

(is-a? 'paco 'vertebrado)
(is-a? 'paco 'pie)

;;; 7. Comprobar cuantos elementos de una parte tiene una form
;;;

(how-many-does-this-form-have-at-this-level? 'paco 'pie)
(how-many-does-this-form-have-at-this-level? 'vertebrado 'espina)
(how-many-does-this-form-have-at-this-level? 'pie 'dedo-pie)
(how-many-does-this-form-have-at-this-level? 'pie 'digito)

;;; 8. Comprobar la herencia del número de elementos de las partes
;;;    mediante la herencia múltiple y la herencia ortogonal.

(how-many-does-it-have? 'paco 'espina)
(how-many-does-it-have? 'paco 'pie)
(how-many-does-it-have? 'paco 'dedo-pie)
(how-many-does-it-have? 'paco 'digito)
