604 lines
25 KiB
Scheme
604 lines
25 KiB
Scheme
;;; 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))
|