#lang scheme

;;Estructuras de datos
(define-struct nodo
  (;field
   id 
   estado
   camino
   nivel
   (terminal #:mutable)
   )
  #:transparent)

(define arbol-viajante (make-hash))
(hash-set! arbol-viajante 0 (make-nodo 0 'A (list 'A) 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))) )))
;;;;;Operaciones posibles
;;sucesores posibles
(define sucesores-posibles
  (lambda (ciudad)
    (let ((ciudades (list 'B 'C 'D 'E 'F 'A)))
      (remove ciudad ciudades)
      ) ))
;;aplicar restricción
(define se-aplica-restriccion?
  (lambda (ciudad nodo)
    (if (member ciudad (nodo-camino nodo))
        #t
        #f)))
;;;;;Expansión de un nudo
(define terminal!
  (lambda (nudo booleano)
    (set-nodo-terminal! nudo booleano) ))
;;
(define expande-nodo
  (lambda (nudo)
    (let* ((id (hash-count arbol-viajante))
           (estado (nodo-estado nudo))
           (camino (nodo-camino nudo))
           (nivel (nodo-nivel nudo))
           (terminal (nodo-terminal nudo))
           )
      (if terminal
          (void)
          (let ((suc-posibles (sucesores-posibles estado))
                )
            (crea-expansion+restriccion suc-posibles nudo)
                ) )) ))
;;incluye la restricción de ciudad no repetida
(define crea-expansion+restriccion
  (lambda (sucesores nudo)
    (let go ((new-id (hash-count arbol-viajante))
             (suc-posibles sucesores)
             (path (nodo-camino nudo))
             (level (add1 (nodo-nivel nudo)))
             )
      (if (null? suc-posibles)
          (void)
          (let* ((new-nodo-id new-id)
                 (new-nodo-cont (car suc-posibles))
                 (new-nodo-path (cons new-nodo-cont path))
                 (new-nodo-nivel level)
                 (new-nodo-terminal #f)
                 (new-nodo
                  (make-nodo 
                   new-nodo-id 
                   new-nodo-cont 
                   new-nodo-path 
                   new-nodo-nivel 
                   new-nodo-terminal))
                 )
            (cond
              ((se-aplica-restriccion? new-nodo-cont nudo)
               (terminal! new-nodo #t) 
               (hash-set! arbol-viajante new-id new-nodo)
               )
;              ((es-terminal? new-nodo-cont nudo)
;               (terminal! new-nodo #t) 
;               (hash-set! arbol-viajante new-id new-nodo)
;               )
              (else
               (hash-set! arbol-viajante new-id new-nodo)
               )
              )
            (go (add1 new-id) (cdr suc-posibles) path level)
            ) 
          )
    ) ))
;;Expansión de un nivel
(define expande-nivel
  (lambda (lst-nodos)
    (for-each
     (lambda (nudo)
       (unless (nodo-terminal nudo)
         (expande-nodo nudo)))
     lst-nodos)))
;; Construcción del árbol
;;la lista de nudos en un nivel dado
(define num-nivel
  (lambda (arbol)
    (let* ((last (sub1 (hash-count arbol-viajante)))
           (nudo (hash-ref arbol-viajante last))
           )
      (nodo-nivel nudo))))
(define lista-nudos-en-nivel
  (lambda (arbol)
    (let ((nivel (num-nivel 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)) ))
;;Construcción
(define construye-arbol
  (lambda (arbol)
    (let go ((lst-nudos (lista-nudos-en-nivel arbol)) )
      (if (all-terminal? lst-nudos)
          (printf "Hecho. Nº nudos: ~a~n" (hash-count arbol))
          (begin
            (expande-nivel lst-nudos)
            (go
             (lista-nudos-en-nivel arbol))) )) ))
;;Matriz de distancias entre ciudades:
(define distancias (make-hash))
(hash-set! distancias 'A (list (cons 'A 0) (cons 'B 13) (cons 'C 33) (cons 'D 69) (cons 'E 44) (cons 'F 68)))
(hash-set! distancias 'B (list (cons 'A 13) (cons 'B 0) (cons 'C 85) (cons 'D 22) (cons 'E 60) (cons 'F 52)))
(hash-set! distancias 'C (list (cons 'A 33) (cons 'B 85) (cons 'C 0) (cons 'D 9) (cons 'E 26) (cons 'F 43)))
(hash-set! distancias 'D (list (cons 'A 69) (cons 'B 22) (cons 'C 9) (cons 'D 0) (cons 'E 45) (cons 'F 82)))
(hash-set! distancias 'E (list (cons 'A 44) (cons 'B 60) (cons 'C 26) (cons 'D 45) (cons 'E 0) (cons 'F 83)))
(hash-set! distancias 'F (list (cons 'A 68) (cons 'B 52) (cons 'C 43) (cons 'D 82) (cons 'E 83) (cons 'F 0)))
;;Distancia entre dos ciudades:
(define distancia-entre
  (lambda (X Y)
    (let* ((fila (hash-ref distancias X))
           (columna (assoc Y fila))
           )
      (cdr columna)) ))
;;Kilómetros recorridos
(define distancia-recorrida
  (lambda (path)
    (if (null? (cdr path))
        0
        (+
         (distancia-entre (car path) (cadr path))
         (distancia-recorrida (cdr path)))
        ) ))
;;Soluciones y solución óptima
(define ultimo-nivel
  (lambda (arbol)
    (let* ((last (sub1 (hash-count arbol)))
           (nivel (nodo-nivel (hash-ref arbol last)))
           )
      (let go ((i last)
               )
        (if (= (nodo-nivel (hash-ref arbol i)) nivel)
            (cons
             (hash-ref arbol i)
             (go (sub1 i)))
            '())
        ) )
    ))
(define soluciones
  (lambda (last-nivel)
    (if (null? last-nivel)
        '()
        (if (eq? (nodo-estado (car last-nivel)) 'A)
            (cons
             (car last-nivel)
             (soluciones (cdr last-nivel)))
            (soluciones (cdr last-nivel))
            ))
    ))
(define solucion-optima
  (lambda (soluciones)
    (letrec 
        ((optima (first soluciones))
         (resto (rest soluciones))
         (aux
          (lambda (opt restantes respuesta)
            (let ((km-opt (distancia-recorrida (nodo-camino opt)))
                  (km-cadr 
                   (if (null? restantes)
                       (void)
                       (distancia-recorrida 
                        (nodo-camino (first restantes)))))
                  )
              (cond
                ((null? restantes) respuesta)
                ((= km-cadr km-opt)
                 (aux 
                  opt 
                  (cdr restantes) 
                  (cons (cons (first restantes) km-cadr) respuesta)))
                ((< km-cadr km-opt)
                 (aux 
                  (first restantes) 
                  (cdr restantes) 
                  (list (cons (first restantes) km-cadr))))
                (else
                 (aux opt (cdr restantes) respuesta))
                )
              ) ))
         )
      (aux optima resto (list optima))
      ) ))
;;;;;;;;;;;;;
(construye-arbol arbol-viajante)

(define Soluciones 
  (soluciones (ultimo-nivel arbol-viajante)))
(printf "~nSOLUCIONES: ~a~n" (length Soluciones))
(printf "~nSOLUCIÓN ÓPTIMA:~n")
(solucion-optima Soluciones)
