(define graphs:assert
 (lambda (test . info)
  #f))

;;; Fold over list elements, associating to the left.
(define fold
 (lambda (lst folder state)
  (graphs:assert (list? lst) lst)
  (graphs:assert (procedure? folder) folder)
  (do ((lst lst (cdr lst))
       (state state (folder (car lst) state)))
    ((null? lst) state))))

;;; Given the size of a vector and a procedure which
;;; sends indicies to desired vector elements, create
;;; and return the vector.
(define proc->vector
 (lambda (size f)
  (graphs:assert (and (integer? size) (exact? size) (>= size 0)) size)
  (graphs:assert (procedure? f) f)
  (if (zero? size)
      (vector)
      (let ((x (make-vector size (f 0))))
       (let loop ((i 1))
	(if (< i size)
	    (begin (vector-set! x i (f i))
		   (loop (+ i 1)))))
       x))))

(define vector-fold
 (lambda (vec folder state)
  (graphs:assert (vector? vec) vec)
  (graphs:assert (procedure? folder) folder)
  (let ((len (vector-length vec)))
   (do ((i 0 (+ i 1))
	(state state (folder (vector-ref vec i) state)))
     ((= i len) state)))))

(define vector-map
 (lambda (vec proc)
  (proc->vector (vector-length vec)
		(lambda (i) (proc (vector-ref vec i))))))

;;; Given limit, return the list 0, 1, ..., limit-1.
(define giota
 (lambda (limit)
  (graphs:assert (and (integer? limit) (exact? limit) (>= limit 0)) limit)
  (let -*- ((limit limit)
	    (res '()))
   (if (zero? limit)
       res
       (let ((limit (- limit 1)))
	(-*- limit (cons limit res)))))))

;;; Fold over the integers [0, limit).
(define gnatural-fold
 (lambda (limit folder state)
  (graphs:assert (and (integer? limit) (exact? limit) (>= limit 0)) limit)
  (graphs:assert (procedure? folder) folder)
  (do ((i 0 (+ i 1))
       (state state (folder i state)))
    ((= i limit) state))))

;;; Iterate over the integers [0, limit).
(define gnatural-for-each
 (lambda (limit proc!)
  (graphs:assert (and (integer? limit) (exact? limit) (>= limit 0)) limit)
  (graphs:assert (procedure? proc!) proc!)
  (do ((i 0 (+ i 1))) ((= i limit)) (proc! i))))

(define natural-for-all?
 (lambda (limit ok?)
  (graphs:assert (and (integer? limit) (exact? limit) (>= limit 0)) limit)
  (graphs:assert (procedure? ok?) ok?)
  (let -*- ((i 0))
   (or (= i limit) (and (ok? i) (-*- (+ i 1)))))))

(define natural-there-exists?
 (lambda (limit ok?)
  (graphs:assert (and (integer? limit) (exact? limit) (>= limit 0)) limit)
  (graphs:assert (procedure? ok?) ok?)
  (let -*- ((i 0))
   (and (not (= i limit)) (or (ok? i) (-*- (+ i 1)))))))

(define there-exists?
 (lambda (lst ok?)
  (graphs:assert (list? lst) lst)
  (graphs:assert (procedure? ok?) ok?)
  (let -*- ((lst lst))
   (and (not (null? lst)) (or (ok? (car lst)) (-*- (cdr lst)))))))

;;; Fold over the tree of permutations of a universe.
;;; Each branch (from the root) is a permutation of universe.
;;; Each node at depth d corresponds to all permutations which pick the
;;; elements spelled out on the branch from the root to that node as
;;; the first d elements.
;;; Their are two components to the state:
;;;	The b-state is only a function of the branch from the root.
;;;	The t-state is a function of all nodes seen so far.
;;; At each node, b-folder is called via
;;;	(b-folder elem b-state t-state deeper accross)
;;; where elem is the next element of the universe picked.
;;; If b-folder can determine the result of the total tree fold at this stage,
;;; it should simply return the result.
;;; If b-folder can determine the result of folding over the sub-tree
;;; rooted at the resulting node, it should call accross via
;;;	(accross new-t-state)
;;; where new-t-state is that result.
;;; Otherwise, b-folder should call deeper via
;;;	(deeper new-b-state new-t-state)
;;; where new-b-state is the b-state for the new node and new-t-state is
;;; the new folded t-state.
;;; At the leaves of the tree, t-folder is called via
;;;	(t-folder b-state t-state accross)
;;; If t-folder can determine the result of the total tree fold at this stage,
;;; it should simply return that result.
;;; If not, it should call accross via
;;;	(accross new-t-state)
;;; Note, fold-over-perm-tree always calls b-folder in depth-first order.
;;; I.e., when b-folder is called at depth d, the branch leading to that
;;; node is the most recent calls to b-folder at all the depths less than d.
;;; This is a gross efficiency hack so that b-folder can use mutation to
;;; keep the current branch.
(define fold-over-perm-tree
 (lambda (universe b-folder b-state t-folder t-state)
  (graphs:assert (list? universe) universe)
  (graphs:assert (procedure? b-folder) b-folder)
  (graphs:assert (procedure? t-folder) t-folder)
  (let -*- ((universe universe)
	    (b-state b-state)
	    (t-state t-state)
	    (accross (lambda (final-t-state) final-t-state)))
   (if (null? universe)
       (t-folder b-state t-state accross)
       (let -**- ((in universe)
		  (out '())
		  (t-state t-state))
	(let* ((first (car in))
	       (rest (cdr in))
	       (accross	(if (null? rest)
			    accross
			    (lambda (new-t-state)
			     (-**- rest (cons first out) new-t-state)))))
	 (b-folder first
		   b-state
		   t-state
		   (lambda (new-b-state new-t-state)
		    (-*- (fold out cons rest)
			 new-b-state
			 new-t-state
			 accross))
		   accross)))))))

;;; A directed graph is stored as a connection matrix (vector-of-vectors)
;;; where the first index is the `from' vertex and the second is the `to'
;;; vertex.  Each entry is a bool indicating if the edge exists.
;;; The diagonal of the matrix is never examined.
;;; Make-minimal? returns a procedure which tests if a labelling
;;; of the verticies is such that the matrix is minimal.
;;; If it is, then the procedure returns the result of folding over
;;; the elements of the automoriphism group.  If not, it returns #f.
;;; The folding is done by calling folder via
;;;	(folder perm state accross)
;;; If the folder wants to continue, it should call accross via
;;;	(accross new-state)
;;; If it just wants the entire minimal? procedure to return something,
;;; it should return that.
;;; The ordering used is lexicographic (with #t > #f) and entries
;;; are examined in the following order:
;;;	1->0, 0->1
;;;
;;;	2->0, 0->2
;;;	2->1, 1->2
;;;
;;;	3->0, 0->3
;;;	3->1, 1->3
;;;	3->2, 2->3
;;;	...
(define make-minimal?
 (lambda (max-size)
  (graphs:assert (and (integer? max-size) (exact? max-size) (>= max-size 0))
		 max-size)
  (let ((iotas (proc->vector (+ max-size 1) giota))
	(perm (make-vector max-size 0)))
   (lambda (size graph folder state)
    (graphs:assert (and (integer? size) (exact? size) (<= 0 size max-size))
		   size
		   max-size)
    (graphs:assert (vector? graph) graph)
    (graphs:assert (procedure? folder) folder)
    (fold-over-perm-tree (vector-ref iotas size)
			 (lambda (perm-x x state deeper accross)
			  (case (cmp-next-vertex graph perm x perm-x)
			   ((less) #f)
			   ((equal)
			    (vector-set! perm x perm-x)
			    (deeper (+ x 1) state))
			   ((more) (accross state))
			   (else (graphs:assert #f))))
			 0
			 (lambda (leaf-depth state accross)
			  (graphs:assert (eqv? leaf-depth size)
					 leaf-depth
					 size)
			  (folder perm state accross))
			 state)))))

;;; Given a graph, a partial permutation vector, the next input and the next
;;; output, return 'less, 'equal or 'more depending on the lexicographic
;;; comparison between the permuted and un-permuted graph.
(define cmp-next-vertex
 (lambda (graph perm x perm-x)
  (let ((from-x (vector-ref graph x))
	(from-perm-x (vector-ref graph perm-x)))
   (let -*- ((y 0))
    (if (= x y)
	'equal
	(let ((x->y? (vector-ref from-x y))
	      (perm-y (vector-ref perm y)))
	 (cond ((eq? x->y? (vector-ref from-perm-x perm-y))
		(let ((y->x? (vector-ref (vector-ref graph y) x)))
		 (cond ((eq? y->x?
			     (vector-ref (vector-ref graph perm-y) perm-x))
			(-*- (+ y 1)))
		       (y->x? 'less)
		       (else 'more))))
	       (x->y? 'less)
	       (else 'more))))))))

;;; Fold over rooted directed graphs with bounded out-degree.
;;; Size is the number of verticies (including the root).  Max-out is the
;;; maximum out-degree for any vertex.  Folder is called via
;;;	(folder edges state)
;;; where edges is a list of length size.  The ith element of the list is
;;; a list of the verticies j for which there is an edge from i to j.
;;; The last vertex is the root.
(define fold-over-rdg
 (lambda (size max-out folder state)
  (graphs:assert (and (exact? size) (integer? size) (> size 0)) size)
  (graphs:assert (and (exact? max-out) (integer? max-out) (>= max-out 0))
		 max-out)
  (graphs:assert (procedure? folder) folder)
  (let* ((root (- size 1))
	 (edge? (proc->vector size (lambda (from) (make-vector size #f))))
	 (edges (make-vector size '()))
	 (out-degrees (make-vector size 0))
	 (minimal-folder (make-minimal? root))
	 (non-root-minimal?
	  (let ((cont (lambda (perm state accross)
		       (graphs:assert (eq? state #t) state)
		       (accross #t))))
	   (lambda (size)
	    (minimal-folder size edge? cont #t))))
	 (root-minimal?
	  (let ((cont (lambda (perm state accross)
		       (graphs:assert (eq? state #t) state)
		       (case (cmp-next-vertex edge? perm root root)
			((less) #f)
			((equal more) (accross #t))
			(else (graphs:assert #f))))))
	   (lambda ()
	    (minimal-folder root edge? cont #t)))))
   (let -*- ((vertex 0)
	     (state state))
    (cond ((not (non-root-minimal? vertex)) state)
	  ((= vertex root)
	   (graphs:assert
	    (begin
	     (gnatural-for-each
	      root
	      (lambda (v)
	       (graphs:assert (= (vector-ref out-degrees v)
				 (length (vector-ref edges v)))
			      v
			      (vector-ref out-degrees v)
			      (vector-ref edges v))))
	     #t))
	   (let ((reach? (make-reach? root edges))
		 (from-root (vector-ref edge? root)))
	    (let -*- ((v 0)
		      (outs 0)
		      (efr '())
		      (efrr '())
		      (state state))
	     (cond ((not (or (= v root) (= outs max-out)))
		    (vector-set! from-root v #t)
		    (let ((state (-*- (+ v 1)
				      (+ outs 1)
				      (cons v efr)
				      (cons (vector-ref reach? v) efrr)
				      state)))
		     (vector-set! from-root v #f)
		     (-*- (+ v 1) outs efr efrr state)))
		   ((and (natural-for-all?
			  root
			  (lambda (v)
			   (there-exists? efrr
					  (lambda (r) (vector-ref r v)))))
			 (root-minimal?))
		    (vector-set! edges root efr)
		    (folder
		     (proc->vector size (lambda (i) (vector-ref edges i)))
		     state))
		   (else state)))))
	  (else
	   (let ((from-vertex (vector-ref edge? vertex)))
	    (let -**- ((sv 0)
		       (outs 0)
		       (state state))
	     (if (= sv vertex)
		 (begin
		  (vector-set! out-degrees vertex outs)
		  (-*- (+ vertex 1) state))
		 (let* ((state
			 ;; no sv->vertex, no vertex->sv
			 (-**- (+ sv 1) outs state))
			(from-sv (vector-ref edge? sv))
			(sv-out (vector-ref out-degrees sv))
			(state
			 (if (= sv-out max-out)
			     state
			     (begin
			      (vector-set! edges
					   sv
					   (cons vertex (vector-ref edges sv)))
			      (vector-set! from-sv vertex #t)
			      (vector-set! out-degrees sv (+ sv-out 1))
			      (let* ((state
				      ;; sv->vertex, no vertex->sv
				      (-**- (+ sv 1) outs state))
				     (state
				      (if (= outs max-out)
					  state
					  (begin
					   (vector-set! from-vertex sv #t)
					   (vector-set!
					    edges
					    vertex
					    (cons sv
						  (vector-ref edges vertex)))
					   (let ((state
						  ;; sv->vertex, vertex->sv
						  (-**- (+ sv 1)
							(+ outs 1)
							state)))
					    (vector-set!
					     edges
					     vertex
					     (cdr (vector-ref edges vertex)))
					    (vector-set! from-vertex sv #f)
					    state)))))
			       (vector-set! out-degrees sv sv-out)
			       (vector-set! from-sv vertex #f)
			       (vector-set! edges
					    sv
					    (cdr (vector-ref edges sv)))
			       state)))))
		  (if (= outs max-out)
		      state
		      (begin
		       (vector-set! edges
				    vertex
				    (cons sv (vector-ref edges vertex)))
		       (vector-set! from-vertex sv #t)
		       (let ((state
			      ;; no sv->vertex, vertex->sv
			      (-**- (+ sv 1) (+ outs 1) state)))
			(vector-set! from-vertex sv #f)
			(vector-set! edges
				     vertex
				     (cdr (vector-ref edges vertex)))
			state)))))))))))))

;;; Given a vector which maps vertex to out-going-edge list,
;;; return a vector  which gives reachability.
(define make-reach?
 (lambda (size vertex->out)
  (let ((res (proc->vector size
			   (lambda (v)
			    (let ((from-v (make-vector size #f)))
			     (vector-set! from-v v #t)
			     (for-each (lambda (x) (vector-set! from-v x #t))
				       (vector-ref vertex->out v))
			     from-v)))))
   (gnatural-for-each
    size
    (lambda (m)
     (let ((from-m (vector-ref res m)))
      (gnatural-for-each
       size
       (lambda (f)
	(let ((from-f (vector-ref res f)))
	 (if (vector-ref from-f m)
	     (gnatural-for-each size
				(lambda (t)
				 (if (vector-ref from-m t)
				     (vector-set! from-f t #t)))))))))))
   res)))

;;; Produces all directed graphs with N verticies, distinguished root,
;;; and out-degree bounded by 2, upto isomorphism (there are 44).

(let ((n 7))
 (fold-over-rdg n 2 cons '()))