#lang scheme

;;Constantes de atenuación
(define alpha 0.5)
(define momentum 0.9)

;;;Cálculo del error de una neurona de la capa de salida
(define error-una-neurona_salida
  (lambda (r_deseada r_dada)
    (* (- r_deseada r_dada)
       (* r_dada (- 1 r_dada)))
    ))
;;;Errores en neuronas capa salida
(define errores-capa-salida
  (lambda (respuestas_d neuronas)
    (if (null? respuestas_d)
        (begin
          (newline)
          #t
          )
        (begin
          (send (car neuronas) add-error
                (error-una-neurona_salida 
                 (car respuestas_d) 
                 (send (car neuronas) get-salida)))
          (errores-capa-salida (cdr respuestas_d) (cdr neuronas))
          )
        )
    ))
;;;Cálculo del error de una neurona de una capa oculta
(define error-neuron-oculta
  (lambda (neuron lst-errores lst-pesos)
    (letrec 
        ((r_dada (send neuron get-salida))
         (aux
          (lambda (e p)
            (if (null? e)
                0
                (+
                 (* (car e) (car p))
                 (aux (cdr e) (cdr p)))
                )
            ))
         )
      (*
       (* r_dada (- 1 r_dada))
       (aux lst-errores lst-pesos))
      )
    ))
;;Auxiliar para recuperar los errores de las neuronas de una capa    
(define get-errores-capa
  (lambda (capa)
    (define aux
      (lambda (neuronas)
        (if (null? neuronas)
            '()
            (cons
             (send (first neuronas) get-error)
             (aux (rest neuronas)))
            ) ))
    (aux (send capa get-neuronas))
    ))
;;Errores en una capa oculta
(define back-error->capa-oculta
  (lambda (capa_oculta capa_back)
    (let* ((neuronas_back (send capa_back get-neuronas))
           (err-neuronas_back (get-errores-capa capa_back))
           (neuronas_ocultas (send capa_oculta get-neuronas))
           (pesos (send capa_oculta get-pesos))
           )
      (for-each
       (lambda (n pes)
         (send n add-error
               (error-neuron-oculta n err-neuronas_back pes) )
         )
       neuronas_ocultas pesos)
      (newline)
      )
    ))
;;;Para establecer en cada neurona su error
(define set-errores-red
  (lambda (red r_deseadas)
    (let* ((capas (cdr (send red get-capas)))
           (capa_s (last capas))
           (rest-capas (reverse (cdr (reverse capas))))
           (neuronas_s (send capa_s get-neuronas))
           )
      (errores-capa-salida r_deseadas neuronas_s)
      (let go ((resto-capas rest-capas)
               (capa capa_s)
               )
        (if (null? resto-capas)
            #t
            (begin
              (back-error->capa-oculta (first resto-capas) capa)
              (go (cdr resto-capas) (first resto-capas))
              )
            )
        )
      )
    ))
;;;MODIFICACIÓN DE PARAMETROS
(define modifica-parametro
  (lambda (param error-neuron salida_n_previa)
    (+ param
       (* alpha error-neuron salida_n_previa)
       (* momentum param))
    ))
(define modifica-pesos-neurona
  (lambda (neuron pesos lst-sal-previas)
    (if (null? pesos)
        '()
        (cons
          (modifica-parametro
           (car pesos)
           (send neuron get-error)
           (car lst-sal-previas))
          (modifica-pesos-neurona 
           neuron (cdr pesos) (cdr lst-sal-previas)) )
        )
    ))
(define modifica-parametros-neurona
  (lambda (neuron pesos lst-sal-previas)
    (send neuron set-umbral
              (modifica-parametro
               (send neuron get-umbral)
               (send neuron get-error)
               -1))
    (modifica-pesos-neurona neuron pesos lst-sal-previas)
    ))
(define modifica-capa
  (lambda (capa capa_previa)
    (let go ((neuronas (send capa get-neuronas))
             (pesos (send capa get-pesos))
             (vector_prev (get-salida-capa capa_previa))
             (patron '())
             )
      (if (null? neuronas)
          (send capa set-pesos (reverse patron))
          (go
           (cdr neuronas)
           (cdr pesos)
           vector_prev
           (cons
            (modifica-parametros-neurona
             (car neuronas) (car pesos) vector_prev)
            patron))
          )
      )
    )
  )
;;Auxiliar para recuperar las salidas de las neuronas de una capa    
(define get-salida-capa
  (lambda (capa)
    (define aux
      (lambda (neuronas)
        (if (null? neuronas)
            '()
            (cons
             (send (first neuronas) get-salida)
             (aux (rest neuronas)))
            ) ))
    (aux (send capa get-neuronas))
    ))
;;Modificación parámetros de la red
(define modifica-parametros-red
  (lambda (red)
    (let ((capas (send red get-capas)) )
      (let go ((previa (car capas))
               (resto (cdr capas))
               )
        (if (null? resto)
            'hecho
            (begin
              (modifica-capa (car resto) previa)
              (go (car resto) (cdr resto))
              )
            )
        )
      )
    ))
;;;Auxiliar para escribir informe                 
(define print-patron-conexionista
  (lambda (red)
    (let go ((capas (cdr (send red get-capas)))
             )
      (if (null? capas)
          (newline)
          (begin
            (print-esquema-capa (car capas))
            (go (cdr capas))
            )
          )
      )
    ))
(define print-esquema-capa
  (lambda (capa)
    (let go ((neuronas (send capa get-neuronas))
             (pesos (send capa get-pesos))
             )
      (if (null? neuronas)
          (newline)
          (begin
            (print-informe-neurona (car neuronas) (car pesos))
            (go (cdr neuronas) (cdr pesos))
            )
          )
      )
    ))
(define print-informe-neurona
  (lambda (neuron pesos_af)
    (printf "neurona ~a; umbral ~a; pesos_aferentes ~a ~n"
            (send neuron get-id)
            (send neuron get-umbral)
            pesos_af)))

;;;Algoritmo de entrenamiento 
(define igual-deseada-dada?
  (lambda (lst_des lst_da)
    (if (null? lst_des)
        #t
        (if
         (case
             (car lst_des)
           ((0.9) (> (car lst_da) 0.8))
           ((0.1) (< (car lst_da) 0.2))
           )
         (igual-deseada-dada? (cdr lst_des) (cdr lst_da))
         #f)
        )
    ))
(define entrenamiento
  (lambda (training-set red)
    (printf "Entrenamiento~n")
    (let go ((conj-e training-set)
             )
      (cond
        ((null? conj-e) )
        (else
         (let* ((row (car conj-e))
                (input (car row))
                (r_deseada (cdr row))
                (r_dada (send red proceso! input))
                )
           (unless (igual-deseada-dada? r_deseada r_dada)
             (set-errores-red red r_deseada)
             (modifica-parametros-red red)
             )
           )
         (go (cdr conj-e) ) )
        )
      ) 
    ))
;;;LA REGLA DELTA
(define error-neurona
  (lambda (R_deseada R_dada)
    (- R_deseada R_dada)
    ))
(define error-todas-neuronas
  (lambda (lst-deseada lst-dada)
    (if (null? lst-deseada)
        0
        (+
         (expt (error-neurona (car lst-deseada) (car lst-dada)) 2)
         (error-todas-neuronas (cdr lst-deseada) (cdr lst-dada)))
        )
    ))
(define suma-errores
  (lambda (red conj-e)
    (if (null? conj-e)
        0
        (let* ((row (car conj-e))
               (input (car row))
               (r_deseada (cdr row))
               (r_dada (send red proceso! input))
               )
          (+ 
           (error-todas-neuronas r_deseada r_dada)
           (suma-errores red (cdr conj-e))) 
          )
        )
    ))

(define error-medio
  (lambda (red training-set)
    (* (/ 1 (length training-set))
       (suma-errores red training-set))
    ))
;;El valor mínimo del error-medio
(define minimo-delta 0.1)
;;
(define delta-entrenamiento
  (lambda (red training-set)
    (let go ((i 0)
             (j 1000)
             )
      (if (= i j)
          #t
          (begin
            (printf "Iteración: ~a. " (add1 i))
            (entrenamiento training-set red)
            (if (<= (error-medio red training-set) minimo-delta)
                (begin
                  (printf "~nRed entrenada. Iteración: ~a~n" (add1 i))
                  (printf "Nuevo Patrón Conexionista: ~n")
                  (print-patron-conexionista red)
                  )
                (go (add1 i) j)
                )
            )
          )
      )
    ))
(provide delta-entrenamiento print-patron-conexionista error-medio minimo-delta)