#lang scheme

(require "Restaurantes.ss")
(define la-tabla tabla-restaurantes)
(define meta 'meta)

;(require "Tricomonicidas.ss")
;(define la-tabla training-set)
;(define meta 'ACT_TRIC)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;un nodo del árbol de discriminación cuyo esquema formal es:
;;id contenido camino nivel terminal
(define-struct nodo
  (;field:
   id subtabla contenido camino nivel terminal)
  #:transparent
  )
;;creación de un ejemplar: (make-nodo id/v contenido/v camino/v nivel/v terminal/v)
;;acceso al valor de un field: nodo-field_name. P. ej.: (nodo-id ejemplar)
;;forma mensaje de acceso: (nodo-id ejemplar)
;;si un field ha sido calificado de #:mutable, es posible cambiar su valor
;;(set-field_name! ejemplar new_value)
;;esto último vale igual si toda la estructura ha sido declarada #:mutable.

;;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 arbol-id3 (make-hash))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;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-gi (second atrib))
           (atrib-val (second atrib))
           (atrib-subtablas (third atrib))
           (path '())
           (nivel 0)
           (nodos-expanda '())
           )
      (printf "Iniciando árbol. Atrib-sel: ~a con valores ~a~n"
              atrib-name atrib-val)
      (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)));repetido
              (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-gi (second atrib))
           (atrib-val (second atrib))
           (atrib-subtablas (third atrib))
           (nodos-expanda '())
           (n (hash-count arbol-id3))
           )
      (printf "Expandiendo el nodo-~a. Atrib-sel: ~a con valores ~a~n"
              id atrib-name atrib-val)
      (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)
          (print-reglas (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);(null? tabla);
          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)))
          )
      `(if ,antecedente then ,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 print-subtabla
  (lambda (tabla)
    (if (null? tabla)
        (display "")
        (begin
          (printf "~a~n" (car tabla))
          (print-subtabla (cdr tabla)))) ))

(define print-nodo
  (lambda (mensa nodo)
    (printf "~aNODO-~a. ~n" mensa (nodo-id nodo))
    (printf "Contenido:~a Camino:~a Nivel:~a Terminal?:~a~nSubtabla:~n"        
            (nodo-contenido nodo) 
            (nodo-camino nodo) 
            (nodo-nivel nodo) 
            (nodo-terminal nodo))
    (print-subtabla (nodo-subtabla nodo))
     ))

(define print-arbol
  (lambda (arbol)
    (printf "~nEl árbol de discriminación:~n~n")
    (let go ((j (hash-count arbol))
             (i 0)
             (nodo #f))
      (if (= i j)
          (newline)
          (begin
            (set! nodo (hash-ref arbol i))
            (print-nodo "" nodo)
            (go j (add1 i) #f))) )))
(define print-reglas
  (lambda (reglas)
    (printf "~nReglas generales inducidas:~n~n")
    (let go ((i 0)
             (j (length reglas))
             )
      (if (= i j)
          (newline)
          (begin
            (printf "R~a: ~a~n" (add1 i) (list-ref reglas i))
            (go (add1 i) j))
          )
      ) ))
;;;;;;;;;;;;;

(id3 la-tabla)
(print-arbol arbol-id3)

