#lang scheme

;;Estructuras de datos
(define-struct nodo
  (;fields
   id 
   estado
   camino
   nivel
   terminal
   )
  #:transparent)
;;
(define misioneros-canibales (make-hash))
(hash-set! misioneros-canibales 
           0 
           (make-nodo 
            0 
            (cons '(B C C C M M M) '()) 
            (list (cons '(B C C C M M M) '())) 
            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 sentido-mov
  (lambda (estado)
    (if (member 'B (car estado))
        (begin
          
          (values car cdr)
          )
        (if (member 'B (cdr estado))
            (begin
              
              (values cdr car)
              )
            'no-sé)) ))
(define ->1M
  (lambda (estado opart olleg)
    (let* ((o-partida (opart estado))
           (o-llegada (olleg estado))
           )
      (if (equal? opart car)
          (cons
           (remove 'B (remove 'M o-partida))
           (cons 'B (cons 'M o-llegada)))
          (cons
           (cons 'B (cons 'M o-llegada))
           (remove 'B (remove 'M o-partida))
           )
          )
      ) ))
(define ->1C
  (lambda (estado opart olleg)
    (let* ((o-partida (opart estado))
           (o-llegada (olleg estado))
           )
      (if (equal? opart car)
          (cons
           (remove 'B (remove 'C o-partida))
           (cons 'B (cons 'C o-llegada)))
          (cons
           (cons 'B (cons 'C o-llegada))
           (remove 'B (remove 'C o-partida))
           )
          )
      ) ))
(define ->MM
  (lambda (estado opart olleg)
    (let* ((o-partida (opart estado))
           (o-llegada (olleg estado))
           )
      (if (equal? opart car)
          (cons
           (remove 'B (remove 'M (remove 'M o-partida)))
           (cons 'B (cons 'M (cons 'M o-llegada))))
          (cons
           (cons 'B (cons 'M (cons 'M o-llegada)))
           (remove 'B (remove 'M (remove 'M o-partida)))
           )
          )
      ) ))
(define ->CC
  (lambda (estado opart olleg)
    (let* ((o-partida (opart estado))
           (o-llegada (olleg estado))
           )
      (if (equal? opart car)
          (cons
           (remove 'B (remove 'C (remove 'C o-partida)))
           (cons 'B (cons 'C (cons 'C o-llegada))))
          (cons
           (cons 'B (cons 'C (cons 'C o-llegada)))
           (remove 'B (remove 'C (remove 'C o-partida)))
           )
          )
      ) ))
(define ->MC
  (lambda (estado opart olleg)
    (let* ((o-partida (opart estado))
           (o-llegada (olleg estado))
           )
      (if (equal? opart car)
          (cons
           (remove 'B (remove 'M (remove 'C o-partida)))
           (cons 'B (cons 'M (cons 'C o-llegada))))
          (cons
           (cons 'B (cons 'M (cons 'C o-llegada)))
           (remove 'B (remove 'M (remove 'C o-partida)))
           )
          )
      ) ))
;;Predicados sobre operaciones
(define mov-1M?
  (lambda (estado opart olleg)
    (let ((o-partida (opart estado))
          (o-llegada (olleg estado))
          )
      (member 'M o-partida) )))
(define mov-1C?
  (lambda (estado opart olleg)
    (let ((o-partida (opart estado))
          (o-llegada (olleg estado))
          )
      (member 'C o-partida) )))
(define mov-MM?
  (lambda (estado opart olleg)
    (let ((o-partida (opart estado))
          (o-llegada (olleg estado))
          )
      (if (member 'M o-partida)
          (if (member 'M (remove 'M o-partida))
              #t
              #f
            )
          #f)
       )))
(define mov-CC?
  (lambda (estado opart olleg)
    (let ((o-partida (opart estado))
          (o-llegada (olleg estado))
          )
      (if (member 'C o-partida)
          (if (member 'C (remove 'C o-partida))
              #t
              #f
            )
          #f)
       )))
(define mov-MC?
  (lambda (estado opart olleg)
    (let ((o-partida (opart estado))
          (o-llegada (olleg estado))
          )
      (if (member 'M o-partida)
          (if (member 'C (remove 'M o-partida))
              #t
              #f
            )
          #f)
       )))
;;Se aplican todas las operaciones que satisfacen condiciones
(define aplica-operaciones
  (lambda (estado)
    (let-values 
        ([(o-part o-lleg) (sentido-mov estado)]
         [(resultado) '()]
         )
      (when (mov-1M? estado o-part o-lleg)
;        (printf "1M~n")
        (set! resultado 
              (append resultado 
                      (list (->1M estado o-part o-lleg)))))
      (when (mov-1C? estado o-part o-lleg)
;        (printf "1C~n")
        (set! resultado 
              (append resultado 
                      (list (->1C estado o-part o-lleg)))))
      (when (mov-MM? estado o-part o-lleg)
;        (printf "MM~n")
        (set! resultado 
              (append resultado 
                      (list (->MM estado o-part o-lleg)))))
      (when (mov-CC? estado o-part o-lleg)
;        (printf "CC~n")
        (set! resultado 
              (append resultado 
                      (list (->CC estado o-part o-lleg)))))
      (when (mov-MC? estado o-part o-lleg)
;        (printf "MC~n")
        (set! resultado 
              (append resultado 
                      (list (->MC estado o-part o-lleg)))))
      resultado )))
;;Condiciones o restricciones del problema
;;Restricciones
(define existe-en-path?
  (lambda (estado path)
    (if (null? path)
        #f
        (let* ((state (first path))
               )
          (if (equal? estado state)
              #t
              (existe-en-path? estado (rest path))
              ))
        ) ))
(define es-solucion?
  (lambda (new-estado)
    (letrec
        ((aux
          (lambda (cdr-estado solucion)
            (if (null? solucion)
                (if (null? cdr-estado)
                    #t
                    #f)
                (if (member (first cdr-estado) solucion)
                    (aux (rest cdr-estado) (remove (first cdr-estado) solucion))
                    #f)) ))
         )
      (and
       (null? (car new-estado))
       (aux (cdr new-estado) '(B C C C M M M)))
    ) ))
;;específica: nº caníbales > nº misioneros
(define canibales>misioneros?
  (lambda (new-estado)
    (define cuantos-hay
      (lambda (lista simbolo)
        (if (null? lista)
            0
            (if (eq? (first lista) simbolo)
                (+ 1
                   (cuantos-hay (rest lista) simbolo))
                (+ 0 
                   (cuantos-hay (rest lista) simbolo)))) ))
    (let ((M-o-izqda (cuantos-hay (car new-estado) 'M))
          (C-o-izqda (cuantos-hay (car new-estado) 'C))
          (M-o-dcha (cuantos-hay (cdr new-estado) 'M))
          (C-o-dcha (cuantos-hay (cdr new-estado) 'C))
          )
      (or 
       (and (not (zero? M-o-izqda)) (> C-o-izqda M-o-izqda))
       (and (not (zero? M-o-dcha)) (> C-o-dcha M-o-dcha)))
      ) ))
;;;
(define crea-expansion+restricciones
  (lambda (expansion id camino nivel)
    (for-each
     (lambda (estado)
       (let ((id-n id)
;             (estado estado)
             (path (cons estado camino))
             (level (add1 nivel))
             )
         (cond
           ((existe-en-path? estado camino) 
;            (printf "nº nodo: ~a; nudo: ~a; terminal: redundante~n" id estado)
            (hash-set! misioneros-canibales 
                       id-n 
                       (make-nodo id-n estado path level #t)) 
            (set! id (add1 id)))
           ((es-solucion? estado) 
;            (printf "nº nodo: ~a; nudo: ~a; terminal: solución~n" id estado)
            (hash-set! misioneros-canibales 
                       id-n 
                       (make-nodo id-n estado path level #t)) 
            (set! id (add1 id)))
           ((canibales>misioneros? estado)
;            (printf "no se anota un nuevo nudo porque hay más caníbales que misioneros: ~a~n" estado)
            (hash-set! misioneros-canibales 
                       id-n 
                       (make-nodo id-n estado path level #t)) 
            (set! id (add1 id))
            )
           (else
;            (printf "nº nodo: ~a; nudo: ~a; terminal: no~n" id estado)
            (hash-set! misioneros-canibales 
                       id-n 
                       (make-nodo id-n estado path level #f)) 
            (set! id (add1 id))) )
         ))
     expansion)
    ))
;;;;;Expansión de un nudo
;;para ordenación alfabética de símbolos
(define symbol<?
  (lambda (s1 s2)
    (string<? (symbol->string s1) (symbol->string s2)) ))
;;
(define expande-nodo
  (lambda (nudo)
    (let* ((id (hash-count misioneros-canibales))
           (estado (nodo-estado nudo))
           (camino (nodo-camino nudo))
           (nivel (nodo-nivel nudo))
           (terminal (nodo-terminal nudo))
           )
;      (pnodo "expande-nodo" nudo)
      (if terminal
          (void)
          (let* ((expan (aplica-operaciones estado))
                 (expansion 
                  (map
                   (lambda (estado)
                     (cons
                      (sort (car estado) symbol<?)
                      (sort (cdr estado) symbol<?)))
                   expan))
                 )
;            (printf "~a~n" expansion)
            (crea-expansion+restricciones expansion id camino nivel)
                ) )) ))
;;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 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-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 misioneros-canibales)
;(parbol misioneros-canibales)

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