#lang scheme
(require mzlib/trace)

;;Redes semánticas

;;Nodos
(define-struct nodo
  (;field
   id
   caracteristicas
   link-superior
   (link-inferiora #:mutable)
   )
  #:prefab
  )
;;forma mensaje de acceso: (nodo-id ejemplar)
;;cada field ha de ser calificado de #:mutable. forma mensaje de set!: (set-nodo-id! ejemplar new)

;;un árbol es una hash-table. Cada elemento del árbol tiene una key:= número de orden (arriba->abajo, izqda->dcha) y un nodo
;;construir el árbol es construir la hash-table.
;;funciones: hash-count; hash-ref; hash-set! en la forma (hash-set! arbol (add1 (hash-count arbol)) nodo)

(define red-animales (make-hash))

(hash-set! red-animales
           'animal
           (make-nodo 'animal "es un animal" empty '(vertebrado invertebrado)))

(hash-set! red-animales
           'vertebrado
           (make-nodo 
            'vertebrado 
            "tiene un esqueleto cartilaginoso u óseo" 
            'animal 
            '(mamifero ave pez)))

(hash-set! red-animales
           'ave
           (make-nodo 'ave "tiene alas" 'vertebrado '(gorrión)))

(hash-set! red-animales
           'gorrión
           (make-nodo 'gorrión "su hábitat es urbano y está muy acostumbrado a vivir cerca del hombre" 'ave empty))

(hash-set! red-animales
           'pez
           (make-nodo 'pez "vive en el agua" 'vertebrado '(tiburon)))

(hash-set! red-animales
           'tiburon
           (make-nodo 'tiburón "tiene un esqueleto hecho de cartílago en vez de hueso" 'pez empty))

(hash-set! red-animales
           'mamifero
           (make-nodo 'mamifero "amamanta sus crías" 'vertebrado '(carnivoro primate cetaceo)))

(hash-set! red-animales
           'carnivoro
           (make-nodo 'carnivoro "come carne" 'mamifero '(primate lobo perro)))

(hash-set! red-animales
           'lobo
           (make-nodo 'lobo "es salvaje y puede vivir en manada" 'carnivoro empty))

(hash-set! red-animales
           'perro
           (make-nodo 'perro "es domestico" 'carnivoro empty))

(hash-set! red-animales
           'primate
           (make-nodo 'primate "es un primate" 'mamifero '(mono chimpance hombre)))

(hash-set! red-animales
           'mono
           (make-nodo 'mono "tiene una cola prensil" 'primate empty))

(hash-set! red-animales
           'chimpance
           (make-nodo 'chimpance "es un simio" 'primate empty))

(hash-set! red-animales
           'hombre
           (make-nodo 'hombre "es inteligente" 'primate empty))

(hash-set! red-animales
           'cetaceo
           (make-nodo 'cetaceo "vive en el agua" 'mamifero '(ballena delfin)))

(hash-set! red-animales
           'ballena
           (make-nodo 'ballena "tiene barbas" 'cetaceo empty))

(hash-set! red-animales
           'delfin
           (make-nodo 'delfin "tiene dientes" 'cetaceo empty))

(hash-set! red-animales
           'invertebrado
           (make-nodo 'invertebrado "carece de esqueleto" 'animal '(artropodo molusco)))

(hash-set! red-animales
           'artropodo
           (make-nodo 'artropodo "tiene apéndices articulados y un cuerpo segmentado" 'invertebrado '(insecto aracnido crustaceo miriapodo)))

(hash-set! red-animales
           'insecto
           (make-nodo 'insecto "tiene un par de antenas, tres pares de patas y dos pares de alas" 'artropodo '(mosca abeja)))

(hash-set! red-animales
           'mosca
           (make-nodo 'mosca "tiene sólo dos alas" 'insecto empty))

(hash-set! red-animales
           'abeja
           (make-nodo 'abeja "es un insecto social" 'insecto empty))

(hash-set! red-animales
           'aracnido
           (make-nodo 'aracnido "su cuerpo posee dos regiones y tiene cuatro pares de extremidades" 'artropodo '(araña)))

(hash-set! red-animales
           'araña
           (make-nodo 'araña "Producen seda, llamada tela de araña" 'aracnido empty))

(hash-set! red-animales
           'crustaceo
           (make-nodo 'crustaceo "tiene dos ojos compuestos y dos pares de antenas" 'artropodo '(langosta)))

(hash-set! red-animales
           'langosta
           (make-nodo 'langosta "Posee cinco pares de patas y el primer par de patas no termina en dos grandes pinzas" 'crustaceo empty))

(hash-set! red-animales
           'miriapodo
           (make-nodo 'miriapodo "tiene cabeza y su tronco está formado por muchos segmentos y multitud de pares de patas" 'artropodo '(ciempies)))

(hash-set! red-animales
           'ciempies
           (make-nodo 'ciempies "Son carnívoros y segregan veneno" 'miriapodo empty))

(hash-set! red-animales
           'molusco
           (make-nodo 'molusco "tiene un cuerpo blando, desnudo o protegido por una concha" 'invertebrado '(gasteropodo bivalvo cefalopodo)))

(hash-set! red-animales
           'gasteropodo
           (make-nodo 'gasteropodo "tiene cabeza, un pie musculoso ventral y una concha dorsal" 'molusco '(caracol)))

(hash-set! red-animales
           'caracol
           (make-nodo 'caracol "tiene una concha en espiral" 'gasteropodo empty))

(hash-set! red-animales
           'bivalvo
           (make-nodo 'bivalvo "está protegido por dos valvas" 'molusco '(ostra)))

(hash-set! red-animales
           'ostra
           (make-nodo 'ostra "posee dos valvas casi circulares y desiguales" 'bivalvo empty))

(hash-set! red-animales
           'cefalopodo
           (make-nodo 'cefalopodo "tiene una cabeza y varios tentáculos" 'molusco '(pulpo)))

(hash-set! red-animales
           'pulpo
           (make-nodo 'pulpo "posee ocho tentáculos y es carnívoro" 'cefalopodo empty))


;;interfaz
(define print-pregunta
  (lambda (string/symbol)
    (if (symbol? string/symbol)
        (printf "Estabas pensando en un ~a, ¿no?.~n" string/symbol)
        (printf "¿~a?~n" string/symbol) )
    ))
(define pregunta-si-no
  (lambda (string/symbol)
    (print-pregunta string/symbol)
    (let ((input (read)))
      (cond
        ((eq? input 'Sí) #t)
        ((eq? input 'Si) #t)
        ((eq? input 'S) #t)
        ((eq? input 's) #t)
        ((eq? input 'No) #f)
        ((eq? input 'no) #f)
        ((eq? input 'N) #f)
        ((eq? input 'n) #f)
        (else (pregunta-si-no string/symbol))
        )
      )
    ))
(define mensaje-final
  (lambda (valor)
    (if valor
        (printf "He tenido suerte!!~n")
        (printf "Lo siento, me equivoque.~n") )
    ))
(define respuesta-acertada
  (lambda ()
    (printf "Dime, por favor, en qué animal estabas pensando~n")
    (read) ))
(define diferencia
  (lambda (item nuevo)
    (printf "Si me dices algo que diferencie a ~a de ~a, puedo aprender~n" nuevo item)
    (read-char)
    (read-line) ));;ojo!!
(define mensaje-inicial
  (lambda ()
  (printf "Piensa en un animal. Intentaré adivinar su nombre~n")
  (printf "Te haré preguntas. Contesta, por favor, S(í) o N(o)~n") ))
(define dif-especifica
  (lambda (nuevo)
    (printf "Dime, por favor, algo característico de ~a.~n" nuevo)
    (read-char)
    (read-line) ));;ojo!!   
    
(define genero-inmediato
  (lambda (nuevo superior)
    (printf "Puedes clasificar ~a junto a ~a.~n" nuevo superior)
    (read) ))

;;Redes semánticas à la Porfirio
(define-syntax genero?
  (syntax-rules ()
    [(genero? nudo)
     (null? (nodo-link-superior nudo))]
    ))
(define-syntax especie-ultima?
  (syntax-rules ()
    [(especie-ultima? nudo)
     (null? (nodo-link-inferiora nudo))
     ]
    ))
;;Operaciones
(define especies
  (lambda (nudo)
    (nodo-link-inferiora nudo)
    ))
(define genero
  (lambda (nudo)
    (nodo-link-superior nudo)
    ))
(define diferencia-especifica
  (lambda (nudo)
    (nodo-caracteristicas nudo) ))
;;Búsqueda en la red semántica
(define busqueda-profundidad
  (lambda (lista-especies genus red)
    (let* ((nodo (if (null? lista-especies)
                     lista-especies
                     (hash-ref red (first lista-especies))))
           )
      (cond
        ((null? nodo)
         (printf "Las especies de ~a están incompletas.~n~n" 
                 (nodo-id genus))
         (aprende-especies-genero genus red)
         )
        ((especie-ultima? nodo)
         (if (pregunta-si-no (diferencia-especifica nodo))
             (solucion-o-aprende nodo red)
             
             (busqueda-profundidad
              (rest lista-especies) nodo red)
             )
         )

         (else
         (if (pregunta-si-no (diferencia-especifica nodo))
             (busqueda-profundidad
              (especies nodo) nodo red)
             (busqueda-profundidad
              (rest lista-especies) genus red)
             )
         )
        )
      )
    ))
;;Aprendizajes
;;aprendizaje especie ínfima
(define solucion-o-aprende
  (lambda (nodo red)
    (cond
      ((pregunta-si-no (nodo-id nodo)) 
       (mensaje-final #t) )
      (else
       (mensaje-final #f)
       (aprende-especie-infima nodo red) )
      )
    (jugar-otra-vez)
    ))
(define aprende-especie-infima
  (lambda (nudo red)
    (let* ((acertada (respuesta-acertada))
           (caracteristica 
            (diferencia (nodo-id nudo) acertada))
           )
      (add-nodo acertada caracteristica nudo red)
      )
    ))
(define add-nodo
  (lambda (id-true caracteristica nodo-false red)
    (let* ((id-false (nodo-id nodo-false))
           (id-superior (nodo-link-superior nodo-false))
           (nodo-superior (hash-ref red id-superior))
           (nodo-superior-inferiora
            (nodo-link-inferiora nodo-superior))
           (new-inferiora
            (add-inferior
             id-true id-false nodo-superior-inferiora))
           )
      (hash-set! red
                 id-true
                 (make-nodo 
                  id-true 
                  caracteristica 
                  id-superior 
                  empty) )
      (set-nodo-link-inferiora! nodo-superior new-inferiora)
      )
    ))
(define add-inferior
  (lambda (nuevo detras-de lista-inferiora)
    (if (null? lista-inferiora)
        '()
        (if (eq? (first lista-inferiora) detras-de)
            (cons
             detras-de
             (cons 
              nuevo
              (add-inferior nuevo detras-de 
                            (rest lista-inferiora))))
            (cons
             (first lista-inferiora)
             (add-inferior nuevo detras-de 
                            (rest lista-inferiora)))
            )
        )
    ))
;;aprendizaje especie ínfima y especies intermedias
(define make-nudo
  (lambda (id carac superior inferiores red)
    (hash-set! red id
               (make-nodo
                id carac superior inferiores)) ))

(define make-nudos
  (lambda 
      (especie-infima esp-inf-caract lista-superiores red genus)
    (let* ((id-nodo (first lista-superiores))
           (pred (symbol->string (first lista-superiores)))
           (caracteristica 
            (string-append "es un " pred))
           (inferiora (if (null? (rest lista-superiores))
                          (list especie-infima)
                          (list (second lista-superiores))))
           (id-genus (nodo-id genus))
           (new-inferiora-genus
            (append
             (nodo-link-inferiora genus)
             (list id-nodo)) )
           )
      (cond
        ((null? (rest lista-superiores))
         (make-nudo 
          id-nodo caracteristica id-genus inferiora red)
         (make-nudo 
          especie-infima esp-inf-caract id-nodo empty red)
         )
        (else
         ;;añade nuevo nodo genero/especie
         (make-nudo 
          id-nodo caracteristica id-genus inferiora red)
         (make-nudos 
          especie-infima esp-inf-caract 
          (rest lista-superiores) 
          red 
          (hash-ref red id-nodo))
         )
        )
      )
    ))

(define especies-intermedias
  (lambda 
      (id-especie-infima id-nudo-genero lista-esp-intermedias)
    (printf "Dime, por favor, un ~a es un " id-especie-infima)
    (let* ((esp-intermedia (read))
           
          )
      (if (eq? esp-intermedia id-nudo-genero)
          lista-esp-intermedias
          (especies-intermedias
           esp-intermedia
           id-nudo-genero
           (cons
            esp-intermedia
            lista-esp-intermedias))
          )
      )
    )
  )
(define aprende-especies-genero
  (lambda (nudo-genero red)
    (let*
        ((especie-infima (respuesta-acertada))
         (caract-especie-infima 
          (dif-especifica especie-infima))
         (id-nudo-genero (nodo-id nudo-genero))
         (espec-interm 
          (especies-intermedias 
           especie-infima id-nudo-genero '()))
         (new-inferiora-genus 
          (append 
           (nodo-link-inferiora nudo-genero) 
           (list (first espec-interm))))
         )
      (make-nudos 
       especie-infima 
       caract-especie-infima 
       espec-interm 
       red 
       nudo-genero)
      (set-nodo-link-inferiora! 
       nudo-genero new-inferiora-genus)
      (jugar-otra-vez)
      )
    ))
;;driver
(define recorre-red
  (lambda (genero-supremo red)
    (busqueda-profundidad
     (especies 
      (hash-ref red genero-supremo))
     (hash-ref red genero-supremo)
     red)
    ))
;;
(define jugar-otra-vez
  (lambda ()
    (if (pregunta-si-no "Quieres jugar otra vez")
        (recorre-red 'animal  red-animales)
        (begin
          (print-hash-table #t)
          (print-red archivo red-animales)
          'Adiós)
        )
    ))

(define juego
  (lambda file-path
    (mensaje-inicial)
    (when (file-exists? (first file-path))
        (set! red-animales 
              (read-red (first file-path))) )
    (recorre-red 'animal  red-animales)
    ))
;;para almacenar la red en un fichero
(define archivo
  "/Volumes/usuario/ZETA/animales-red.txt")
(define read-red
  (lambda (file)
    (let* ((in-port (open-input-file file))
           (red (read in-port))
           )
      (close-input-port in-port)
      (hash-copy red)
      )
    ))
(define print-red
  (lambda (file obj)
    (let ((out-port 
           (open-output-file file #:exists 'replace)))
      (print obj out-port)
      (close-output-port out-port)
      )
    ))
;;
(juego archivo)
