;;; tremaux.scm
;;;
;;; Robert R. Snapp (C) 2006
;;; snapp@cs.uvm.edu
;;;
;;; Functions in this file apply tremaux's algorithm to the hampton court maze. We assume that the entrance node is 'a and the goal
;;; node is 'o in the graph defined below.
;;;
;;; Syntax:  (tremaux 'a 'o *hampton-court*)
;;;
;;;

;;; A graph consists of a list of lists. Each sublist contains a vertex label, followed by a list
;;; of edges, each edge represtented by the vertex of the destination.

;;; *maze* is the graph of a maze. For example:
(define *hampton-court* 
  '((a (b)) (b (a c d)) (c (b)) 
    (d (b e f)) (e (d)) (f (d g h))
    (g (f)) (h (f i j)) (i (h j l)) 
    (j (h i k)) (k (j)) (l (i m n)) 
    (m (l)) (n (l o p)) (o (n)) (p (n))))



;; Get neighbors returns the list of vertices that are adjacent to the indicated vertex.
(define get-neighbors
  (lambda (v graph)
    (cond ((null? graph) '())
          ((eq? v (caar graph)) (cadar graph))
          (else (get-neighbors v (cdr graph))))))


;; new-node? returns #t if the indicated node has not yet been visited, i.e., there is no reference to it in labels,
;; a list of association pairs in the form ( ((a. b) . lab) ... ), where (a . b) denotes the path that eminates from node a
;; towards node b, and lab indicates the label that appears at the end of this path adjacent to node a.
(define new-node?
  (lambda (node labels)
    (cond ((null? labels) #t)
          ((eq? node (caaar labels)) #f)
          (else (new-node? node (cdr labels))))))



;; get-new-path returns a dotted pair in the form (a . b) that represents the path from a, the indicated node, to node b, along
;; a path that has not yet be used in the search. If no such path exists, then get-new-path returns #f.
(define get-new-path
  (lambda (node neighbors labels)
    (cond ((null? neighbors) #f)
          (else (let ((candidate-path (cons node (car neighbors))))
                  (cond ((not (assoc candidate-path labels)) candidate-path)
                        (else (get-new-path node (cdr neighbors) labels))))))))

;; get-exit-path returns the path at the indicated old node that is labeled with an 'X. A dotted pair of the form (a . b)
;; is returned, where a is the indicated node, and b indicates the destination of the path.

(define get-exit-path
  (lambda (node neighbors labels)
    (cond ((null? neighbors) #f)
          (else (let ((path (cons node (car neighbors))))
                  (cond ((equal? (cdr (assoc path labels)) 'X) path)
                        (else (get-exit-path node (cdr neighbors) labels))))))))
   
   
;; insert-X inserts a new X-label for the indicated path-end into the front of the indicated a-list labels.
(define insert-X
  (lambda (path-end labels) ; path-end should be a pair of the form (p . q)
    (cons (cons path-end 'X) labels)))

;; insert-N inserts a new N-label for the indicated path-end into the front of the indicated a-list labels.
(define insert-N
  (lambda (path-end labels) ; path-end should be a pair of the form (p . q)
    (cons (cons path-end 'N) labels)))

;; tremaux implements tremaux's algorithm for the indicated graph. The first argument, start, indicates the label of the starting node;
;; the second, goal, indicates that of the goal node. The third argument, graph, indicates the graph of the maze that should contain
;; start and goal as nodes. (Note that the algorithm assumes that no more than one passage exists between any pair of nodes, and that 
;; no passage loops back to its original junction. How can these defecs be fixed?) 

(define tremaux 
  (lambda (start goal graph)
    (letrec ((start? (lambda (node) (eq? node start)))
             (goal? (lambda (node) (eq? node goal)))
             (dead-end? (lambda (node neighbors) (and (not (start? node)) (not (goal? node)) (= (length neighbors) 1))))
             (forward (lambda (history labels)
                        (let* ((node (car history))
                               (neighbors (get-neighbors node graph))
                               (prior-node (or (start? node) (cadr history)))
                               (return-path (cons node prior-node)))
                          (cond ((goal? node) (tremaux-output start goal graph history (insert-X return-path labels))) 
                                ((dead-end? node neighbors) (backward (cons prior-node history) labels))
                                ((new-node? node labels)
                                 (let* ((new-labels (if (start? node)
                                                        labels
                                                        (insert-X return-path labels)))
                                        (next-path (get-new-path node neighbors new-labels)))
                                   (forward (cons (cdr next-path) history) (insert-N next-path new-labels))))
                                (else (backward (cons (cadr history) history) (insert-N return-path labels)))))))
             (backward (lambda (history labels)
                         (let* ((node (car history))
                                (neighbors (get-neighbors node graph)))
                           (cond ((start? node) (display "Search Failed") (newline) #f)
                                 (else (let ((next-path (get-new-path node neighbors labels)))
                                         (cond (next-path (forward  (cons (cdr next-path) history) (insert-N next-path labels)))
                                               (else (let ((next-path (get-exit-path node neighbors labels)))
                                                       (backward (cons (cdr next-path) history) labels)))))))))))
      (forward (list start) '()))))
                               
;; tremaux-output is invoked after the goal is reached. The value it returns is ultimately returned by tremaux, but it also displays
;; the list of labels drawn, and can be easily modified as needed.
(define tremaux-output
  (lambda (start goal graph history labels)
    (letrec ((start? (lambda (node) (eq? node start)))
             (escape (lambda (e-history labels)
                       (let* ((node (car e-history))
                              (neighbors (get-neighbors node graph))
                              (next-path (get-exit-path node neighbors labels)))
                         (cond ((start? node) e-history)
                               (else (escape (cons (cdr next-path) e-history) labels)))))))
      (display (reverse labels))
      (newline)
      (list (escape (list goal) labels)
            (reverse history)))))