#lang scheme

;;Parámetros y funciones específicas de dos bidones

(provide 
 ;parámetros que son variables
 length-cromosoma 
 length-poblacion
 %pot-repr 
 %mejores-repr
 punto-de-cruce
 prob-mutacion
 solucion
 ;parámetros que son procedimientos         
 criterio-fitness
 criterio-parada
 haz-gen!
 muta-gen
 poblacion-fitness
 )

;;PARAMETROS QUE SON VARIABLES
;;del cromosoma
(define length-cromosoma 7)
;;de la población
(define length-poblacion 16); 50 100
;;porcentaje de la población que se reproduce
(define %pot-repr (/ 2 3))
;;los mejores son un % de %a-cruzar
(define %mejores-repr (/ 3 4))
;;punto del cruce de cromosomas
(define punto-de-cruce 3);(random length-cromosoma)); 3
;;probabilidad de la mutación: 1 por 1000
(define prob-mutacion (cons 167 1000)); ~1/6
;;cuando se conoce la solución, ésta es un cromosoma
(define solucion '((4 . 3) (5 . 2) (0 . 2) (2 . 0) (2 . 3) (5 . 0) (0 . 0)))



;;procedimiento específico del problema dos bidones. Genera al azar un gen
(define gen-estado
  (lambda ()
    (let ((a (random 6))
          (b (random 4))
          )
      (cons a b))))
;;función fitness. Siempre depende del problema a tratar
;primer criterio: nudo raíz ha de ser (0 . 0)
;segundo criterio: no puede haber nudos repetidos
;tercer criterio: cada nudo, excepto la raíz, ha de ser un sucesor legítimo del anterior
;sumamos 1 si se cumple un subcriterio, restamos 1 si no se cumple
(define calculo-fitness
  (lambda (cromosoma)
    (let* ((raiz (last cromosoma))
           (grado (if (equal? raiz (cons 0 0)) 1 -1)))
      (let go ((i 0)
               (j (sub1 (length cromosoma))))
        (if (= i j)
            grado
            (+
             (subcriterios i cromosoma)
             (go (add1 i) j))) )) ))
(define subcriterios
  (lambda (i cromosoma)
    (let ((gen (list-ref cromosoma i))
          (antecesor (list-ref cromosoma (add1 i))))
    (cond
      ((member gen (drop cromosoma (add1 i)))
       (if (ilegitimo? gen antecesor) -2 -1))
      ((ilegitimo? gen antecesor) -1)
      (else 1)) ) ))

;;funciones predicativas
;;válida exclusivamente para este fitness
(define ilegitimo?
  (lambda (nodo antecesor)
    (not
     (ormap
      (lambda (exp-ant)
        (equal? nodo exp-ant) )
      (aplica-operaciones antecesor))) ))
;;propias del problema de los dos bidones
(define-syntax es-posible-llenar?
  (syntax-rules ()
    ((es-posible-llenar? bidon tamaño)
     (< bidon tamaño)) ))
(define-syntax es-posible-vaciar?
  (syntax-rules ()
    ((es-posible-vaciar? bidon)
     (not (zero? bidon))) ))
(define-syntax es-posible-rellenar?
  (syntax-rules ()
    ((es-posible-rellenar? bidon1 tamaño bidon2)
     (and (< bidon1 tamaño) (> bidon2 0))) ))
;;operaciones elementales
(define-syntax nodo-cons
  (syntax-rules ()
    ((nodo-cons) (error))
    ((nodo-cons a b) (cons a b))
    ))

(define llenar-G 5)
(define llenar-P 3)
(define vaciar 0)

(define P->G;rellenar G con P
  (lambda (g p)
    (cond
      ((<= (+ g p) 5) (nodo-cons (+ g p) 0))
      ((> (+ g p) 5) (nodo-cons 5 (- (+ g p) 5)))
      )
    ))
(define G->P;rellenar P con G
  (lambda (g p)
    (cond
      ((<= (+ g p) 3) (nodo-cons 0 (+ g p)))
      ((> (+ g p) 3) (nodo-cons (- (+ g p) 3) 3))
      )
    ))
;;procedimiento general     
(define aplica-operaciones
  (lambda (nodo)
    (let ((G (car nodo))
          (P (cdr nodo))
          (resultado '())
          )
      (when (es-posible-llenar? G 5)
        (set! resultado 
              (append resultado 
                      (list (nodo-cons llenar-G P)))))
      (when (es-posible-llenar? P 3)
        (set! resultado 
              (append resultado 
                      (list (nodo-cons G llenar-P)))))
      (when (es-posible-vaciar? G)
        (set! resultado 
              (append resultado 
                      (list (nodo-cons vaciar P)))))
      (when (es-posible-vaciar? P)
        (set! resultado 
              (append resultado 
                      (list (nodo-cons G vaciar)))))
      (when (es-posible-rellenar? G 5 P) 
        (set! resultado 
              (append resultado 
                      (list (P->G G P)))))
      (when (es-posible-rellenar? P 3 G)
        (set! resultado 
              (append resultado 
                      (list (G->P G P)))))
      resultado )))
;;criterio de parada aplicada a toda la población
(define stop->solucion
  (lambda (cromosoma)
    (let ((nodo-solucion (cons 4 (void)))
          (fit-crom (car cromosoma))
          (crom (cadr cromosoma))
          )
    (if
     (and
      (= fit-crom 7)
      (equal? (caar crom) (car nodo-solucion)))
     cromosoma
     #f)) ))
(define hay-una-solucion?;individuo=(fitness (representación))
  (lambda (poblacion)
    (if (null? poblacion)
        #f
        (let* ((cromosoma (stop->solucion (car poblacion)))
               )
          (if cromosoma
              cromosoma
              (hay-una-solucion? (cdr poblacion))) )
        ) ))

;;fitness de una poblacion
(define poblacion-fitness
  (lambda (poblacion)
    (exact->inexact
     (/
      (apply +
             (map
              (lambda (cromosoma)
                (car cromosoma))
              poblacion))
      (length poblacion))
     ) ))
;;PARAMETROS QUE SON PROCEDIMIENTOS

(define criterio-parada hay-una-solucion?)

(define criterio-fitness calculo-fitness)

(define haz-gen! gen-estado)

(define muta-gen gen-estado)

