;;;; Graph-Walking Algorithms

(define (depth-first-search node)
  (depth-first-walk node (loop-avoidance-node-filter)))

(define (depth-first-walk node link-filter)
  (let per-node ((node node) (k (lambda () #f)))
    (maybe-accumulate
     node
     (lambda ()
       (let per-link ((links (node-links node)))
	 (if (pair? links)
	     (let ((node
		    (dereference-link (car links)
				      link-filter)))
	       (if node
		   (per-node node
			     (lambda ()
			       (per-link (cdr links))))
		   (per-link (cdr links))))
	     (k)))))))


(define (maybe-accumulate node get-next)
  (if *debug-trace?*
      (begin
	(fresh-line)
	(write-string ";trace: ")
	(write (node-name node))
	(newline)))
  (if (node-value node)
      (cons node get-next)
      (get-next)))

(define *debug-trace?* #f)


(define (loop-avoidance-node-filter)
  (let ((table (make-eq-hash-table)))
    (lambda (node)
      (if (hash-table/get table node #f)
	  #f
	  (begin
	    (hash-table/put! table node #t)
	    node)))))

(define (breadth-first-search node)
  (breadth-first-walk node (loop-avoidance-node-filter)))

(define (breadth-first-walk node link-filter)
  (define (per-node node pending k)
    (maybe-accumulate
     node
     (lambda ()
       (let per-link ((links (node-links node))
		      (pending pending))
	 (if (pair? links)
	     (per-link (cdr links)
		       (let ((node
			      (dereference-link (car links)
						link-filter)))
			 (if node
			     (cons node pending)
			     pending)))
	     (k pending))))))
  (define (step pending)
    (if (pair? pending)
	(let loop ((nodes pending) (pending '()))
	  (if (pair? nodes)
	      (per-node (car nodes)
			pending
			(lambda (pending)
			  (loop (cdr nodes) pending)))
	      (step pending)))
	#f))
  (per-node node '() step))

(define (best-first-search node)
  (best-first-walk node (loop-avoidance-node-filter)))

(define (best-first-walk node link-filter)
  (let ((pq (make-priority-queue)))
    (define (per-node node)
      (for-each (lambda (link)
		  (add-to-queue link
				(link-priority link)
				pq))
		(node-links node))
      (maybe-accumulate node next-node))
    (define (next-node)
      (let ((link (remove-from-queue pq)))
	(if link
	    (let ((node
		   (dereference-link link link-filter)))
	      (if node
		  (per-node node)
		  (next-node)))
	    #f)))
    (per-node node)))

;;;; Supporting data structures

(define (make-priority-queue)
  (list 'queue))

(define (add-to-queue elt priority pq)
  (set-cdr! pq
	    (let loop ((ps (cdr pq)))
	      (if (pair? ps)
		  (if (> priority (caar ps))
		      (cons (cons priority elt) ps)
		      (cons (car ps) (loop (cdr ps))))
		  (list (cons priority elt))))))

(define (remove-from-queue pq)
  (let ((ps (cdr pq)))
    (and (pair? ps)
	 (begin
	   (set-cdr! pq (cdr ps))
	   (cdar ps)))))

(define (make-node name value . links)
  (cons* 'node name value links))

(define (node-name node)
  (cadr node))

(define (node-value node)
  (caddr node))

(define (node-links node)
  (cdddr node))

(define (make-link thunk #!optional priority)
  (list 'link (if (default-object? priority) 0 priority) thunk))

(define (dereference-link link link-filter)
  (let ((node ((caddr link))))
    (if node
	(link-filter node)
	#f)))

(define (link-priority link)
  (cadr link))

(define (search-values->list values)
  (if (pair? values)
      (cons (car values) (search-values->list ((cdr values))))
      '()))