; ==================================================
; === programa: ENCADENAMIENTO REGRESIVO
; === probarlo asi:
; === * (back-chain '(robbie es leopardo))
; === SI
; === * (back-chain '(suzie es albatros))
; === SI
; === * (back-chain '(robbie es (? x)))
; === --> X = MAMIFERO
; === --> X = CARNIVORO
; === --> X = LEOPARDO
; === * (back-chain '((? animal) es (? x)))
; === --> ANIMAL = ROBBIE X = MAMIFERO
; === --> ANIMAL = SUZIE X = AVE
; === --> ANIMAL = ROBBIE X = CARNIVOR
; === --> ANIMAL = ROBBIE X = LEOPARDO
; === --> ANIMAL = SUZIE X = ALBATROS
; === autor: Jose Rafael Rodriguez Ochoa
; === fecha: enero / 1998
; ==================================================
; ==================================================
; === comando: corresponde
; === funcion: match
; === fecha: enero / 1998
; ==================================================
(defun corresponde (p d &optional ligaduras)
(cond ((elementos-p p d) (corresponde-atomos p d ligaduras))
((variable-p p) (corresponde-variable p d ligaduras))
((recursivos-p p d) (corresponde-partes p d ligaduras))
(t 'FAIL)
)
)
; ==================================================
; === comando: elementos-p
; === funcion: probar si ambos (p y d) son atomos
; === fecha: enero / 1998
; ==================================================
(defun elementos-p (p d)
(and (atom p) (atom d))
)
; ==================================================
; === comando: variable-p
; === funcion: probar si (p) es una lista y su
; === primer elemento es variable
; === fecha: enero / 1998
; ==================================================
(defun variable-p (p)
(and (listp p) (eq '? (first p)))
)
; ==================================================
; === comando: recursivos-p
; === funcion: probar si (p y q) son listas
; === fecha: enero / 1998
; ==================================================
(defun recursivos-p (p d)
(and (listp p) (listp d))
)
; ==================================================
; === comando: corresponde-atomos
; === funcion: si (p y q) son iguales regresa
; === (ligaduras) sino FALLA
; === fecha: enero / 1998
; ==================================================
(defun corresponde-atomos (p d ligaduras)
(if (eql p d) ligaduras 'FAIL)
)
; ==================================================
; === comando: corresponde-variable
; === funcion: verificar si se conoce la variable
; === de patron
; === de nuevo
; === si no, agrega nueva asociacion
; === fecha: enero / 1998
; ==================================================
(defun corresponde-variable (p d ligaduras)
(let ((ligadura (encuentra-ligadura p ligaduras)))
(if ligadura (corresponde (extrae-valor ligadura) d ligaduras)
(agrega-ligadura p d ligaduras)
)
)
)
; ==================================================
; === comando: corresponde-partes
; === corresponden produciendo nuevas ligaduras
; === si no, FALLA
; === usando las ligaduras resultantes
; === fecha: enero / 1998
; ==================================================
(defun corresponde-partes (p d ligaduras)
(let ((resultado (corresponde (first p) (first d) ligaduras)))
(if (eq 'FAIL resultado) 'FAIL
(corresponde (rest p) (rest d) resultado)
)
)
)
; ==================================================
; === comando: encuentra-ligadura
; === funcion: encontrar una ligadura
; === fecha: enero / 1998
; ==================================================
(defun encuentra-ligadura (expresion-variable-patron ligadura)
(unless (eq '_ (extrae-variable expresion-variable-patron))
(assoc (extrae-variable expresion-variable-patron) ligadura)
)
)
; ==================================================
; === comando: agrega-ligadura
; === fecha: enero / 1998
; ==================================================
(defun agrega-ligadura (expresion-variable-patron dato ligaduras)
(if (eq '_ (extrae-variable expresion-variable-patron)) ligaduras
(cons (haz-ligadura (extrae-variable expresion-variable-patron) dato) ligaduras)
)
)
; ==================================================
; === comando: extrae-ligaduras
; === funcion: extraer una ligadura
; === fecha: enero / 1998
; ==================================================
(defun extrae-variable (exp-var-pat)
(second exp-var-pat)
)
; ==================================================
; === comando: haz-ligadura
; === funcion: crear una ligadura con (var y dato)
; === fecha: enero / 1998
; ==================================================
(defun haz-ligadura (var dato)
(list var dato)
)
; ==================================================
; === comando: recuerda-afirmacion
; === funcion: agregar nuevas afirmaciones al final
; === fecha: enero / 1998
; ==================================================
(defun recuerda-afirmacion (afirmacion)
(recuerda-flujo afirmacion *afirmaciones*)
)
; ==================================================
; === comando: recuerda-regla
; === funcion: agregar nuevas reglas al final
; === fecha: enero / 1998
; ==================================================
(defun recuerda-regla (regla)
(recuerda-flujo regla *reglas*)
)
; ==================================================
; === comando: recuerda-flujo
; === funcion: agregar nuevos flujos al final
; === fecha: enero / 1998
; ==================================================
(defmacro recuerda-flujo (objeto variable)
`(unless (miembro-de-flujo ,objeto ,variable)
(setf ,variable
(agrega-a-flujo ,variable
(construye-flujo ,objeto 'flujo-vacio)))
,objeto)
)
; ==================================================
; === comando: miembro-de-flujo
; === funcion: determinar si una cosa dada es un objeto en un flujo
; === fecha: enero / 1998
; ==================================================
(defun miembro-de-flujo (objeto flujo)
(cond ((final-del-flujo-p flujo) nil)
((equal objeto (principio-del-flujo flujo)) t)
(t (miembro-de-flujo objeto (resto-del-flujo flujo)))
)
)
; ==================================================
; === comando: agrega-a-flujo
; === funcion: agregar nuevos flujos al final
; === fecha: enero / 1998
; ==================================================
(defun agrega-a-flujo (flujo1 flujo2)
(if (final-del-flujo-p flujo1) flujo2
(construye-flujo (principio-del-flujo flujo1)
(agrega-a-flujo (resto-del-flujo flujo1) flujo2)
)
)
)
; ==================================================
; === comando: back-chain
; === en una respuesta atractiva.
; === fecha: enero / 1998
; ==================================================
(defun back-chain (&rest patrones)
(let ((flujo-de-ligaduras (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 respuestas)
(setf respuestas-mostradas
(cons respuesta respuestas-mostradas)
)
)
)
)
)
)
)
; ==================================================
; === comando: muestra-respuestas
; === funcion: imprimir resultados
; === fecha: enero / 1998
; ==================================================
(defun muestra-respuestas (respuestas)
(format t "~&-->")
(dolist (respuesta respuestas)
(format t " ~a = ~a" (first respuesta) (second respuesta))
)
)
; ==================================================
; === comando: aplica-filtros
; === funcion: desplegar los filtros
; === fecha: enero / 1998
; ==================================================
(defun aplica-filtros (patrones flujo-inicial-entrada)
(if (endp patrones)
(aplica-filtros (rest patrones)
(filtra-flujo-de-ligaduras (first patrones) flujo-inicial-entrada)
)
)
)
; ==================================================
; === comando: filtra-flujo-de-ligaduras
; === de la regla.
; === fecha: enero / 1998
; ==================================================
(defun 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
)
)
)
; ==================================================
; === comando: lista-variables
; === funcion: producir variables
; === fecha: enero / 1998
; ==================================================
(defun lista-variables (arbol &optional nombres)
(cond ((atom arbol) nombres)
((eq '? (first arbol))
(if (member (second arbol) nombres) nombres
(append nombres (rest arbol))
)
)
(t (lista-variables (rest arbol)
(lista-variables (first arbol) nombres)))
)
)
; ==================================================
; === comando: construye-flujo
; === funcion: inicializar un flujo
; === fecha: enero / 1998
; ==================================================
(defun construye-flujo (objeto flujo)
(list objeto flujo)
)
; ==================================================
; === comando: final-del-flujo
; === funcion: comprobar si es el final del flujo
; === fecha: enero / 1998
; ==================================================
(defun final-del-flujo-p (flujo)
(eq flujo 'flujo-vacio)
)
; ==================================================
; === comando: principio-del-flujo
; === funcion: extraer al principio del flujo
; === fecha: enero / 1998
; ==================================================
(defun principio-del-flujo (flujo)
(first flujo)
)
; ==================================================
; === comando: resto-del-flujo
; === funcion: extraer el resto (segundo) del flujo
; === fecha: enero / 1998
; ==================================================
(defun resto-del-flujo (flujo)
(second flujo)
)
; ==================================================
; === comando: concatena-flujo
; === funcion: crear un solo flujo de objetos a
; === partir de un flujo de flujos de objetos
; === fecha: enero / 1998
; ==================================================
(defun concatena-flujo (flujos)
(if (final-del-flujo-p flujos) 'flujo-vacio
(if (final-del-flujo-p (principio-del-flujo flujos))
(concatena-flujo (resto-del-flujo flujos))
(construye-flujo (principio-del-flujo (principio-del-flujo flujos))
(concatena-flujo
(construye-flujo (resto-del-flujo (principio-del-flujo flujos))
(resto-del-flujo flujos))
)
)
)
)
)
; ==================================================
; === comando: transforma-flujo
; === funcion: aplica un procedimiento a cada
; === objeto en un flujo produciendo
; === un nuevo flujo (mapcar)
; === fecha: enero / 1998
; ==================================================
(defun transforma-flujo (procedimiento flujo)
(if (final-del-flujo-p flujo) 'flujo-vacio
(construye-flujo (funcall procedimiento (principio-del-flujo flujo))
(transforma-flujo procedimiento (resto-del-flujo flujo))
)
)
)
; ==================================================
; === comando: corresponde-patron-con-afirmaciones
; === funcion: operar sobre todas las afirmaciones
; === fecha: enero / 1998
; ==================================================
(defun corresponde-patron-con-afirmaciones (patron ligaduras)
(concatena-flujo
(transforma-flujo
#'(lambda (afirmacion) (intenta-afirmacion patron afirmacion ligaduras))
*afirmaciones*
)
)
)
; ==================================================
; === comando: intenta-afirmacion
; === funcion: verificar el match
; === fecha: enero / 1998
; ==================================================
(defun intenta-afirmacion (patron afirmacion ligaduras)
(let ((resultado (corresponde patron afirmacion ligaduras)))
(if (eq 'falla resultado)
'flujo-vacio
(construye-flujo resultado 'flujo-vacio)
)
)
)
; ==================================================
; === comando: corresponde-patron-con-reglas
; === funcion: parte del match (corresponde)
; === fecha: enero / 1998
; ==================================================
(defun corresponde-patron-con-reglas (patron ligaduras)
(concatena-flujo
(transforma-flujo
#'(lambda (regla) (prueba-regla patron regla ligaduras))
*reglas*
)
)
)
; ==================================================
; === comando: consecuente-de-la-regla
; === funcion: obtener el consecuente
; === fecha: enero / 1998
; ==================================================
(defun consecuente-de-la-regla (regla)
(first (last regla))
)
; ==================================================
; === comando: nombre-de-la-regla
; === funcion: extraer el nombre de la regla
; === fecha: enero / 1998
; ==================================================
(defun nombre-de-la-regla (regla)
(first regla)
)
; ==================================================
; === comando: antecedentes-de-la-regla
; === funcion: obtener el antecedente
; === fecha: enero / 1998
; ==================================================
(defun antecedentes-de-la-regla (regla)
(butlast (rest regla))
)
; ==================================================
; === comando: unifica-atomos
; === funcion: si son iguales (p1 y p2) => ligaduras
; === fecha: enero / 1998
; ==================================================
(defun unifica-atomos (p1 p2 ligaduras)
(if (eql p1 p2) ligaduras 'falla)
)
; ==================================================
; === comando: unifica-partes
; === funcion: si son iguales (p1 y p2) => ligaduras
; === fecha: enero / 1998
; ==================================================
(defun unifica-partes (p1 p2 ligaduras)
(let ((resultado (unifica (first p1) (first p2) ligaduras)))
(if (eq 'falla resultado) 'falla
(unifica (rest p1) (rest p2) resultado)
)
)
)
; ==================================================
; === comando: unifica-variable
; === funcion: unir ligaduras
; === fecha: enero / 1998
; ==================================================
(defun unifica-variable (p1 p2 ligaduras)
(let ((ligadura (encuentra-ligadura p1 ligaduras)))
(if ligadura (unifica (extrae-valor ligadura) p2 ligaduras)
(if (contenidop p1 p2 ligaduras) 'falla
(agrega-ligadura p1 p2 ligaduras)
)
)
)
)
; ==================================================
; === comando: contenidop
; === funcion: funciona si su primer argumento
; === su segundo
; === fecha: enero / 1998
; ==================================================
(defun contenidop (variable expresion ligaduras)
(if (equal variable expresion) nil
(contenido-o-igual-p variable expresion ligaduras)
)
)
; ==================================================
; === comando: contenido-o-igual-p
; === funcion: examinar de manera recursiva su
; === segundo argumento, reemplazando
; === cualquier variable que encuentre
; === con el valor de ella si la hay
; === fecha: enero / 1998
; ==================================================
(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))
)
)
)
; ==================================================
; === comando: unifica
; === funcion: corresponder 2 patrones
; === fecha: enero / 1998
; ==================================================
(defun unifica (p1 p2 &optional ligaduras)
(cond ((elementos-p p1 p2)(unifica-atomos p1 p2 ligaduras))
((variable-p p1)(unifica-variable p1 p2 ligaduras))
((variable-p p2)(unifica-variable p2 p1 ligaduras))
((recursivos-p p1 p2)(unifica-partes p1 p2 ligaduras))
(t 'falla)
)
)
; ==================================================
; === comando: prueba-regla
; === funcion: checar si coincide
; === fecha: enero / 1998
; ==================================================
(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
(aplica-filtros (antecedentes-de-la-regla regla)
(construye-flujo resultado 'flujo-vacio)
)
)
)
)
; ==================================================
; === comando: extrae-valor
; === funcion: sacar un valor mas de ligadura
; === fecha: enero / 1998
; ==================================================
(defun extrae-valor (ligadura)
(second ligadura)
)
; ==================================================
; === comando: haz-respuesta
; === funcion: construir una lista de asociacion
; === fecha: enero / 1998
; ==================================================
(defun haz-respuesta (variables ligaduras)
(particulariza-variables
(mapcar #'(lambda (variable)
(list variable (list '? variable))) variables) ligaduras)
)
; ==================================================
; === comando: particulariza-variables
; === funcion: reemplazar expresiones de variable usando
; === una lista de ligaduras.
; === fecha: enero / 1998
; ==================================================
(defun particulariza-variables (patron lista-a)
(cond ((atom patron) patron)
((eq '? (first patron))(extrae-valor (encuentra-ligadura patron lista-a)))
(t (cons (particulariza-variables (first patron) lista-a)
(particulariza-variables (rest patron) lista-a))
)
)
)
; ==================================================
; === comando: haz-variables-unicas
; === funcion: auxiliar de prueba-regla
; === fecha: enero / 1998
; ==================================================
(defun haz-variables-unicas (regla)
(let ((variables (lista-variables regla)))
(dolist (variable variables regla)
(setf regla (particulariza-variables regla
(list (list variable (list '? (gentemp variable))))))))
)
; ==================================================
; === BASE DE DATOS ORIENTADA AL MUNDO ANIMAL
; === CON REGLAS
; === fecha: enero / 1998
; ==================================================
(setf *afirmaciones* 'flujo-vacio)
(recuerda-afirmacion '(robbie tiene manchas oscuras))
(recuerda-afirmacion '(robbie tiene color leonado))
(recuerda-afirmacion '(robbie come carne))
(recuerda-afirmacion '(robbie tiene pelo))
(recuerda-afirmacion '(suzie tiene plumas))
(recuerda-afirmacion '(suzie vuela bien))
(recuerda-afirmacion '(bozo es perro))
(recuerda-afirmacion '(deedee es caballo))
(recuerda-afirmacion '(deedee es padre de sugar))
(recuerda-afirmacion '(deedee es padre de brassy))
(setf *reglas* 'flujo-vacio)
(recuerda-regla '(identifica1
((? animal) tiene pelo)
((? animal) es mamifero)))
(recuerda-regla '(identifica2
((? animal) da leche)
((? animal) es mamifero)))
(recuerda-regla '(identifica3
((? animal) tiene plumas)
((? animal) es ave)))
(recuerda-regla '(identifica4
((? animal) vuela)
((? animal) pone huevos)
((? animal) es ave)))
(recuerda-regla '(identifica5
((? animal) come carne)
((? animal) es carnivoro)))
(recuerda-regla '(identifica6
((? animal) tiene dientes puntiagudos)
((? animal) tiene garras)
((? animal) tiene ojos al frente)
((? animal) es carnivoro)))
(recuerda-regla '(identifica7
((? animal) es mamifero)
((? animal) es ungulado)))
(recuerda-regla '(identifica8
((? animal) es mamifero)
((? animal) rumia)
((? animal) es ungulado)))
(recuerda-regla '(identifica9
((? animal) es mamifero)
((? animal) es carnivoro)
((? animal) tiene color leonado)
((? animal) tiene manchas oscuras)
((? animal) es leopardo)))
(recuerda-regla '(identifica10
((? animal) es mamifero)
((? animal) es carnivoro)
((? animal) tiene color leonado)
((? animal) tiene rayas negras)
((? animal) es tigre)))
(recuerda-regla '(identifica11
((? animal) es ungulado)
((? animal) tiene cuello largo)
((? animal) tiene piernas largas)
((? animal) tiene manchas oscuras)
((? animal) es jirafa)))
(recuerda-regla '(identifica12
((? animal) es ungulado)
((? animal) tiene rayas negras)
((? animal) es cebra)))
(recuerda-regla '(identifica13
((? animal) es ave)
((? animal) no vuela)
((? animal) tiene cuello largo)
((? animal) tiene piernas largas)
((? animal) es blanco y negro)
((? animal) es avestruz)))
(recuerda-regla '(identifica14
((? animal) es ave)
((? animal) no vuela)
((? animal) nada)
((? animal) es pinguino)))
(recuerda-regla '(identifica15
((? animal) es ave)
((? animal) vuela bien)
((? animal) es albatros)))
(recuerda-regla '(identifica16
((? animal) es (? especie))
((? animal) es padre de (? cria))
((? cria) es (? especie))))
; ======================================================================= FIN