;;; GRAPHS -- Obtained from Andrew Wright. ;;; ==== util.ss ==== ; Fold over list elements, associating to the left. (define fold (lambda (lst folder state) ; (assert (list? lst) ; lst) ; (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) ; (assert (and (integer? size) ; (exact? size) ; (>= size 0)) ; size) ; (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) ; (assert (vector? vec) ; vec) ; (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) ; (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) ; (assert (and (integer? limit) ; (exact? limit) ; (>= limit 0)) ; limit) ; (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!) ; (assert (and (integer? limit) ; (exact? limit) ; (>= limit 0)) ; limit) ; (assert (procedure? proc!) ; proc!) (do ((i 0 (+ i 1))) ((= i limit)) (proc! i)))) (define natural-for-all? (lambda (limit ok?) ; (assert (and (integer? limit) ; (exact? limit) ; (>= limit 0)) ; limit) ; (assert (procedure? ok?) ; ok?) (let _-*- ((i 0)) (or (= i limit) (and (ok? i) (_-*- (+ i 1))))))) (define natural-there-exists? (lambda (limit ok?) ; (assert (and (integer? limit) ; (exact? limit) ; (>= limit 0)) ; limit) ; (assert (procedure? ok?) ; ok?) (let _-*- ((i 0)) (and (not (= i limit)) (or (ok? i) (_-*- (+ i 1))))))) (define there-exists? (lambda (lst ok?) ; (assert (list? lst) ; lst) ; (assert (procedure? ok?) ; ok?) (let _-*- ((lst lst)) (and (not (null? lst)) (or (ok? (car lst)) (_-*- (cdr lst))))))) ;;; ==== ptfold.ss ==== ; 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) ; (assert (list? universe) ; universe) ; (assert (procedure? b-folder) ; b-folder) ; (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))))))) ;;; ==== minimal.ss ==== ; 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) ; (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) ; (assert (and (integer? size) ; (exact? size) ; (<= 0 size max-size)) ; size ; max-size) ; (assert (vector? graph) ; graph) ; (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 ; (assert #f) (fatal-error "???")))) 0 (lambda (leaf-depth state accross) ; (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)))))))) ;;; ==== rdg.ss ==== ; 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) ; (assert (and (exact? size) ; (integer? size) ; (> size 0)) ; size) ; (assert (and (exact? max-out) ; (integer? max-out) ; (>= max-out 0)) ; max-out) ; (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) ; (assert (eq? state #t) ; state) (accross #t)))) (lambda (size) (minimal-folder size edge? cont #t)))) (root-minimal? (let ((cont (lambda (perm state accross) ; (assert (eq? state #t) ; state) (case (cmp-next-vertex edge? perm root root) ((less) #f) ((equal more) (accross #t)) (else ; (assert #f) (fatal-error "???")))))) (lambda () (minimal-folder root edge? cont #t))))) (let _-*- ((vertex 0) (state state)) (cond ((not (non-root-minimal? vertex)) state) ((= vertex root) ; (assert ; (begin ; (gnatural-for-each root ; (lambda (v) ; (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))) ;;; ==== test input ==== ; Produces all directed graphs with N verticies, distinguished root, ; and out-degree bounded by 2, upto isomorphism. (define (run n) (fold-over-rdg n 2 cons '())) (define (main) (run-benchmark "graphs" graphs-iters (lambda (result) (equal? (length result) 596)) (lambda (n) (lambda () (run n))) 5))