;;; GRAPHS -- Obtained from Andrew Wright.
(library (r6rs-benchmarks graphs)
(export main)
(import (r6rs) (r6rs-benchmarks))
;;; ==== 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)))))
; AZIZ: r6rs has vector-map, this is not even used
;(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)))