;;; 1.

;;; the trick, as always, is to do the simplest possible terminal cases

(define lookup-code
  (lambda (target sexpr dummy)
    (if (eq? target sexpr)
	dummy
	(and (pair? sexpr)
	     (or (lookup-code target (car sexpr) (list 'car dummy))
		 (lookup-code target (cdr sexpr) (list 'cdr dummy)))))))

;;; 2.

;;; This is an abstraction of repeat-to-fixedpoint which takes an
;;; equality operator, so you can generate custom versions with
;;; different termination criteria.

(define repeat-to-fixedpoint-equality
  (lambda (e?)
    (define repeat-to-fixedpoint
      (lambda (f i)
	(let ((j (f i)))
	  (if (e? i j)
	      i
	      (repeat-to-fixedpoint f j)))))
    repeat-to-fixedpoint))

(define repeat-to-fixedpoint
  (repeat-to-fixedpoint-equality equal?))

;;; 3.

;;; Auxiliary functions for representing sets as lists of elements in
;;; arbitrary order.

;;; Note: this would in general be more efficient if the elements of
;;; sets were kept sorted, eg alphabetically.  And also if "skip
;;; lists" were used as the implementation datatype instead of regular
;;; lists.  Ie this representation of sets is reprehensibly slow!

;;; Convert a bag (a list with possibly repeated elements) into a set

(define bag-to-set
  (lambda (s)
    (cond ((null? s) s)
	  ((member (car s) (cdr s))
	   (bag-to-set (cdr s)))
	  (else (cons (car s)
		      (bag-to-set (cdr s)))))))

(define set-subset?
  (lambda (s1 s2)
    (or (null? s1)
	(and (member (car s1) s2)
	     (set-subset? (cdr s1) s2)))))

;;; efficiently test if two lists are the same length

(define length=
  (lambda (l1 l2)
    (if (null? l1)
	(null? l2)
	(and (not (null? l2))
	     (length= (cdr l1) (cdr l2))))))

;;; test for set equality.

(define set-equal?
  (lambda (s1 s2)
    (and (length= s1 s2)
	 (set-subset? s1 s2))))

(define set-remove-elt delete)

;;; Special version of repeat-to-fixedpoint which uses set equality
;;; for termination

(define set-repeat-to-fixedpoint
  (repeat-to-fixedpoint-equality set-equal?))

(define set-union
  (lambda (s1 s2)
    (bag-to-set (append s1 s2))))

(define set-intersection
  (lambda (s1 s2)
    (apply append
	   (map (lambda (elt)
		  (if (member elt s2)
		      (list elt)
		      '()))
		s1))))

;;; Auxiliary functions for dealing with graphs

;;; reverse direction of all edges

(define graph-reverse
  (lambda (g)
    (map reverse g)))

;;; takes a set of vertices, returns set of vertices reachable from the
;;; input set by traversing one edge.

(define graph-forward-link
  (lambda (g vertices)
    (bag-to-set
     (apply append
	    (map (lambda (vertex)
		   (apply append
			  (map (lambda (edge)
				 (if (eq? vertex (car edge))
				     (cdr edge)
				     '()))
			       g)))
		 vertices)))))

;;; set of vertices in a graph

(define graph-vertices
  (lambda (edges)
    (bag-to-set (apply append edges))))

;;; set of vertices in a cycle or reachable from a cycle.
;;; this is not particularly useful!

(define graph-from-cycles
  (lambda (g)
    (set-repeat-to-fixedpoint
     (lambda (vertices)
       (graph-forward-link g vertices))
     (graph-vertices g))))

;;; all vertices reachable by starting in a given input set of
;;; vertices and traversing edges.  ***Must traverse >= 1 edge.***

(define graph-vertices-reachable-from
  (lambda (g vertices)
    (set-repeat-to-fixedpoint
     (lambda (vertices)
       (set-union vertices
		  (graph-forward-link g vertices)))
     (graph-forward-link g vertices))))

;;; test if a vertex is in a cycle by testing if it can be reached by
;;; starting at the given vertex and traversing edges

(define graph-vertex-in-cycle
  (lambda (g n)
    (member n (graph-vertices-reachable-from g (list n)))))
	
;;; slightly less inefficient version.  This expands the set of
;;; vertices reachable by traversing at least one edge from the start
;;; vertex, but terminates if the start vertex shows up in the set, and
;;; not just when the set stops expanding.

(define graph-vertex-in-cycle2
  (lambda (g v-start)
    (let loop ((vertices (graph-forward-link g (list v-start))))
      (or (member v-start vertices)
	  (let ((next-vertices
		 (set-union vertices
			    (graph-forward-link g vertices))))
	    (and (not (length= vertices next-vertices))
		 (loop next-vertices)))))))

;;; return a list of all vertices in some cycle, ie all vertices that
;;; can be reached by starting at that vertex and traversing one or more
;;; edges.

(define cycles
  (lambda (g)
    (apply append
	   (map (lambda (vertex)
		  (if (graph-vertex-in-cycle2 g vertex)
		      (list vertex)
		      '()))
		(graph-vertices g)))))

;;; could use this as candidate vertices that might be in a cycle.  It
;;; is an overestimate, for example consider this graph.
;;; ((a a) (a b) (b c) (c c))

(define cycle-candidates
  (lambda (g)
    (set-intersection
     (graph-from-cycles g)
     (graph-from-cycles (graph-reverse g)))))

;;; 4.

(define associator
  (lambda (alist)
    (lambda (e)
      (cond ((assoc e alist) => cadr)
	    (else #f)))))

;;; 5.

;;; It is all so perfectly cool who could possibly choose?
;;; (COND (... (guard => function) ...) is nice