#lang racket

(define induccion%
  (class object%
    (field
     (la-tabla '())
     (meta 'exito)
     (arbol-id3 #f)
     )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct nodo
  (;field:
   id subtabla contenido camino nivel terminal)
  #:transparent
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Cálculo G. I.
;;Agentes simples
(define log2
  (lambda (n)
    (/ (log n) (log 2))))

(define gi-una-particion
  (lambda (n-obj total)
    (let ((prob (/ n-obj total)))
      (+ (* prob (log2 prob))) ) ))

;;Agente compuesto
(define gi-un-atributo
  (lambda (total lista-n-obj)
    (-
     (apply +
            (map
             (lambda (x)
               (gi-una-particion x total))
             lista-n-obj))) ))
;;;;;;;;;;;;;
;;Para Criterios de selección de atributo
;;sublista de iguales GI
(define sublista-iguales
  (lambda (lista)
    (let go ((mayor (apply max lista))
             (i 0)
             (j (length lista))
             (salida '())
             )
      (if (= i j)
          (reverse salida)
          (cond
            ((= (list-ref lista i) mayor)
             (go 
              mayor 
              (add1 i) 
              j
              (cons i salida)))
            (else
              (go 
               mayor 
               (add1 i) 
               j
               salida))))
      ) ))
;;función predicativa
(define particion-terminal?
  (lambda (subtabla)
    (let go ((sub (cdr subtabla))
             (meta (cdr (last (car subtabla))))
             (salida #t)
             )
      (if (or (null? sub) (not salida))
          salida
          (if (equal? (cdr (last (car sub))) meta)
              (go (cdr sub) meta salida)
              (go (cdr sub) meta (not salida))))
      ) ))
;;cuenta: total-part (j), nº-objs-en-cada-part (lst-n-objs-part), nº-part-terminales (n)
(define particiones
  (lambda (new-tabla)
    (let go ((i 0)
             (j (length new-tabla));numero total particiones
             (n 0)
             (lst-n-objs-part '())
             )
      (if (= i j)
          (begin
            (list j 
                  (reverse lst-n-objs-part)
                  n))
          (if (particion-terminal? (list-ref new-tabla i))
              (go (add1 i) j (add1 n) (cons (length (list-ref new-tabla i)) lst-n-objs-part))
              (go (add1 i) j n (cons (length (list-ref new-tabla i)) lst-n-objs-part))) )) ))
;;;;;;;;;;;;;
;;Para establecer datos de atributos
;;los nombres
(define son-atributos
  (lambda (first-tabla)
    (if (null? first-tabla)
        '()
        (if (equal? (caar first-tabla) meta)
            (son-atributos (cdr first-tabla))
            (cons
             (caar first-tabla)
             (son-atributos (cdr first-tabla)))))
    ))
;;la columna de un atributo en la tabla 
(define columna-un-atributo
  (lambda (atr-name tabla)
    (if (null? tabla)
        '()
        (cons
         (let go ((fila (car tabla))
                  (celda #f))
           (if (null? fila)
               celda
               (if (equal? (caar fila) atr-name)
                   (go (cdr fila) (car fila))
                   (go (cdr fila) celda))))
         (columna-un-atributo atr-name (cdr tabla))))
    ))
;;los valores
(define valores-un-atributo
  (lambda (columna)
    (let ((valores '()))
      (for-each
       (lambda (celda)
         (unless (member (cdr celda) valores)
           (set! valores (cons (cdr celda) valores))))
       columna)
      (reverse valores)) ))
;;;;;;;;;;;;;
;;División de current-tabla
(define divide-tabla
  (lambda (current-tabla atrib-name atrib-valores)
    (let go ((vals atrib-valores)
             )
      (if (null? vals)
          '()
          (cons
           (subtabla current-tabla atrib-name (car vals))
           (go (cdr vals))) ) 
      ) ))
(define subtabla
  (lambda (tabla atrib-name atrib-val)
    (if (null? tabla)
        '()
        (let ((nf (new-fila (car tabla) atrib-name atrib-val)))
          (if (null? nf)
              (subtabla (cdr tabla) atrib-name atrib-val)
              (append 
               nf
               (subtabla (cdr tabla) atrib-name atrib-val))))
        ) ))
(define new-fila
  (lambda (fila atrib-name atrib-val)
    (let go ((f fila)
             (temp'()))
      (if (null? f)
          temp
          (if (and (equal? (caar f) atrib-name)
                   (equal? (cdar f) atrib-val))
              (go (cdr f) (cons (remove (cons atrib-name atrib-val) fila) temp))
              (go (cdr f) temp))) )))
;;;;;;;;;;;;;
;;;Selección de un atributo
(define eleccion-atributo-segun-criterios
  (lambda (tabla)
    (let* ((total-obj-tabla (length tabla))
           (atributos-names (son-atributos (car tabla)))
           (atributos-valores
            (map
             (lambda (atrib-name)
               (valores-un-atributo 
                (columna-un-atributo atrib-name tabla)))
             atributos-names))
           (lista-subtablas-atributos
            (map
             (lambda (atr-name atrib-valores)
               (divide-tabla tabla atr-name atrib-valores) )
             atributos-names atributos-valores))
           (en-part (map particiones lista-subtablas-atributos))
           (datos-cada-atrib
            (map
             (lambda (name valores subtablas lst-tot-nobjs-term)
               (append
                (list name valores subtablas)
                lst-tot-nobjs-term))
             atributos-names atributos-valores lista-subtablas-atributos en-part))
           (gi-cada-atributo
            (map 
             (lambda (datos-atrib)
               (gi-un-atributo total-obj-tabla (fifth datos-atrib))
               )
             datos-cada-atrib))
           (con-gi-iguales (sublista-iguales gi-cada-atributo))
           (criterio-1 (if (= (length con-gi-iguales) 1) 
                           (car con-gi-iguales) 
                           #f))
           (sublist-con-gi-iguales #f)
           (con-part-term-iguales #f)
           (criterio-2 #f)
           (con-menor-num-part #f)
           (criterio-3 #f)
           )
      (set! sublist-con-gi-iguales;;
            (map
               (lambda (ordinal)
                 (list-ref datos-cada-atrib ordinal))
               con-gi-iguales))
      (set! con-part-term-iguales
            (sublista-iguales
             (map
              (lambda (datos-atr)
                (fourth datos-atr))
              sublist-con-gi-iguales)))
      (set! criterio-2 
            (if (= (length con-part-term-iguales) 1) 
                (car con-part-term-iguales) 
                #f))
      (set! con-menor-num-part
            (sublista-iguales
             (map
              (lambda (datos-atr)
                (sixth datos-atr))
              sublist-con-gi-iguales)))
      (set! criterio-3
            (if (= (length con-menor-num-part) 1) 
                (car con-menor-num-part) 
                #f))
      (cond
        (criterio-1 
         (list-ref datos-cada-atrib criterio-1))
        (criterio-2 
         (list-ref sublist-con-gi-iguales criterio-2))
        (criterio-3 
         (list-ref sublist-con-gi-iguales criterio-3))
        (else 
         (list-ref sublist-con-gi-iguales (first con-menor-num-part)))
        )
      ) ))
;;Inicia árbol
(define inicia-arbol
  (lambda (current-tabla)
    (let* ((atrib (eleccion-atributo-segun-criterios current-tabla))
           (atrib-name (first atrib))
           (atrib-val (second atrib))
           (atrib-subtablas (third atrib))
           (path '())
           (nivel 0)
           (nodos-expanda '())
           )
      (let go ((i 0)
               (j (length atrib-val))
               (val-atr atrib-val)
               (subtablas atrib-subtablas) 
               )
        (if (= i j)
            (reverse nodos-expanda)
            (let* ((id i)
                   (subtabla (car subtablas))
                   (contenido (cons atrib-name (car val-atr)))
                   (camino (cons i path))
                   (nivel nivel)
                   (terminal (particion-terminal? subtabla)))
              (hash-set! arbol-id3 i
                         (make-nodo 
                          id subtabla contenido camino nivel terminal))
              (set! nodos-expanda (if terminal nodos-expanda (cons id nodos-expanda)))
              (go (add1 i) j (cdr val-atr) (cdr subtablas))))
        )) ))
;;Expansión de un nodo
(define expande-nodo
  (lambda (nodo)
    (let* ((id (nodo-id nodo))
           (subtabla (nodo-subtabla nodo))
           (contenido (nodo-contenido nodo))
           (path (nodo-camino nodo))
           (nivel (nodo-nivel nodo))
           (terminal (nodo-terminal nodo))
           (atrib (eleccion-atributo-segun-criterios subtabla))
           (atrib-name (first atrib))
           (atrib-val (second atrib))
           (atrib-subtablas (third atrib))
           (nodos-expanda '())
           (n (hash-count arbol-id3))
           )
      (let go ((i n)
               (j (+ n (length atrib-val)))
               (val-atr atrib-val)
               (subtablas atrib-subtablas) 
               )
        (if (= i j)
            (reverse nodos-expanda)
            (let* ((id i)
                   (subtabla (car subtablas))
                   (contenido (cons atrib-name (car val-atr)))
                   (camino (cons i path))
                   (nivel (add1 nivel))
                   (terminal (particion-terminal? subtabla))
                   )
              (hash-set! arbol-id3 i
                         (make-nodo 
                          id subtabla contenido camino nivel terminal))
              (set! nodos-expanda (if terminal nodos-expanda (cons id nodos-expanda)))
              (go (add1 i) j (cdr val-atr) (cdr subtablas))))
        )
      ) ))
;;Expansión de un nivel
(define expande-nivel
  (lambda (nodos-expanda)
    (if (null? nodos-expanda)
        '()
        (append
         (expande-nodo (hash-ref arbol-id3 (car nodos-expanda)))
         (expande-nivel (cdr nodos-expanda)))
        ) ))
;;El procedimiento más general
(define id3
  (lambda (tabla)
    (let go ((expanda-nodos (inicia-arbol tabla)))
      (if (null? expanda-nodos)
          (reglas arbol-id3)
          (go (expande-nivel expanda-nodos)))
      ) ))
;;;;;;;;;;;;;
;;Extracción de reglas a partir del árbol
;;extrae los nodos que contienen reglas: nodo-terminal = #t
(define nodos-con-reglas
  (lambda (arbol)
    (let go ((i 0)
             (j (hash-count arbol))
             (lst '())
             )
      (if (= i j)
          (reverse lst)
          (if (nodo-terminal (hash-ref arbol i))
              (go (add1 i) j (cons (hash-ref arbol i) lst))
              (go (add1 i) j lst))) ) ))
;;Construye la expresión de la regla
(define cons-antecedente
  (lambda (path)
    (if (null? path)
        '()
        (cons
         (nodo-contenido (hash-ref arbol-id3 (car path)))
         (cons-antecedente (cdr path))) ) ))
(define cons-consecuente
  (lambda (subtabla)
    (let go ((tabla (if (null? (cdr subtabla)) (car subtabla) subtabla))
             (salida #f)
             )
      (if (or (null? tabla) salida)
          salida
          (cond
            ((equal? (car (last tabla)) meta)
             (go (cdr tabla) (last tabla)))
            ((equal? (car (last (car tabla))) meta)
             (go (cdr tabla) (last (car tabla))))
            (else
             (go (cdr tabla) salida))))
      ) ))
(define haz-regla
  (lambda (nodo)
    (let ((antecedente (reverse (cons-antecedente (nodo-camino nodo))))
          (consecuente (cons-consecuente (nodo-subtabla nodo)))
          )
      (append antecedente (list consecuente))
      ) ))
;;El procedimiento general
(define reglas
  (lambda (arbol)
    (let go ((en-nodos (nodos-con-reglas arbol))
             (salida '())
             )
      (if (null? en-nodos)
          (reverse salida)
          (go (cdr en-nodos) (cons (haz-regla (car en-nodos)) salida))
          )
      ) ))
;;;;;;;;;;;;;
;;Procedimiento auxiliares
(define make-new-table
  (lambda (tabl)
    (letrec ((para-n
              (lambda (tabla primero)
                (if (null? tabla)
                    (length primero)
                    (if (> (length (first tabla)) (length primero))
                        (para-n (cdr tabla) (first tabla))
                        (para-n (cdr tabla) primero)
                        )
                    )
                ))
             (n 0)
             )
      (set! n (para-n (cdr tabl) (car tabl)))
      (filter-map
       (lambda (elem)
         (if (= (length elem) n)
             elem
             #f))
       tabl)
      )
    ))
    
    (define/public proceso!
      (lambda (historia)
        (let ((Reglas #f)
              (meta_reglas #f)
              )
          (set! la-tabla historia)
          (set! arbol-id3 (make-hash))
          (id3 la-tabla)
          (set! Reglas (reglas arbol-id3))
;          (printf "Reglas directamente inducidas: ~n~a~n" Reglas)
          (set! la-tabla (make-new-table Reglas))
          (set! arbol-id3 (make-hash))
          (set! meta_reglas (id3 la-tabla))
;                (map
;                 (lambda (item)
;                   (append (list (cons 'accion 'x) (cons 'vecino 'x)) item)
;                   )
;                 (id3 la-tabla)
;                 )
;                )
;          (printf "Meta-Reglas inducidas a partir de las reglas anteriores: ~n~a~n" meta_reglas)
          (values Reglas meta_reglas)
          )
        ))
    (super-new)
    ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define operacion_induccion (make-object induccion%))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Aplicamos ID3 sobre la historia de Animat
;(id3 la-tabla)
;;Volvemos a aplicar ID3 ahora sobre las reglas inmediatamente generadas
;;primero se hace una tabla uniforme respecto a la longitud de los registros
;(set! la-tabla (make-new-table (reglas arbol-id3)))
;(set! arbol-id3 (make-hash))
;(id3 la-tabla)

;;Se obtienen meta-reglas
;;Una respuesta como
;;R1: ((vec_tipo 0 . 0) (exito . 0))
;;ha de entenderse como:
;;si la acción apunta a un vecino cuyo tipo es ..., entonces éxito ...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide operacion_induccion)