#lang racket

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (define-struct regla
    ;(struct regla
      (   
       (fuerza #:mutable)
       (antecedente #:mutable)
       (produccion #:mutable)
       (id #:mutable)
       )
      #:transparent
      )
(define operaciones-ag%
  (class object%
    ;;;;;POBLACION INICIAL;;;;;;
    (define intervalo
      (lambda (a b)
        (if (> a b)
            '()
            (cons a
                  (intervalo (add1 a) b))
            )
        ))
    ;;;;;;;;;;;;;;;;;;;;;;;
    (define mutando-gen;fuerza a que el gen cambie
      (lambda (gen)
        (let ((gen-mutante (haz-gen!)))
          (if (equal? gen gen-mutante)
              (mutando-gen gen)
              gen-mutante) )
        ))
    ;;;;;;;;;;;;;;;;;;;;;;;
    (define haz-gen!
      (lambda ()
        (let ((tabla-pares
               (list
                (cons 0 0)
                (cons 0 #\#)
                (cons 1 1)
                ) )
              (azar (random 3))
              )
          (list-ref tabla-pares azar)
          )
        ))
    (define genera-antecedente
      (lambda ()
        (map
         (lambda (o)
           (haz-gen!)
           )
         '(0 1 2 3 4 5 6 7))
        ))
    (define genera-produccion
      (lambda (antecedente)
        (ormap
         (lambda (par ord)
           (if (char? (cdr par))
               #f
               ord)
           )
         antecedente '(0 1 2 3 4 5 6 7))
        ))
    (define gen-regla
      (lambda ()
        (let* ((antecedente (genera-antecedente))
               (accion (genera-produccion antecedente))
               )
          (list antecedente accion)
          )
        ))
    (define antecedente-con-accion
      (lambda (accion)
        (map
         (lambda (ord)
           (if (= ord accion)
               (if (= 0 (random 2)) (cons 0 0) (cons 1 1))
               (haz-gen!))
           )
         '(0 1 2 3 4 5 6 7))
        ))
    (define gen-subpoblacion
      (lambda (n accion temp)
        (if (= n 0)
            temp
            (let ((r (list (antecedente-con-accion accion) accion)) )
              (if (member r temp)
                  (gen-subpoblacion n accion temp)
                  (gen-subpoblacion (sub1 n) accion (cons r temp))
                  )
              )
            )
        ))
    (define gen-poblacion
      (lambda (n);n divisible por 8
        (append-map
         (lambda (A)
           (gen-subpoblacion (quotient n 8) A '())
           )
         '(0 1 2 3 4 5 6 7)
         )
        ))
    (define poblacion
      (lambda (n temp)
        (if (= n 0)
            temp
            (let ((r (gen-regla)) )
              (if (member r temp)
                  (poblacion n temp)
                  (poblacion (sub1 n) (cons r temp))
                  )
              )
            )
        ))
    (define/public make-BC
      (lambda (n)
        (map
         (lambda (individuo ord)
           (make-regla 1 (first individuo) (second individuo) ord)
           )
         (poblacion n '()) (intervalo 0 (sub1 n)))
;        (map
;         (lambda (individuo ord)
;           (make-regla 1 (first individuo) (second individuo) ord)
;           )
;         (gen-poblacion n) (intervalo 0 (sub1 n)))
        ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (define seleccion-padres
      (lambda (BC-clases)
        (let* ((mejores (first BC-clases))
               (c1 (first mejores))
               (c2 #f)
               )
          (if (null? (rest mejores))
              (values c1 #f)
              (values c1 (second mejores))
              )
          )
        ))
    (define son-padres
      (lambda (c1 c2)
        (values
         (append (regla-antecedente c1) (list (regla-produccion c1)))
         (if c2
             (append (regla-antecedente c2) (list (regla-produccion c1)))
             #f)
         )
        ))
    ;;MODULO CRUCE
    (define sublista
      (lambda (lista i j)
        (if (= i j)
            '()
            (cons
             (list-ref lista i)
             (sublista lista (add1 i) j)
             )
            )
        ))
    (define fragmentos_cromosoma
      (lambda (cromosoma lista_puntos_cruce n)
        (if (null? lista_puntos_cruce)
            (cons
             (sublista cromosoma n (length cromosoma))
             '())
            (cons
             (sublista cromosoma n (car lista_puntos_cruce))
             (fragmentos_cromosoma cromosoma (cdr lista_puntos_cruce) (car lista_puntos_cruce))
             )
            )
        ))
    (define cruce_aux
      (lambda (frag_1 frag_2)
        (let go ((i 0)
                 (j (length frag_1))
                 (salida '())
                 )
          (if (= i j)
              salida
              (go (add1 i) j 
                  (if (even? i)
                      (append salida (list-ref frag_1 i))
                      (append salida (list-ref frag_2 i))
                      ))
              )
          )
        ))
    ;;;CREAR NUEVA GENERACIÓN
    (define cruce
      (lambda (c1 c2 lista-puntos_cruce)
        (let ((frag_c1 (fragmentos_cromosoma c1 lista-puntos_cruce 0))
              (frag_c2 (fragmentos_cromosoma c2 lista-puntos_cruce 0))
              )
          (cruce_aux frag_c1 frag_c2)
          )
        ))
    (define/public new-classifiers->BC
      (lambda (BC-clases)
        (let*-values ([(r1 r2) (seleccion-padres BC-clases)]
                      [(c1 c2) (son-padres r1 r2)]
                      ;[(peor) (last (first BC-clases))]
                      [(hacer-mutacion?) (< (random 1000) 5)]
                      [(ord-mutante) (random 8)]
                      [(hijo) (if c2 (cruce c1 c2 (list 3 6)) c1)]
                      [(par-mutante) (list-ref hijo ord-mutante)]
                      [(par-mutado) (mutando-gen par-mutante)]
                      [(hijo-mutado)
                       (map
                        (lambda (par ord)
                          (if (= ord ord-mutante)
                              par-mutado
                              par)
                          )
                        hijo '(0 1 2 3 4 5 6 7 8))]
                      ;[(hijo) (if c2 (cruce c1 c2 (list 3 6)) #f)]
                      ;[(rule) (if hijo
                      ;            (make-regla 1 (take hijo 8) (last hijo) (regla-id peor))
                      ;            r1)]
                      [(rule) 
                       (if hacer-mutacion?
                           (begin
                             (printf "Mutación del gen ~a~n" ord-mutante)
                             (make-regla 1 (take hijo-mutado 8) (last hijo-mutado) -1))
                           (make-regla 1 (take hijo 8) (last hijo) -1))]
                      )
          (values
           r1 r2
           hijo
           rule
           )
          )
        ))
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (super-new)
    ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ag (make-object operaciones-ag%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define generar_reglas%
  (class object%
    ;;Técnica para generar una regla
    (define genera-antecedente
      (lambda (out_receptor)
        out_receptor ))
    ;;;;;;;;;;;;;;
    (define genera-accion
      (lambda (list_ordinales)
        (first list_ordinales)
        ))
    ;;;;;;;;;;;;;;
    (define/public generar-regla
      (lambda (out_receptor N)
        (let* ((antecedente (genera-antecedente out_receptor))
               (accion 
                (genera-accion (list 0 1 2 3 4 5 6 7)))
;                 (if orden_vec (remove* orden_vec (list 0 1 2 3 4 5 6 7)) (list 0 1 2 3 4 5 6 7))))
               )
          (make-regla 1 antecedente accion N)
          )
        ))
    ;;;;;;;;;;;;;;
    (define/public modificar-accion
      (lambda (lista_ordinales lista-acciones_realizadas)
        (let ((proc (if (= (random 2) 0) first last)) )
          (first
           (remove* lista-acciones_realizadas
                    lista_ordinales))
          )
        ))
    ;;Técnica para generalizar una regla
    (define/public generalizar-regla
      (lambda (regla)
        (let ((antecedente (regla-antecedente regla))
              (accion (regla-produccion regla))
              )
          (map
           (lambda (par ord)
             (if (= ord accion)
                 par
                 (if (= (car par) 0)
                     (cons 0 #\#)
                     par)
                 )
             )
           antecedente '(0 1 2 3 4 5 6 7))
          )
        ))
    (super-new)
    ))
;;;;;;;
(define generar-reglas (make-object generar_reglas%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define motor_inferencias%
  (class object%
    (field
     (M-set 'conjunto-reglas-activadas)
     )
    (define seleccion-de-M
      (lambda (output_receptor BC)
        (cond
          ((null? BC) '())
          ((match (regla-antecedente (first BC)) output_receptor)
           (cons
            (first BC)
            (seleccion-de-M output_receptor (rest BC))) )
          (else
           (seleccion-de-M output_receptor (rest BC)))
          )
        ))
    (define match-par?
      (lambda (par1 par2);antecedente-regla output_receptor
        (and
         (equal? (car par1) (car par2))
         (or
          (char? (cdr par1))
          (equal? (cdr par1) (cdr par2))
          ))
        ))
    (define match
      (lambda (lista1 lista2);antecedente-regla output_receptor
        (let go ((i 0)
                 (j (length lista1))
                 )
          (if (= i j)
              #t
              (if (match-par? (list-ref lista1 i) (list-ref lista2 i))
                  (go (add1 i) j)
                  #f)
              )
          )
        ))
    (define/public proceso!
      (lambda (out_receptor bc)
        (set! M-set
              (seleccion-de-M out_receptor bc))
        M-set
        ))
    (super-new)
    ))
;;;;;;
(define motor_inferencial (make-object motor_inferencias%))
;;;;;;;;;;;;;;;;;;;;;
(define probabilidad_reglas%
  (class object%
    (field
     )
    (define sumatorio-fuerzas
      (lambda (set-M)
        (if (null? set-M)
            0
            (+
             (regla-fuerza (first set-M))
             (sumatorio-fuerzas (rest set-M)))
            )
        ))
    (define probabilidad-uno
      (lambda (fuerza-uno sumatorio_fuerzas)
        (/ fuerza-uno sumatorio_fuerzas)
        ))
    (define lista-ordinales
      (lambda (M_set n)
        (if (null? M_set)
            '()
            (cons
             n
             (lista-ordinales (rest M_set) (add1 n)))
            )
        ))
    (define/public proceso!
      (lambda (set_M)
        (let* ((sumatorio (sumatorio-fuerzas set_M))
               (set-M-ordenado
                (sort    
                 (map
                  (lambda (una-r ordinal)
                    (cons
                     (probabilidad-uno (regla-fuerza una-r) sumatorio)
                     ordinal)
                    )
                  set_M (lista-ordinales set_M 0))
                 #:key car >));#:key car <
               (rule_order (cdr (first set-M-ordenado)))
               )
          (list-ref set_M rule_order)
          )
        ))
    (super-new)
    ))
;;;;;;;;
(define regla-mas-probable (make-object probabilidad_reglas%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define procesar-recompensa%
  (class object%
    (define/public procesar-recompensa!
      (lambda (secuencia-actos)
        (difundir-recompensa-secuencia secuencia-actos 1)
        ))
    (define difundir-recompensa-secuencia
      (lambda (secuencia p)
        (cond
          ((null? secuencia) #t)
          (else
           (set! p
                 (refuerzo-un-acto (car secuencia) p))
           (difundir-recompensa-secuencia (cdr secuencia) p)
           )
          )
        ))
    (define refuerzo-un-acto
      (lambda (elemento-secuencia P)
        (let ((A-set (third elemento-secuencia))
              (next-p 0)
              )
          (letrec ((aux
                    (lambda (set-A p)
                      (if (null? set-A)
                          '()
                          (let ((fraccion_restada (reajuste-fuerza-por-recompensa (car set-A) 0.01 p (length A-set))))
                            (set! next-p (+ next-p fraccion_restada))
                            (cons
                             (car set-A)
                             (aux (cdr set-A) p)
                             )
                            )
                          )
                      ))
                   )
            (aux A-set P)
            next-p
            )
          )
        ))
    (define reajuste-fuerza-por-recompensa
      (lambda (regla epsilon p length-A-set)
        (let* ((fuerza_r (regla-fuerza regla))
               (recompensa (/ p length-A-set))
               (fraccion-restada (* epsilon fuerza_r))
               )
          (set-regla-fuerza!
           regla
           (+
            fuerza_r
            recompensa
            (- fraccion-restada)
            )
           )
          fraccion-restada
          )
        ))
    (super-new)
    ))
;;;;;;;
(define calculos-recompensa (make-object procesar-recompensa%))
;;;;;;;;;;;;;;;;;;;;;
(define control_central%
  (class object%
    ;;init-field: los subsistemas
    (init-field
     (Generador-reglas 'generar-reglas)
     (Interprete-reglas 'motor_inferencial)
     (Probabilidad-reglas 'regla-mas-probable)
     (Calcular-recompensa 'calculos-recompensa)
     (Operador-genetico 'ag)
     (BC_length 0)
     )
    ;;field: propiedades estructurales
    (field
     (BC '())
     (M_set 'conjunto-de-reglas-activadas)
     (exito 0)
     (last-rule #f)
     (last-action '())
     ;;;
     (historia '())
     (Secuencia-actos '())
     (A_set '())
     (accion #f)
     ;;;
     (numero-recompensas 0)
     (la_peor #f)
     (h-recompensas '())
     (AG-activado #f)
     )
    ;;;;;;;;;;;;;;;;;;;;
    (define/public set-BC
      (lambda (n)
        (set! BC
              (send Operador-genetico make-BC n))
        ))
    (define/public get-h-recompensas
      (lambda ()
        h-recompensas))
    ;;;;;;;;;;;;;;;;;;;;
    (define sustituir-regla
      (lambda (BC new-last-rule)
        (let ((V (list->vector BC))
              )
          (vector-set! V (regla-id new-last-rule) new-last-rule)
          (set! BC
                (vector->list V))
          )
        BC
        ))
    (define borrar-la-peor
      (lambda (R-peor)
        (set! BC
              (filter-map
               (lambda (r)
                 (if (= (regla-id r) (regla-id R-peor))
                     #f
                     r)
                 )
               BC)
              )
        ))
    (define regla-peor
      (lambda (BC clase)
        (let ((clase-peor 
               (ormap
                (lambda (c)
                  (cond
                    ((null? c) #f)
                    ((= (regla-produccion (first c)) clase) c)
                    (else #f)
                    )
                  )
                BC)
               )
              )
          (if clase-peor
              (last clase-peor)
              (last (get_bc))
              )
          )
        ))
    (define set-fuerza
      (lambda (regla BC)
        (ormap
         (lambda (r)
           (if
            (and
             (equal?  (regla-antecedente regla) (regla-antecedente r))
             (equal? (regla-produccion regla) (regla-produccion r))
             )
            (regla-fuerza r)
            #f)
           )
         BC)
        ))
    ;;;;;;;;;;;;;;;;;;;;
    (define set-secuencia_actos
      (lambda ()
        (set! Secuencia-actos (cons (list accion last-rule A_set) Secuencia-actos))
        ))
    (define inicializa-secuencia_actos
      (lambda ()
        (set! Secuencia-actos '())
        ))
    (define generalizada?
      (lambda (antecedente)
        (ormap
         (lambda (par)
           (char? (cdr par))
           )
         antecedente)
        ))
;;;;;;;;;;;;;;;;;;;;;;;;;
    (define M-set->A-set
      (lambda (M-set rule)
        (cond 
          ((null? M-set) '())
          ((= (length M-set) 1) M-set)
          ((= (regla-produccion rule) (regla-produccion (car M-set)))
           (cons (car M-set)
                 (M-set->A-set (cdr M-set) rule)) )
          (else
           (M-set->A-set (cdr M-set) rule))
          )
        ))
;;;;;;;;;;;;;;;;;;;;;;;;;
    (define/public get_bc
      (lambda ()
        (sort BC #:key regla-fuerza >) ))
    (define/public get-bc
      (lambda ()
        (map
         (lambda (o)
           (sort
           (filter-map
            (lambda (r)
              (if (= (regla-produccion r) o)
                  r
                  #f))
            BC) 
           #:key regla-fuerza >))
         '(0 1 2 3 4 5 6 7))
        ))    
    ;;;;;;;;;;;;;;;;;;;;
    (define/public set-exito
      (lambda (valor num_iter)
        (set! exito valor)
        (printf "***Proceso de refuerzo***~n")
        (printf "La acción realizada ha tenido ~a~n" (if (< exito 0) "fracaso" (if (= exito 0) "éxito" "recompensa")))
        (cond
          ((negative? exito)
           (printf "Secuencia actos: ~a~nRegla: ~a~n" (length Secuencia-actos) last-rule)
           (set-regla-produccion! last-rule
                                  (send Generador-reglas modificar-accion (list 0 1 2 3 4 5 6 7) last-action) )
           (sustituir-regla BC last-rule)
           (printf "Regla modificada: ~a~n" last-rule) 
           )
          
          ((zero? exito)
           (set-secuencia_actos)
           (printf "Secuencia actos: ~a~n regla: ~a~n" (length Secuencia-actos) last-rule)
           (unless (generalizada? (regla-antecedente last-rule))
             (printf "Se generaliza el antecedente de la regla~a~n" last-rule)
             (set-regla-antecedente! last-rule
                                     (send Generador-reglas generalizar-regla last-rule))
             (printf "Regla modificada: ~a~n" last-rule)
             (if (= BC_length (length BC))
                 (sustituir-regla BC last-rule)
                 (begin
                   (borrar-la-peor la_peor)
                   (set-regla-id! last-rule (regla-id la_peor))
                   (sustituir-regla BC last-rule)
                   )
             )
             )
           )
          
          ((= exito 1)
           (set! numero-recompensas (add1 numero-recompensas))
           (set-secuencia_actos)
           (printf "Secuencia actos: ~a~n regla: ~a~n" (length Secuencia-actos) last-rule)
           (unless (generalizada? (regla-antecedente last-rule))
             (printf "Se generaliza el antecedente de la regla~a~n" last-rule)
             (set-regla-antecedente! last-rule
                                     (send Generador-reglas generalizar-regla last-rule))
             (printf "Regla modificada: ~a~n" last-rule)
             
             (borrar-la-peor la_peor)
             (set-regla-id! last-rule (regla-id la_peor))
             (sustituir-regla BC last-rule)
             
             ) 
           (send Calcular-recompensa procesar-recompensa! Secuencia-actos)
           (inicializa-secuencia_actos)
           )
          )
        (printf "***Fin del proceso de refuerzo***~n")
        ))
    (define proceso-ag
      (lambda ()
        (let*-values 
            ([(r1 r2 hijo rule)
              (send Operador-genetico new-classifiers->BC (get-bc))]
             [(fuerza-de-regla_ag) (set-fuerza rule BC)]
             [(regla_peor) (regla-peor (get-bc) (regla-produccion rule))]
             )
          (set-regla-fuerza! rule (if fuerza-de-regla_ag fuerza-de-regla_ag 1))
          (set-regla-id! rule (regla-id regla_peor))
          (sustituir-regla BC rule)
          (printf "Proceso del AG acabado~nRegla: ~a~n" rule)
          )
        ))
    ;;;;;;;;;;;;;;;;;;;;
    (define/public proceso!
      (lambda (output_receptor iter)
        (printf "***Proceso del cerebro***~n")
        (when (and 
               (or (>= numero-recompensas 5) (= iter 50))
               (not AG-activado))
          (set! AG-activado #t))
        (when AG-activado (proceso-ag))
        (printf "Estímulo: ~a~n" output_receptor)
        (printf "Tamaño BC: ~a ~n" (length BC))
        (set! M_set (send Interprete-reglas proceso! output_receptor BC))
        (printf "M-Set ~a~n" (length M_set))
        (cond
          ;;M-set está vacío. Se necesita una nueva regla
          ((null? M_set)
           (set! last-rule (send Generador-reglas generar-regla output_receptor (length BC)))
           (set! accion (regla-produccion last-rule))
           (set! last-action (cons accion '()))
           (printf "Regla generada: ~a~n" last-rule)

           (set! la_peor (regla-peor (get-bc) accion))
           
           (set! BC (cons last-rule BC)) 
           (set! M_set (cons last-rule M_set))
           )
          ;;M-set no está vacío
          (else
           
           (set! last-rule (send Probabilidad-reglas proceso! M_set))
           (set! accion (regla-produccion last-rule))
           (set! last-action (cons accion last-action))
           (printf "Regla de mayor probabilidad: ~a~n" last-rule)
           )
          )
        (set! A_set (M-set->A-set M_set last-rule))
        (printf "***Fin proceso del cerebro***~n")
        (values accion)
        ))
    (super-new)
    ))
;;;;;;;;;;;
(define cerebro (make-object control_central% generar-reglas motor_inferencial regla-mas-probable calculos-recompensa ag 480))
                  
(send cerebro set-BC 480)

(provide cerebro)

