#lang scheme
;(require mzlib/trace)

(define-struct nodo
  (;fields
   id 
   estado
   camino
   nivel
   (proc-gen #:mutable)
   (terminal #:mutable)
   )
  #:transparent)
;;forma mensaje de acceso: (nodo-id ejemplar)
;;cada field ha de ser calificado de #:mutable. forma mensaje de set!: (set-nodo-id ejemplar new)

;;un árbol es una hash-table. Cada elemento del árbol tiene una key:= número de orden (arriba->abajo, izqda->dcha) y un nodo
;;construir el árbol es construir la hash-table.
;;funciones: hash-count; hash-ref; hash-set! en la forma (hash-set! arbol (add1 (hash-count arbol)) nodo)

(define arbol-bidones (make-hash))
(hash-set! arbol-bidones 0 (make-nodo 0 (cons 0 0) (list 0) 0 null #f)); null

;; Para escribir en pantalla
(define pnodo
  (lambda (mensa nodo)
    (printf "~a nodo ~a ~a ~a ~a ~a~n"
            mensa
            (nodo-id nodo) 
            (nodo-estado nodo) 
            (nodo-camino nodo) 
            (nodo-nivel nodo) 
            (nodo-terminal nodo)) ))
(define parbol
  (lambda (arbol)
    (let go ((j (hash-count arbol))
             (i 0)
             (nodo #f))
      (if (= i j)
          (newline)
          (begin
            (set! nodo (hash-ref arbol i))
            (pnodo "" nodo)
            (go j (add1 i) #f))) )))

(define psoluciones
  (lambda (lst)
    (if (null? lst)
        (void)
        (begin
          (pnodo "" (car lst))
          (psoluciones (cdr lst))))))
;;
(define num-niveles-arbol
  (lambda (arbol)
    (let go ((j (hash-count arbol))
             (i 0)
             (k 0)
             )
      (if (= i j)
          k
          (if (> (nodo-nivel (hash-ref arbol i)) k)
              (go j (add1 i) (nodo-nivel (hash-ref arbol i)))
              (go j (add1 i) k))) )))
(define pnivel-arbol
  (lambda (arbol nivel)
    (let go ((j (hash-count arbol))
             (i 0)
             )
      (if (= i j)
          (newline)
          (if (= (nodo-nivel (hash-ref arbol i)) nivel)
              (begin
                (pnodo 
                 (string-append "nivel-" (number->string nivel)) (hash-ref arbol i))
                (go j (add1 i))
                )
              (go j (add1 i))))
      )))
(define parbol-niveles
  (lambda (arbol)
    (let go ((k (num-niveles-arbol arbol))
             (i 0)
             )
      (if (= i k)
          (newline)
          (begin
            (pnivel-arbol arbol i)
            (go k (add1 i))))
      )))
(define psoluciones-arbol
  (lambda (arbol)
    (let go ((j (hash-count arbol))
             (i 0)
             (nodo #f))
      (if (= i j)
          (newline)
          (begin
            (set! nodo (hash-ref arbol i))
            (if (es-solucion? (nodo-estado nodo))
                (begin
                  (pnodo "" nodo)
                  (go j (add1 i) #f))
                (go j (add1 i) #f)))
          )) ))

;;Operaciones posibles
(define llenar-G
  (lambda (G P)
    (cons 5 P) ))
(define llenar-P
  (lambda (G P)
    (cons G 3) ))
(define vaciar-G
  (lambda (G P)
    (cons 0 P) ))
(define vaciar-P
  (lambda (G P)
    (cons G 0) ))
(define P->G;rellenar G con P
  (lambda (g p)
    (cond
      ((<= (+ g p) 5) 
       (cons (+ g p) 0))
      ((> (+ g p) 5) 
       (cons 5 (- (+ g p) 5)))
      )
    ))
(define G->P;rellenar P con G
  (lambda (g p)
    (cond
      ((<= (+ g p) 3) 
       (cons 0 (+ g p)))
      ((> (+ g p) 3) 
       (cons (- (+ g p) 3) 3))
      )
    ))
;;operaciones posibles como funciones predicativas
(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))) ))
;;Dado un nodo, nodo-estado, son operaciones aplicables
(define operaciones-aplicables
  (lambda (nudo)
    (let* ((id (nodo-id nudo))
           (estado (nodo-estado nudo))
           (camino (nodo-camino nudo))
           (nivel (nodo-nivel nudo))
           (proc-gen (nodo-proc-gen nudo))
           (terminal (nodo-terminal nudo))
           (G (car estado))
           (P (cdr estado))
           (operaciones-aplicables '())
           )
      (when (es-posible-llenar? G 5)
        (set! operaciones-aplicables 
              (append operaciones-aplicables 
                      (list llenar-G))))
      (when (es-posible-llenar? P 3)
        (set! operaciones-aplicables 
              (append operaciones-aplicables 
                      (list llenar-P))))
      (when (es-posible-vaciar? G)
        (set! operaciones-aplicables 
              (append operaciones-aplicables 
                      (list vaciar-G))))
      (when (es-posible-vaciar? P)
        (set! operaciones-aplicables 
              (append operaciones-aplicables 
                      (list vaciar-P))))
      (when (es-posible-rellenar? G 5 P) 
        (set! operaciones-aplicables 
              (append operaciones-aplicables 
                      (list P->G))))
      (when (es-posible-rellenar? P 3 G)
        (set! operaciones-aplicables 
              (append operaciones-aplicables 
                      (list G->P))))
      operaciones-aplicables )))
;;
(define operaciones-en-nodo
  (lambda (nudo)
    (let ((oper-apl (operaciones-aplicables nudo)))
      (set-nodo-proc-gen! nudo oper-apl) 
      )))
(define resta-operacion-a-nodo
  (lambda (nudo)
    (set-nodo-proc-gen! nudo (rest (nodo-proc-gen nudo))) ))

(define terminal!
  (lambda (nudo booleano)
    (set-nodo-terminal! nudo booleano) ))
;;
(define next-nodo
  (lambda (nudo arbol)
    (let* (
           (id (nodo-id nudo))
           (estado (nodo-estado nudo))
           (camino (nodo-camino nudo))
           (nivel (nodo-nivel nudo))
           (procs-gen (nodo-proc-gen nudo))
           (terminal (nodo-terminal nudo))
           (G (car estado))
           (P (cdr estado))

           (new-nodo-id (hash-count arbol))
           (new-nodo-estado ((first procs-gen) G P))
           (new-nodo-camino (cons new-nodo-id camino))
           (new-nodo-nivel (add1 nivel))
           (new-nodo-proc-gen null)
           (new-nodo-terminal #f)

           (new-nodo 
            (make-nodo
             new-nodo-id
             new-nodo-estado
             new-nodo-camino
             new-nodo-nivel
             new-nodo-proc-gen
             new-nodo-terminal))
           )
      (operaciones-en-nodo new-nodo)
      (resta-operacion-a-nodo nudo)
      (cond
        ((existe-en-path? new-nodo-estado camino)
         (terminal! new-nodo #t)
         )
        ((es-solucion? new-nodo-estado)
         (terminal! new-nodo #t)
         )
         (else
          (terminal! new-nodo #f)
          )
         ) 
      new-nodo
      ) ))
;;construye árbol
;;hay que hacerlo recursivamente sobre lista de operaciones
(define expansion-arbol
  (lambda (nudo lista-oper arbol)
    (cond
      ((null? lista-oper) 'hecho)
      (else
       (let (
             (siguiente (next-nodo nudo arbol))
             )
         (hash-set! arbol (nodo-id siguiente) siguiente)
         (if (nodo-terminal siguiente)
             (expansion-arbol nudo (rest lista-oper) arbol)
             (begin
               (expansion-arbol 
                siguiente (nodo-proc-gen siguiente) arbol)
               (expansion-arbol nudo (rest lista-oper) arbol))
             )) )
      ) ))
(define construye-arbol
  (lambda (arbol)
    (operaciones-en-nodo (hash-ref arbol 0))
    (let* ((nudo (hash-ref arbol 0))
           (lista-operaciones (nodo-proc-gen nudo))
           )
      (expansion-arbol nudo lista-operaciones arbol)
      (printf "Hecho. Nº nudos: ~a~n" (hash-count arbol))
      ) ))
;;Restricciones
(define existe-en-path?
  (lambda (estado path)
    (if (null? path)
        #f
        (let* ((nudo (hash-ref arbol-bidones (first path)))
               (nudo-estado (nodo-estado nudo))
               )
          (if (equal? estado nudo-estado)
              #t
              (existe-en-path? estado (rest path))
              ))
        ) ))
(define es-solucion?
  (lambda (new-estado)
    (= (car new-estado) 4) ))
;;
(define all-terminales?
  (lambda (id-nodo arbol)
    (let go ((j (hash-count arbol))
             (i id-nodo))
      (if (= i j)
          #t
          (if (nodo-terminal (hash-ref arbol i))
              (go j (add1 i))
              #f))) ))
;;Soluciones y solución óptima
(define-syntax solucion?
  (syntax-rules ()
    ((solucion? estado)
     (= (car estado) 4) )))
(define soluciones
  (lambda (arbol)
    (let go ((i 0)
             (j (hash-count arbol))
             (lst '())
             )
      (if (= i j)
          (reverse lst)
          (if (solucion? (nodo-estado (hash-ref arbol i)))
              (go (add1 i) j (cons (hash-ref arbol i) lst))
              (go (add1 i) j lst))) ) ))
(define solucion-optima
  (lambda (soluciones)
    (letrec 
        ((optima (first soluciones))
         (resto (rest soluciones))
         (aux
          (lambda (opt restantes respuesta)
            (let ((num-path-opt (length (nodo-camino opt)))
                  (num-path-cadr 
                   (if (null? restantes)
                       (void)
                       (length 
                        (nodo-camino (first restantes)))))
                  )
              (cond
                ((null? restantes) respuesta)
                ((= num-path-cadr num-path-opt)
                 (aux 
                  opt 
                  (cdr restantes) 
                  (cons (first restantes) respuesta)))
                ((< num-path-cadr num-path-opt)
                 (aux 
                  (first restantes) 
                  (cdr restantes) 
                  (list (first restantes))))
                (else
                 (aux opt (cdr restantes) respuesta))
                )
              ) ))
         )
      (aux optima resto (list optima))
      ) ))
;;;;;;;;;;;;;
(construye-arbol arbol-bidones)

(printf "~nSOLUCIONES:~n")
(psoluciones (soluciones arbol-bidones))
(printf "~nSOLUCIÓN ÓPTIMA:~n")
(solucion-optima (soluciones arbol-bidones))