#lang scheme

;;Estructuras de datos
(define-struct nodo
  (;fields
   id 
   estado
   camino
   nivel
   (terminal #:mutable)
   )
  #:transparent)
;;
(define hanoi (make-hash))
(hash-set! hanoi 
           0 
           (make-nodo 
            0 
            (list '(1 2 3) '() '()) 
            (list 0) 
            0 
            #f))
;; 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))))))
;;;;;Operaciones posibles
(define 1->2
  (lambda (p1 p2 p3)
    (list (rest p1) (cons (first p1) p2) p3)
    ))
(define 1->3
  (lambda (p1 p2 p3)
    (list (rest p1) p2 (cons (first p1) p3))
    ))
(define 2->3
   (lambda (p1 p2 p3)
    (list p1 (rest p2) (cons (first p2) p3))
    ))
(define 2->1
  (lambda (p1 p2 p3)
    (list (cons (first p2) p1) (rest p2) p3)
    ))
(define 3->1
  (lambda (p1 p2 p3)
    (list (cons (first p3) p1) p2  (rest p3))
    ))
(define 3->2
   (lambda (p1 p2 p3)
    (list p1 (cons (first p3) p2) (rest p3))
    ))
;;Operaciones aplicables
(define operaciones-aplicables
  (lambda (estado)
    (let ((p1 (first estado))
          (p2 (second estado))
          (p3 (third estado))
          )
      (cond
        ((null? p1)
         (cond
           ((null? p2) (list 3->1 3->2))
           ((null? p3) (list 2->1 2->3))
           (else (list 2->1 2->3 3->1 3->2)) )
         )
        ((null? p2)
         (cond
           ((null? p1) (list 3->1 3->2))
           ((null? p3) (list 1->2 1->3))
           (else (list 1->2 1->3 3->1 3->2)) )
         )
        ((null? p3)
         (cond
           ((null? p1) (list 2->1 2->3))
           ((null? p2) (list 1->2 1->3))
           (else (list 1->2 1->3 2->1 2->3)) )
         )
        (else (list 1->2 1->3 2->1 2->3 3->1 3->2)
              )
        )
      )
    ))
;;Restricción: ley de Brahma
(define restriccion
  (lambda (estado mov)
    (let* ((p1 (first estado))
           (p2 (second estado))
           (p3 (third estado))
           (nudo (mov p1 p2 p3)))
      (let go ((pilas nudo)
               )
        (if (null? pilas)
            nudo
            (if (cumple-brahma? (first pilas))
                (go (rest pilas))
                #f)
            )
        )
      )
    ))
(define cumple-brahma?
  (lambda (pila)
    (if (null? pila)
        #t
        (if (= (first pila) (apply min pila))
            (cumple-brahma? (rest pila))
            #f)
        )
    ))
(define es-resultado?
  (lambda (nudo)
    (equal? (nodo-estado nudo) (list '() '() '(1 2 3)))
    ))
;;Expansión de un nudo
(define crea-nudo
  (lambda (nudo)
    (cond
      ((es-resultado? nudo)
       (terminal! nudo #t)
       (hash-set! hanoi (nodo-id nudo) nudo))
      ((es-terminal? nudo)
       (terminal! nudo #t)
       (hash-set! hanoi (nodo-id nudo) nudo))
      (else
       (terminal! nudo #f)
       (hash-set! hanoi (nodo-id nudo) nudo))
      ) ))
(define expande-nodo
  (lambda (nudo)
;    (pnodo "" nudo)
    (let*
        ((id-nudo (nodo-id nudo))
         (estado (nodo-estado nudo))
         (camino (nodo-camino nudo))
         (nivel (nodo-nivel nudo))
         (terminal (nodo-terminal nudo))
         )
      (if terminal
          (void)
          (let*
              ((procs-aplic (operaciones-aplicables estado))
               (expansion
                (filter-map
                 (lambda (proc)
                   (restriccion estado proc))
                 procs-aplic) )
               )
;            (read-line)
;            (printf "~a ~n" expansion)
            (let go ((expanda expansion)
                     (sucesores '())
                     )
              (if (null? expanda)
                  sucesores
                  (if (first expanda)
                      (let* ((n-id (hash-count hanoi))
                             (n-estado (first expanda))
                             (n-camino (cons n-id camino))
                             (n-nivel (add1 nivel))
                             (n-terminal #f)
                             (n-nudo
                              (make-nodo
                               n-id
                               n-estado
                               n-camino
                               n-nivel
                               n-terminal))
                             )
                        (crea-nudo n-nudo)
                        (go (rest expanda) (cons n-nudo sucesores))
                        )
                      (go (rest expanda) sucesores)
                      )
                  )
              )
            )
          )
      )
    ))
;;
(define terminal!
  (lambda (nudo booleano)
    (set-nodo-terminal! nudo booleano) ))
(define es-terminal?
  (lambda (nudo)
    (let ((estado (nodo-estado nudo))
          (camino (rest (nodo-camino nudo)))
          )
      (let go ((path camino))
        (if (null? path)
            #f
            (if (igual-estado? 
                 estado 
                 (nodo-estado (hash-ref hanoi (first path))))
                #t
                (go (rest path))
                )
            )
        )
      ) ))
(define igual-estado?
  (lambda (e1 e2)
    (cond
      ((null? e1) #t)
      ((equal? (first e1) (first e2))
       (igual-estado? (rest e1) (rest e2)) )
      (else #f)
      )
    ))
;;;Importante aunque no se usa
(define igual-esquema-estado?
  (lambda (e1 e2)
    (cond
      ((null? e1) #t)
      ((member (first e1) e2)
       (igual-esquema-estado? (rest e1) (remove (first e1) e2)) )
      (else #f)
      )
    ))
;;Expansión de un nivel
(define expande-nivel
  (lambda (lst-nodos)
    (for-each
     (lambda (nudo)
;       (pnodo "" nudo)
;       (read-line)
       (unless (nodo-terminal nudo)
         (expande-nodo nudo)))
     lst-nodos)))
;;Construcción del árbol
;;La lista de nudos en un nivel dado
(define nivel-num
  (lambda (arbol)
    (let* ((last (sub1 (hash-count arbol)))
           (nudo (hash-ref arbol last))
           )
      (nodo-nivel nudo))))
(define nivel-lst-nodos
  (lambda (arbol)
    (let ((nivel (nivel-num arbol)) )
      (let go ((last (sub1 (hash-count arbol)))
               (lst-nudos '())
               )
        (if (and 
             (>= last 0) 
             (= (nodo-nivel (hash-ref arbol last)) nivel))
            (go (sub1 last)
                (cons (hash-ref arbol last) lst-nudos))
            lst-nudos
            ) )) ))
;;predicados para dar por acabado el árbol
(define-syntax terminal?
  (syntax-rules ()
    ((terminal? nudo)
     (nodo-terminal nudo)) ))
(define-syntax all-terminal?
  (syntax-rules ()
    ((all-terminal? lst)
     (andmap
      (lambda (x)
        (terminal? x))
      lst)) ))
;;
(define construye-arbol
  (lambda (arbol)
    (let go ((lst-nudos (nivel-lst-nodos arbol)) )
      (if (all-terminal? lst-nudos)
          (printf "Hecho. Nº nudos: ~a~n" (hash-count arbol))
          (begin
            (expande-nivel lst-nudos)
            (go
             (nivel-lst-nodos arbol))) )) ))
;;Soluciones y solución óptima
(define soluciones
  (lambda (arbol)
    (let go ((i 0)
             (j (hash-count arbol))
             (lst '())
             )
      (if (= i j)
          (reverse lst)
          (if (es-resultado? (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 proc)
            (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)
                  proc
                  ))
                ((proc num-path-cadr num-path-opt)
                 (aux 
                  (first restantes) 
                  (cdr restantes) 
                  (list (first restantes))
                  proc
                  ))
                (else
                 (aux opt (cdr restantes) respuesta proc))
                )
              ) ))
         )
      (values
      (aux optima resto (list optima) <)
      (aux optima resto (list optima) >) )
      ) ))
(define prama
  (lambda (path)
    (if (null? path)
        (newline)
        (begin
          (pnodo "" (hash-ref hanoi (first path)))
          (prama (rest path)))
        ) ))
;;;;;;;;;;;;;
(construye-arbol hanoi)

(define Soluciones (soluciones hanoi))
(printf "~nSOLUCIONES Nº: ~a~n" (length Soluciones))
(let-values ([(Optima Peor) (solucion-optima Soluciones)])
;(define Optima (solucion-optima Soluciones))
(printf "~nSOLUCIÓN ÓPTIMA:~a movimientos~n" (sub1(length (nodo-camino (first Optima)))))
(prama (reverse(nodo-camino (first Optima))))
(printf "~nSOLUCION PEOR: ~a movimientos~n" (sub1(length (nodo-camino (first Peor)))))
(prama (reverse (nodo-camino (first Peor))))
)