#lang scheme

(require "Clases-neuron-capa-red.rkt")

;;;;;;;;;;;;;;INSTANCIAS
;;;NEURONAS
(define n_1 (make-object neuron_entrada% 'n_1))
(define n_2 (make-object neuron_entrada% 'n_2))
(define n_3 (make-object neuron_entrada% 'n_3))
(define n_4 (make-object neuron_entrada% 'n_4))

(define n_5 
  (make-object neurona%  'n_5
    4 propagacion_lineal lineal escalon_1))
(define n_6 
  (make-object neurona%  'n_6
    3 propagacion_lineal lineal escalon_1))
;;;CAPAS
(define capa_1 
  (make-object capa_entrada% 'c_1
    (list n_1 n_2 n_3 n_4) ))
(define capa_2 
  (make-object capa% 'c_2
    (list n_5 n_6) (list (list 2 2 1 1) (list 1 1 1 0))))

;;; Procedimientos de dibujo

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; LA RED CON MONITOR
(define red-monitorizada%
  (class red%
    (inherit-field lista-capas)
    
    (define/public procesar!
      (lambda (input)
        (let go ((input input)
                 (capas lista-capas)
                 (hoffset 10) )
          (cond
            ((null? capas) input)
            (else
             (display input) (display "-->")
             (set! input (send (car capas) proceso! input))
             ;(pinta-capa input hoffset)
             (go input (cdr capas) (+ hoffset 30)) ) )) ))
    (super-new) ))
;;;;
;;;RED
(define perceptron (make-object red-monitorizada% (list capa_1 capa_2)))

;;;;;;;;;ENTRENAMIENTO
(define estimulos
  (list
   '(1 1 1 1)
   '(1 1 1 0)
   '(1 1 0 1)
   '(1 1 0 0)
   '(1 0 1 1)
   '(1 0 1 0)
   '(1 0 0 1)
   '(1 0 0 0)
   '(0 1 1 1)
   '(0 1 1 0)
   '(0 1 0 1)
   '(0 1 0 0)
   '(0 0 1 1)
   '(0 0 1 0)
   '(0 0 0 1)
   '(0 0 0 0)
   ))
(define training_set
  (list
   (cons '(1 1 1 1) '(1 0))
   (cons '(1 1 1 0) '(0 0))
   (cons '(1 1 0 1) '(0 0))
   (cons '(1 1 0 0) '(0 0))
   (cons '(1 0 1 1) '(0 0))
   (cons '(1 0 1 0) '(0 0))
   (cons '(1 0 0 1) '(0 0))
   (cons '(1 0 0 0) '(0 0))
   (cons '(0 1 1 1) '(0 1))
   (cons '(0 1 1 0) '(0 0))
   (cons '(0 1 0 1) '(0 0))
   (cons '(0 1 0 0) '(0 0))
   (cons '(0 0 1 1) '(0 0))
   (cons '(0 0 1 0) '(0 0))
   (cons '(0 0 0 1) '(0 0))
   (cons '(0 0 0 0) '(0 0))
   ))
   
;;Cálculo del error
(define error-una-neurona
  (lambda (R_deseada R_dada alpha);alpha=0.25
    (* alpha (- R_deseada R_dada))
    ))
;;Modificación de un parámetro
(define set-parametro
  (lambda (error param señal)
    (+ param (* error señal)) ))
;;Modificación de pesos
(define modifica-pesos
  (lambda (error lst-señales lst-pesos)
    (if (null? lst-señales)
        '()
        (cons
         (set-parametro error (car lst-pesos) (car lst-señales))
         (modifica-pesos error (cdr lst-señales) (cdr lst-pesos)))
        ) ))
;;Modificación parámetros de una neurona
(define mod-parametros_una-neurona
  (lambda (error input neurona pesos)    
    (send neurona set-umbral
          (set-parametro error (send neurona get-umbral) -1))
    (modifica-pesos error input pesos)
    ))
;;Modificación de unidades de una capa
(define modifica-capa
  (lambda (input r_des r_dada capa)
    (let go ((pesos (send capa get-pesos))
             (neuronas (send capa get-neuronas))
             (r_deseadas r_des)
             (r_dadas r_dada)
             (new-pesos '())
             )
      (if (null? neuronas)
          (begin
            (send capa set-pesos (reverse new-pesos)) )
          (let* ((neuron (car neuronas))
                 (weights (car pesos))
                 (err 
                  (error-una-neurona 
                   (car r_deseadas) (car r_dadas) 0.25))
                 )
            (go 
             (cdr pesos) (cdr neuronas) 
             (cdr r_deseadas) (cdr r_dadas)
             (cons 
              (mod-parametros_una-neurona err input neuron weights)
              new-pesos))
            )
          )
      )
    ))
;;;Auxiliar para escribir informe                 
(define print-pesos-umbral
  (lambda (capa)
    (let go ((pesos (send capa get-pesos))
             (neuronas (send capa get-neuronas))
             )
      (if (null? pesos)
          (newline)
          (begin
            (display "pesos: ")
            (display (car pesos))
            (display "; umbral: ")
            (display (send (car neuronas) get-umbral))
            (newline)
            (go (cdr pesos) (cdr neuronas))
            )
          )
      )
    ))
;;;Algoritmo de entrenamiento
(define entrenamiento
  (lambda (training-set red)
    (printf "~nEntrenamiento~n")
    (let go ((conj-e training-set)
             (capa (second (send red get-capas)))
             )
      (cond
        ((null? conj-e) )
        (else
         (let* ((row (car conj-e))
                (input (car row))
                (r_deseada (cdr row))
                (r_dada (send red procesar! input))
                )
           (display r_dada) (newline)
           (print-pesos-umbral capa)
           (unless (equal? r_deseada r_dada)
             (modifica-capa input r_deseada r_dada capa)
             (printf "Nuevos parámetros: ~n")
             (print-pesos-umbral capa)
             )
           )
         (go (cdr conj-e) capa) )
        )
      ) 
    ))
;;;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 procesar! 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.025)
;;
(define delta-entrenamiento
  (lambda (red training-set)
    (let go ((i 0)
             (j 100)
             )
      (if (= i j)
          #t
          (begin
            (entrenamiento training-set red)
            (if (<= (error-medio red training-set) minimo-delta)
                (begin
                  (printf "~nRed entrenada. Iteración: ~a~n" i)
                  (print-pesos-umbral 
                   (second (send red get-capas))))
                (go (add1 i) j)
                )
            )
          )
      )
    ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(printf "Red: perceptron-bicapa.~nParámetros:~n")
(print-pesos-umbral (second (send perceptron get-capas)))
;;;Delta
(printf "~nError medio: ~a ~n" (error-medio perceptron training_set))

(delta-entrenamiento perceptron training_set)

(printf "~nError medio: ~a ~n" (error-medio perceptron training_set))