#lang scheme

(require "ID3_trico.ss")
(require (only-in "Tricomonicidas.ss" test-set))

(id3 la-tabla)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Para establecer los nombres de atributos
(define son-atributos;son-atributos
  (lambda (first-tabla)
    (if (null? first-tabla)
        '()
        (cons
         (caar first-tabla)
         (son-atributos (cdr first-tabla))) )
    ))

;;Dados un par atributo/val, la lista/esquema de atributos y el esquema de signos
;;ubica el valor del atributo en el esquema de signos
(define atrib-in-esquema
  (lambda (atrib esq-atrib esq-sign)
    (if (equal? (car atrib) (car esq-atrib))
        (cons (cdr atrib) (cdr esq-sign))
        (cons
         (car esq-sign)
         (atrib-in-esquema atrib (cdr esq-atrib) (cdr esq-sign)))
        )
    ))
;;Dada una regla, aplica atrib-in-esquema reiteradamente hasta construir esquema-signos
(define atrib-esquema
  (lambda (regla esq-atrib esq-sign)
    (if (null? regla)
        esq-sign
        (atrib-esquema 
         (cdr regla) esq-atrib (atrib-in-esquema (car regla) esq-atrib esq-sign))
        )
    ))
;;a modo de driver para los tres anteriores
(define regla->esquema
  (lambda (regla);regla=lista de pares
    (let* ((atribs (son-atributos (first la-tabla)))
           (esquema (make-list (length atribs) '*))
           )
      ;(printf "Regla: ~a~n" regla)
      ;(printf "Esquema atribs: ~a~n" atribs)
      (atrib-esquema regla atribs esquema)
      )
    ))
;;
;;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))))
      ) ))
;;El procedimiento general
(define haz-base-reglas
  (lambda (arbol)
    (let go ((en-nodos (nodos-con-reglas arbol))
             (i 1)
             )
      (if (null? en-nodos)
          'Base-de-Reglas:hecha
          (let* ((nodo (car en-nodos))
                 (antecedente (reverse (cons-antecedente (nodo-camino nodo))))
                 (consecuente (cons-consecuente (nodo-subtabla nodo)))
                 )
            (hash-set! 
             BR i
             (make-regla
              i
              (list antecedente consecuente)
              (regla->esquema (append antecedente (list consecuente)))
              0 0 0))
            (go (cdr en-nodos) (add1 i))
          )
          )
      ) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;una regla de la base de reglas cuyo esquema formal es:
;;id representación-semántica representación-ag fitness realimentación aportación-crédito
(define-struct regla
  (;field:
   id repr-sem repr-sig 
      (fit #:mutable)
      (realim #:mutable)
      (aport #:mutable)
      )
  #:transparent
  )
;;creación de un ejemplar: (make-regla id/v repr-sem/v repr-sig/v fit/v realim/v aport/v)
;;acceso al valor de un field: regla-field_name. P. ej.: (regla-id ejemplar)
;;forma mensaje de acceso: (regla-id ejemplar)
;;si un field ha sido calificado de #:mutable, es posible cambiar su valor
;;(set-struct_name-field_name! ejemplar new_value)
;;esto último vale igual si toda la estructura ha sido declarada #:mutable.

;;una Base de Reglas es una hash-table. 
;;Cada elemento del árbol tiene una key:= número de orden y una regla
;;construir la BR es construir la hash-table.
;;funciones: hash-count; hash-ref; hash-set! 
;;en la forma (hash-set! BR (add1 (hash-count arbol)) regla)
(define BR (make-hash))
(let* ((atribs (son-atributos (first la-tabla)))
       (long (length atribs))
       )
  (hash-set! BR 0 
             (make-regla 0 atribs (make-list long '*) 'fit 'realimenta 'aportacion))
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(haz-base-reglas arbol-id3)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Intérprete de la parte antecedente de una regla
(define interprete-antecedente-regla
  (lambda (antecedente registro)
    (andmap
     (lambda (atrib-val)
       (ormap
        (lambda (campo)
          (equal? campo atrib-val))
        registro))
     antecedente)
    ))

;;Intérprete de un hecho/registro
(define interprete
  (lambda (br hecho);br=hash-table
    (let go ((i 1)
             (j (hash-count br))
             )
      (if (= i j)
          #f;;ninguna regla clasifica el hecho
          (let* ((rule (hash-ref br i))
                 (regla (regla-repr-sem rule))
                 (ant (first regla))
                 (consecuente (second regla))
                 )
            ;(printf "Regla-~a ~a~n" i regla)
            (cond 
              ((interprete-antecedente-regla ant hecho)
               (printf "es clasificado por Regla-~a ~n" i )
               consecuente
               ;;realimentación
               (set-regla-realim! rule (+ 0.01 (regla-realim rule)))
               (go (add1 i) j))
              (else (go (add1 i) j))
              )
            )
          )
      )
    ))
;;Test de la base de datos
(define test
  (lambda (tabla caso)
    (newline)
    (let go ((i 1)
             (table tabla)
             )
    (cond
      ((null? table)
       (if caso
           (ordena-reglas-realimentacion BR)
           (print-reglas-realimentacion
        (ordena-reglas-realimentacion BR)))
       );'hecho)
      (else
       (printf "Hecho-~a " i );~a~n" i (car table))
       (interprete BR (car table));;??
       (go (add1 i) (cdr table)))
      )) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ordena-reglas-realimentacion
  (lambda (br)
    (printf "~nReglas ordenadas según realimentación:~n")
    (let go ((i 1)
             (j (hash-count br))
             (salida '())
             )
      (if (= i j)
          (sort salida #:key cdr >)
          (go (add1 i) j (cons (cons i (regla-realim (hash-ref br i))) salida))
          )
      )
    ))
(define print-reglas-realimentacion
  (lambda (lista-pares)
    (for-each
     (lambda (par)
       (printf "Regla-~a ~a valor-de-uso ~a~n"
               (car par)
               (regla-repr-sem (hash-ref BR (car par)))
               (cdr par)))
     lista-pares) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(printf "~nTest con la tabla training-set~n")
(test la-tabla #t)
(printf "~nAñadiendo test con la tabla test-set~n")
(test test-set #f)