suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

restore graphs benchmark

Browse Source 
svn: r4110
This commit is contained in:
Matthew Flatt 2006-08-22 05:33:28 +00:00
parent 950c45c9ac
commit 6d48f2d7cc
2 changed files with 43 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/tests/mzscheme/benchmarks/common/auto.ss
View File

@ -202,6 +202,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
dynamic dynamic
earley earley
fft fft
graphs
nboyer nboyer
nestedloop nestedloop
nfa nfa

81
collects/tests/mzscheme/benchmarks/common/graphs.sch
View File

@ -8,14 +8,6 @@
; 389625 vectors with 2551590 elements ; 389625 vectors with 2551590 elements
; 56653504 closures (not counting top level and known procedures) ; 56653504 closures (not counting top level and known procedures)
(define (graphs-benchmark . rest)
(let ((N (if (null? rest) 7 (car rest))))
(time
(fold-over-rdg N
2
cons
'()))))
; End of new code. ; End of new code.
;;; ==== std.ss ==== ;;; ==== std.ss ====
@ -23,12 +15,12 @@
; (define-syntax assert ; (define-syntax assert
; (syntax-rules () ; (syntax-rules ()
; ((assert test info-rest ...) ; ((assert test info-rest ...)
; #F))) ; #f)))
; ;
; (define-syntax deny ; (define-syntax deny
; (syntax-rules () ; (syntax-rules ()
; ((deny test info-rest ...) ; ((deny test info-rest ...)
; #F))) ; #f)))
; ;
; (define-syntax when ; (define-syntax when
; (syntax-rules () ; (syntax-rules ()
@ -292,14 +284,14 @@
; Make-minimal? returns a procedure which tests if a labelling ; Make-minimal? returns a procedure which tests if a labelling
; of the verticies is such that the matrix is minimal. ; of the verticies is such that the matrix is minimal.
; If it is, then the procedure returns the result of folding over ; If it is, then the procedure returns the result of folding over
; the elements of the automoriphism group. If not, it returns #F. ; the elements of the automoriphism group. If not, it returns #f.
; The folding is done by calling folder via ; The folding is done by calling folder via
; (folder perm state accross) ; (folder perm state accross)
; If the folder wants to continue, it should call accross via ; If the folder wants to continue, it should call accross via
; (accross new-state) ; (accross new-state)
; If it just wants the entire minimal? procedure to return something, ; If it just wants the entire minimal? procedure to return something,
; it should return that. ; it should return that.
; The ordering used is lexicographic (with #T > #F) and entries ; The ordering used is lexicographic (with #t > #f) and entries
; are examined in the following order: ; are examined in the following order:
; 1->0, 0->1 ; 1->0, 0->1
; ;
@ -335,15 +327,16 @@
(lambda (perm-x x state deeper accross) (lambda (perm-x x state deeper accross)
(case (cmp-next-vertex graph perm x perm-x) (case (cmp-next-vertex graph perm x perm-x)
((less) ((less)
#F) #f)
((equal) ((equal)
(vector-set! perm x perm-x) (vector-set! perm x perm-x)
(deeper (+ x 1) (deeper (+ x 1)
state)) state))
((more) ((more)
(accross state)) (accross state))
(else ;(else
(assert #F)))) ; (assert #f))
))
0 0
(lambda (leaf-depth state accross) (lambda (leaf-depth state accross)
'(assert (eqv? leaf-depth size) '(assert (eqv? leaf-depth size)
@ -416,7 +409,7 @@
(edge? (edge?
(proc->vector size (proc->vector size
(lambda (from) (lambda (from)
(make-vector size #F)))) (make-vector size #f))))
(edges (edges
(make-vector size '())) (make-vector size '()))
(out-degrees (out-degrees
@ -426,31 +419,32 @@
(non-root-minimal? (non-root-minimal?
(let ((cont (let ((cont
(lambda (perm state accross) (lambda (perm state accross)
'(assert (eq? state #T) '(assert (eq? state #t)
state) state)
(accross #T)))) (accross #t))))
(lambda (size) (lambda (size)
(minimal-folder size (minimal-folder size
edge? edge?
cont cont
#T)))) #t))))
(root-minimal? (root-minimal?
(let ((cont (let ((cont
(lambda (perm state accross) (lambda (perm state accross)
'(assert (eq? state #T) '(assert (eq? state #t)
state) state)
(case (cmp-next-vertex edge? perm root root) (case (cmp-next-vertex edge? perm root root)
((less) ((less)
#F) #f)
((equal more) ((equal more)
(accross #T)) (accross #t))
(else ;(else
(assert #F)))))) ; (assert #f))
))))
(lambda () (lambda ()
(minimal-folder root (minimal-folder root
edge? edge?
cont cont
#T))))) #t)))))
(let -*- (let -*-
((vertex ((vertex
0) 0)
@ -468,7 +462,7 @@
v v
(vector-ref out-degrees v) (vector-ref out-degrees v)
(vector-ref edges v)))) (vector-ref edges v))))
#T)) #t))
(let ((reach? (let ((reach?
(make-reach? root edges)) (make-reach? root edges))
(from-root (from-root
@ -486,7 +480,7 @@
state)) state))
(cond ((not (or (= v root) (cond ((not (or (= v root)
(= outs max-out))) (= outs max-out)))
(vector-set! from-root v #T) (vector-set! from-root v #t)
(let ((state (let ((state
(-*- (+ v 1) (-*- (+ v 1)
(+ outs 1) (+ outs 1)
@ -494,7 +488,7 @@
(cons (vector-ref reach? v) (cons (vector-ref reach? v)
efrr) efrr)
state))) state)))
(vector-set! from-root v #F) (vector-set! from-root v #f)
(-*- (+ v 1) (-*- (+ v 1)
outs outs
efr efr
@ -546,7 +540,7 @@
sv sv
(cons vertex (cons vertex
(vector-ref edges sv))) (vector-ref edges sv)))
(vector-set! from-sv vertex #T) (vector-set! from-sv vertex #t)
(vector-set! out-degrees sv (+ sv-out 1)) (vector-set! out-degrees sv (+ sv-out 1))
(let* ((state (let* ((state
; sv->vertex, no vertex->sv ; sv->vertex, no vertex->sv
@ -557,7 +551,7 @@
(if (= outs max-out) (if (= outs max-out)
state state
(begin (begin
(vector-set! from-vertex sv #T) (vector-set! from-vertex sv #t)
(vector-set! edges (vector-set! edges
vertex vertex
(cons sv (cons sv
@ -570,10 +564,10 @@
(vector-set! edges (vector-set! edges
vertex vertex
(cdr (vector-ref edges vertex))) (cdr (vector-ref edges vertex)))
(vector-set! from-vertex sv #F) (vector-set! from-vertex sv #f)
state))))) state)))))
(vector-set! out-degrees sv sv-out) (vector-set! out-degrees sv sv-out)
(vector-set! from-sv vertex #F) (vector-set! from-sv vertex #f)
(vector-set! edges (vector-set! edges
sv sv
(cdr (vector-ref edges sv))) (cdr (vector-ref edges sv)))
@ -585,13 +579,13 @@
vertex vertex
(cons sv (cons sv
(vector-ref edges vertex))) (vector-ref edges vertex)))
(vector-set! from-vertex sv #T) (vector-set! from-vertex sv #t)
(let ((state (let ((state
; no sv->vertex, vertex->sv ; no sv->vertex, vertex->sv
(-**- (+ sv 1) (-**- (+ sv 1)
(+ outs 1) (+ outs 1)
state))) state)))
(vector-set! from-vertex sv #F) (vector-set! from-vertex sv #f)
(vector-set! edges (vector-set! edges
vertex vertex
(cdr (vector-ref edges vertex))) (cdr (vector-ref edges vertex)))
@ -605,11 +599,11 @@
(proc->vector size (proc->vector size
(lambda (v) (lambda (v)
(let ((from-v (let ((from-v
(make-vector size #F))) (make-vector size #f)))
(vector-set! from-v v #T) (vector-set! from-v v #t)
(for-each (for-each
(lambda (x) (lambda (x)
(vector-set! from-v x #T)) (vector-set! from-v x #t))
(vector-ref vertex->out v)) (vector-ref vertex->out v))
from-v))))) from-v)))))
(gnatural-for-each size (gnatural-for-each size
@ -626,7 +620,7 @@
(lambda (t) (lambda (t)
(if (vector-ref from-m t) (if (vector-ref from-m t)
(begin ; [wdc - was when] (begin ; [wdc - was when]
(vector-set! from-f t #T))))))))))))) (vector-set! from-f t #t)))))))))))))
res))) res)))
@ -642,4 +636,13 @@
; cons ; cons
; '()))) ; '())))
(graphs-benchmark 6) (let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 3) (v 0))
(if (zero? n)
v
(loop (- n 1)
(fold-over-rdg (if input 6 0)
2
cons
'()))))))