diff --git a/collects/tests/mzscheme/benchmarks/common/auto.ss b/collects/tests/mzscheme/benchmarks/common/auto.ss index f3ad8439f5..725e59e906 100755 --- a/collects/tests/mzscheme/benchmarks/common/auto.ss +++ b/collects/tests/mzscheme/benchmarks/common/auto.ss @@ -3,6 +3,8 @@ exec mzscheme -qu "$0" ${1+"$@"} |# +;; See "tabulate.ss" for information on the output format + (module auto scheme/base (require (for-syntax scheme/base) mzlib/process @@ -11,6 +13,7 @@ exec mzscheme -qu "$0" ${1+"$@"} mzlib/compile mzlib/inflate mzlib/date + mzlib/port dynext/file syntax/toplevel scheme/runtime-path) @@ -74,18 +77,24 @@ exec mzscheme -qu "$0" ${1+"$@"} (define (clean-up-zo bm) (delete-file (build-path "compiled" (format "~a.zo" bm)))) + (define (setup-larceny bm) + (setup-sps bm "(larceny benchmarking)")) + (define (mk-larceny bm) (parameterize ([current-input-port (open-input-string (format (string-append - "(compiler-switches 'fast-safe)\n" - "(compile-file \"~a.sch\")\n") + "(import (larceny compiler))\n" + "(compile-library \"~a.sls\")\n") bm))] [current-output-port (open-output-bytes)]) - (system "larceny"))) + (system "larceny -err5rs") + ;; Make sure compiled version is used: + (delete-file (format "~a.sls" bm)))) (define (clean-up-fasl bm) - (delete-file (format "~a.fasl" bm))) + (clean-up-sps bm) + (delete-file (format "~a.slfasl" bm))) (define (mk-mzc bm) (parameterize ([current-output-port (open-output-bytes)]) @@ -104,16 +113,45 @@ exec mzscheme -qu "$0" ${1+"$@"} (system (format "gsi -:d-,m10000 ~a.o1" bm))) (define (run-larceny bm) - (parameterize ([current-input-port (open-input-string - (format "(load \"~a.fasl\")\n" - bm))]) - (system "larceny"))) + (system "larceny -r6rs -program prog.sps -path .")) + (define (setup-sps bm lib) + (with-output-to-file "prog.sps" + #:exists 'truncate + (lambda () + (printf "(import (~a))\n" bm) + (printf "(bm-!-go)\n"))) + (with-output-to-file (format "~a.sls" bm) + #:exists 'truncate + (lambda () + (printf "(library (~a)\n" bm) + (printf " (export bm-!-go)\n") + (printf " (import (rnrs) (rnrs mutable-pairs) (rnrs mutable-strings) (rnrs r5rs) ~a)\n" lib) + (printf " (define (bm-!-go) 'ok)\n") + (call-with-input-file (format "~a.sch" bm) + (lambda (in) + (copy-port in (current-output-port)))) + (printf ")\n")))) + + (define (clean-up-sps bm) + (delete-file "prog.sps") + (let ([f (format "~a.sls" bm)]) + (when (file-exists? f) + (delete-file f)))) + + (define (setup-ikarus bm) + (setup-sps bm "(ikarus)") + (system "rm -rf ~/.ikarus")) + (define (mk-ikarus bm) - (void)) + (system "ikarus --compile-dependencies prog.sps")) (define (run-ikarus bm) - (system (format "ikarus ~a.sch < /dev/null" bm))) + (system "ikarus --r6rs-script prog.sps")) + + (define (clean-up-ikarus bm) + (clean-up-sps bm) + (system "rm -rf ~/.ikarus")) (define (extract-times bm str) str) @@ -134,6 +172,15 @@ exec mzscheme -qu "$0" ${1+"$@"} (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)]) (map bytes->number (cdr m)))) + (define (extract-bigloo-times bm str) + (let ([m (regexp-match #rx#"real: ([0-9]+) sys: ([0-9]+) user: ([0-9]+)" str)] + ;; `time' result is 10s of milliseconds? OS ticks, maybe? + [msec/tick 10]) + (list (* msec/tick (+ (bytes->number (caddr m)) + (bytes->number (cadddr m)))) + (* msec/tick (bytes->number (cadr m))) + 0))) + (define (extract-larceny-times bm str) (let ([m (regexp-match #rx#"Elapsed time...: ([0-9]+) ms.*Elapsed GC time: ([0-9]+) ms" str)]) (list (bytes->number (cadr m)) @@ -169,7 +216,7 @@ exec mzscheme -qu "$0" ${1+"$@"} ;; Table of implementatons and benchmarks ------------------------------ - (define-struct impl (name make run extract-result clean-up skips)) + (define-struct impl (name setup make run extract-result clean-up skips)) (define mutable-pair-progs '(conform destruct @@ -183,6 +230,7 @@ exec mzscheme -qu "$0" ${1+"$@"} (define impls (list (make-impl 'mzscheme + void mk-mzscheme (lambda (bm) (system (format "mzscheme -u ~a.ss" bm))) @@ -190,6 +238,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-nothing mutable-pair-progs) (make-impl 'mz-old + void mk-mzscheme (lambda (bm) (system (format "mz-old -u ~a.ss" bm))) @@ -197,6 +246,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-nothing mutable-pair-progs) (make-impl 'mzschemecgc + void mk-mzscheme (lambda (bm) (system (format "mzschemecgc -u ~a.ss" bm))) @@ -204,6 +254,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-nothing mutable-pair-progs) (make-impl 'mzscheme3m + void mk-mzscheme (lambda (bm) (system (format "mzscheme3m -u ~a.ss" bm))) @@ -211,6 +262,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-nothing mutable-pair-progs) (make-impl 'plt-r5rs + void mk-plt-r5rs (lambda (bm) (system (format "plt-r5rs ~a.scm" bm))) @@ -218,6 +270,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-plt-r5rs null) (make-impl 'mzc + void mk-mzc (lambda (bm) (system (format "mzscheme -mvqee '(load-extension \"~a\")' '(require ~a)'" @@ -228,6 +281,7 @@ exec mzscheme -qu "$0" ${1+"$@"} (append '(takr takr2) mutable-pair-progs)) (make-impl 'mzscheme-j + void mk-mzscheme (lambda (bm) (system (format "mzscheme -jqu ~a.ss" bm))) @@ -235,6 +289,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-nothing mutable-pair-progs) (make-impl 'mzschemecgc-j + void mk-mzscheme (lambda (bm) (system (format "mzschemecgc -jqu ~a.ss" bm))) @@ -242,6 +297,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-nothing mutable-pair-progs) (make-impl 'mzschemecgc-tl + void mk-mzscheme-tl (lambda (bm) (system (format "mzschemecgc -qr compiled/~a.zo" bm))) @@ -250,37 +306,42 @@ exec mzscheme -qu "$0" ${1+"$@"} (append '(nucleic2) mutable-pair-progs)) (make-impl 'chicken + void (run-mk "mk-chicken.ss") run-exe extract-chicken-times clean-up-bin - '(nucleic2)) + '(scheme2 takr2)) (make-impl 'bigloo + void (run-mk "mk-bigloo.ss") - run-exe/time - extract-time-times + run-exe + extract-bigloo-times clean-up-bin - '(cpstack maze maze2 puzzle triangle)) + '(cpstack takr2)) (make-impl 'gambit + void (run-mk "mk-gambit.ss") run-gambit-exe extract-gambit-times clean-up-o1 '(nucleic2)) (make-impl 'larceny + setup-larceny mk-larceny run-larceny extract-larceny-times clean-up-fasl '()) (make-impl 'ikarus + setup-ikarus mk-ikarus run-ikarus extract-ikarus-times - clean-up-nothing - '(fft)))) + clean-up-ikarus + '(takr)))) - (define obsolte-impls '(mzscheme mzscheme-j mzschemecgc-tl mzc mz-old)) + (define obsolte-impls '(mzscheme3m mzschemecgc mzscheme-j mzschemecgc-j mzschemecgc-tl mzc mz-old)) (define benchmarks '(conform @@ -303,6 +364,7 @@ exec mzscheme -qu "$0" ${1+"$@"} nboyer nestedloop nfa + nothing nqueens nucleic2 paraffins @@ -329,23 +391,25 @@ exec mzscheme -qu "$0" ${1+"$@"} impls)]) (if (memq bm (impl-skips i)) (rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f)) - (let ([start (current-inexact-milliseconds)]) - ((impl-make i) bm) - (let ([end (current-inexact-milliseconds)]) - (let loop ([n num-iterations]) - (unless (zero? n) - (let ([out (open-output-bytes)]) - (unless (parameterize ([current-output-port out] - [current-error-port out]) - ((impl-run i) bm)) - (error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm)) - (rprintf "[~a ~a ~s ~a]\n" - impl - bm - ((impl-extract-result i) bm (get-output-bytes out)) - (inexact->exact (round (- end start))))) - (loop (sub1 n))))) - ((impl-clean-up i) bm))) + (begin + ((impl-setup i) bm) + (let ([start (current-inexact-milliseconds)]) + ((impl-make i) bm) + (let ([end (current-inexact-milliseconds)]) + (let loop ([n num-iterations]) + (unless (zero? n) + (let ([out (open-output-bytes)]) + (unless (parameterize ([current-output-port out] + [current-error-port out]) + ((impl-run i) bm)) + (error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm)) + (rprintf "[~a ~a ~s ~a]\n" + impl + bm + ((impl-extract-result i) bm (get-output-bytes out)) + (inexact->exact (round (- end start))))) + (loop (sub1 n))))) + ((impl-clean-up i) bm)))) (flush-output))) ;; Extract command-line arguments -------------------- diff --git a/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch b/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch index c0bc43003d..edb17f65ff 100644 --- a/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch +++ b/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch @@ -1,9 +1,16 @@ +(define orig-time time) + (define-macro (time expr) `(time-it (lambda () ,expr))) (define (time-it thunk) - (thunk)) + (multiple-value-bind (res rtime stime utime) + (orig-time thunk) + (print "real: " rtime " sys: " stime " user: " utime) + res)) (define (error . x) #f) - +(define bitwise-or bit-or) +(define bitwise-and bit-and) +(define bitwise-not bit-not) diff --git a/collects/tests/mzscheme/benchmarks/common/dderiv.sch b/collects/tests/mzscheme/benchmarks/common/dderiv.sch index bc01d9cac7..5e47a0b037 100644 --- a/collects/tests/mzscheme/benchmarks/common/dderiv.sch +++ b/collects/tests/mzscheme/benchmarks/common/dderiv.sch @@ -46,19 +46,13 @@ (define (f+dderiv a) (cons '+ (map dderiv a))) -(put '+ 'dderiv f+dderiv) ; install procedure on the property list - (define (f-dderiv a) (cons '- (map dderiv a))) -(put '- 'dderiv f-dderiv) ; install procedure on the property list - (define (*dderiv a) (list '* (cons '* a) (cons '+ (map dderiv-aux a)))) -(put '* 'dderiv *dderiv) ; install procedure on the property list - (define (/dderiv a) (list '- (list '/ @@ -71,8 +65,6 @@ (cadr a) (dderiv (cadr a)))))) -(put '/ 'dderiv /dderiv) ; install procedure on the property list - (define (dderiv a) (cond ((not (pair? a)) @@ -90,6 +82,14 @@ (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) +(put '+ 'dderiv f+dderiv) ; install procedure on the property list + +(put '- 'dderiv f-dderiv) ; install procedure on the property list + +(put '* 'dderiv *dderiv) ; install procedure on the property list + +(put '/ 'dderiv /dderiv) ; install procedure on the property list + ;;; call: (run) (time (run)) diff --git a/collects/tests/mzscheme/benchmarks/common/index-template.html b/collects/tests/mzscheme/benchmarks/common/index-template.html index ac12dd642c..ecdf4dc875 100644 --- a/collects/tests/mzscheme/benchmarks/common/index-template.html +++ b/collects/tests/mzscheme/benchmarks/common/index-template.html @@ -4,45 +4,52 @@

About the Benchmarks

-

The pages linked below show some benchmark results on a collection of fairly standard +

The benchmark page shows some benchmark results on a collection of fairly standard (mostly Gabriel) Scheme benchmarks.

Tables show relative performance, with the actual time for the fastest run shown on the left. So, by default, 1 is the fastest, but select any implementation to normalize the table with respect to that implementation's speed. A -- appears when a benchmark - didn't run in an implementation (and you should assume a benchmark problem, - rather than an implementation problem).

+ didn't run in an implementation for some reason (possibly not a good one).

-

Small gray numbers are (relative) compile times.

+

Small gray numbers are (relative) +compile times, where the compile time for the nothing +benchmark is subtracted from every other benchmark's compile +time.

Run times are averaged over three runs. All reported times are CPU time (system plus user). - Where available, the times are based on the output of the implementation's time - syntactic form, otherwise /usr/bin/time is used.

+ The times are based on the output of the implementation's time + syntactic form for function.

-

Compiler configuration: +

Machine:

+ +

Compiler configurations: +

-These configurations are all "safe mode", but they allow the compiler -to assume that built-in Scheme functions are not redefined and (except -in the case of Larceny) that no top-level defintion is ever +These configurations are all “safe mode,” but they allow the compiler +to assume that built-in Scheme functions are not redefined and that no top-level defintion is ever changed. Such assumptions correspond to putting the benchmark in an -R6RS library (we expect).

+R6RS library.

In general, we attempt to use the various implementations in a compentent way, but not in a sophisticated way. For example, we do not tweak inlining parameters or specify fixnum arithmetic (where appropriate), which could produce significant improvements from some compilers.

-

For a larger set of benchmarks and a more sophisticated use of the compilers, - see Marc Feeley's page: - http://www.iro.umontreal.ca/~gambit/bench.html. +

For more benchmarks and a more sophisticated use of a few compilers, + including fixnum- and flonum-specific arithmetic as well as unsafe modes, + see this other page.

For further details on the benchmarks here, see the benchmark source and infrastructure, which is available form the PLT SVN repository:

@@ -50,8 +57,3 @@ R6RS library (we expect).

http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/

-

Results

- - diff --git a/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss b/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss index 1ae3523c47..700d34ae95 100644 --- a/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss +++ b/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss @@ -9,9 +9,9 @@ (include "bigloo-prelude.sch") (include ,(format "~a.sch" name)))) (newline)) - 'truncate/replace) + #:exists 'truncate/replace) -(when (system (format "bigloo -w -o ~a -copt -O3 -copt -fomit-frame-pointer -O6 ~a~a.scm" +(when (system (format "bigloo -w -o ~a -copt -m32 -call/cc -copt -O3 -copt -fomit-frame-pointer -O6 ~a~a.scm" name (if (memq (string->symbol name) '(ctak)) diff --git a/collects/tests/mzscheme/benchmarks/common/nfa.sch b/collects/tests/mzscheme/benchmarks/common/nfa.sch index 2b3aa06d3a..b00dcd076b 100644 --- a/collects/tests/mzscheme/benchmarks/common/nfa.sch +++ b/collects/tests/mzscheme/benchmarks/common/nfa.sch @@ -42,7 +42,7 @@ 'fail)) (time (let ((input (string->list (string-append (make-string 133 #\a) "bc")))) - (let loop ((n 50000)) + (let loop ((n 150000)) (if (zero? n) 'done (begin diff --git a/collects/tests/mzscheme/benchmarks/common/nothing.sch b/collects/tests/mzscheme/benchmarks/common/nothing.sch new file mode 100644 index 0000000000..d3cd072131 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/nothing.sch @@ -0,0 +1 @@ +(time 1) diff --git a/collects/tests/mzscheme/benchmarks/common/nothing.ss b/collects/tests/mzscheme/benchmarks/common/nothing.ss new file mode 100644 index 0000000000..1f7a80f8fe --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/nothing.ss @@ -0,0 +1,2 @@ + +(module nothing "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch index 24c0b04b7b..2e99c4119b 100644 --- a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch +++ b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch @@ -49,10 +49,6 @@ (define-syntax FUTURE (syntax-rules () ((FUTURE x) x))) (define-syntax TOUCH (syntax-rules () ((TOUCH x) x))) -(define-syntax def-macro (syntax-rules () ((def-macro stuff ...) #t))) -(define-syntax def-struct (syntax-rules () ((def-macro stuff ...) #t))) -(define-syntax def-nuc (syntax-rules () ((def-nuc stuff ...) #t))) - (define-syntax define-structure (syntax-rules () ((define-structure #f @@ -320,204 +316,6 @@ ) -; -- SYSTEM DEPENDENT CODE ---------------------------------------------------- - -; The code in this section is not portable. It must be adapted to -; the Scheme system you are using. - -; ********** GAMBIT 2.2 - -'; Add a single-quote at the start of this line if you are NOT using Gambit -(begin - -(declare ; Compiler declarations for fast code: - (multilisp) ; - Enable the FUTURE special-form - (block) ; - Assume this file contains the entire program - (standard-bindings) ; - Assume standard bindings (this permits open-coding) - (extended-bindings) ; - Same for extensions (such as "##flonum.+") - (fixnum) ; - Use fixnum arithmetic by default - (not safe) ; - Remove all runtime type checks -) - -(define-macro (def-macro form . body) - `(DEFINE-MACRO ,form (LET () ,@body))) - -(def-macro (FLOAT+ x . l) `(,(string->symbol "##flonum.+") ,x ,@l)) -(def-macro (FLOAT- x . l) `(,(string->symbol "##flonum.-") ,x ,@l)) -(def-macro (FLOAT* x . l) `(,(string->symbol "##flonum.*") ,x ,@l)) -(def-macro (FLOAT/ x . l) `(,(string->symbol "##flonum./") ,x ,@l)) -(def-macro (FLOAT= x y) `(,(string->symbol "##flonum.=") ,x ,y)) -(def-macro (FLOAT< x y) `(,(string->symbol "##flonum.<") ,x ,y)) -(def-macro (FLOAT<= x y) `(not (,(string->symbol "##flonum.<") ,y ,x))) -(def-macro (FLOAT> x y) `(,(string->symbol "##flonum.<") ,y ,x)) -(def-macro (FLOAT>= x y) `(not (,(string->symbol "##flonum.<") ,x ,y))) -(def-macro (FLOATsin x) `(,(string->symbol "##flonum.sin") ,x)) -(def-macro (FLOATcos x) `(,(string->symbol "##flonum.cos") ,x)) -(def-macro (FLOATatan x) `(,(string->symbol "##flonum.atan") ,x)) -(def-macro (FLOATsqrt x) `(,(string->symbol "##flonum.sqrt") ,x)) -) - -; ********** MIT-SCHEME - -'; Remove the single-quote from this line if you are using MIT-Scheme -(begin - -(declare (usual-integrations)) - -(define-macro (def-macro form . body) - `(DEFINE-MACRO ,form (LET () ,@body))) - -(def-macro (nary-function op1 op2 args) - (if (null? (cdr args)) - `(,op1 ,@args) - (let loop ((args args)) - (if (null? (cdr args)) - (car args) - (loop (cons (list op2 (car args) (cadr args)) (cddr args))))))) - -(def-macro (FLOAT+ x . l) `(nary-function begin flo:+ ,(cons x l))) -(def-macro (FLOAT- x . l) `(nary-function flo:negate flo:- ,(cons x l))) -(def-macro (FLOAT* x . l) `(nary-function begin flo:* ,(cons x l))) -(def-macro (FLOAT/ x . l) `(nary-function error flo:/ ,(cons x l))) -(def-macro (FLOAT= x y) `(flo:= ,x ,y)) -(def-macro (FLOAT< x y) `(flo:< ,x ,y)) -(def-macro (FLOAT<= x y) `(not (flo:< ,y ,x))) -(def-macro (FLOAT> x y) `(flo:< ,y ,x)) -(def-macro (FLOAT>= x y) `(not (flo:< ,x ,y))) -(def-macro (FLOATsin x) `(flo:sin ,x)) -(def-macro (FLOATcos x) `(flo:cos ,x)) -(def-macro (FLOATatan x) `(flo:atan ,x)) -(def-macro (FLOATsqrt x) `(flo:sqrt ,x)) - -(def-macro (FUTURE x) x) -(def-macro (TOUCH x) x) -) - -; ********** SCM - -'; Remove the single-quote from this line if you are using SCM -(begin - -(defmacro def-macro (form . body) - `(DEFMACRO ,(car form) ,(cdr form) (LET () ,@body))) - -(def-macro (FLOAT+ x . l) `(+ ,x ,@l)) -(def-macro (FLOAT- x . l) `(- ,x ,@l)) -(def-macro (FLOAT* x . l) `(* ,x ,@l)) -(def-macro (FLOAT/ x . l) `(/ ,x ,@l)) -(def-macro (FLOAT= x y) `(= ,x ,y)) -(def-macro (FLOAT< x y) `(< ,x ,y)) -(def-macro (FLOAT<= x y) `(not (< ,y ,x))) -(def-macro (FLOAT> x y) `(< ,y ,x)) -(def-macro (FLOAT>= x y) `(not (< ,x ,y))) -(def-macro (FLOATsin x) `(sin ,x)) -(def-macro (FLOATcos x) `(cos ,x)) -(def-macro (FLOATatan x) `(atan ,x)) -(def-macro (FLOATsqrt x) `(sqrt ,x)) - -(def-macro (FUTURE x) x) -(def-macro (TOUCH x) x) -) - -; -- STRUCTURE DEFINITION MACRO ----------------------------------------------- - -; The macro "def-struct" provides a simple mechanism to define record -; structures out of vectors. The first argument to "def-struct" is a boolean -; indicating whether the vector should be tagged (to allow the type of the -; structure to be tested). The second argument is the name of the structure. -; The remaining arguments are the names of the structure's fields. A call -; to "def-struct" defines macros to -; -; 1) construct a record object of this type -; 2) fetch and store each field -; 3) test a record to see if it is of this type (only if tags are used) -; 4) define subclasses of this record with additional fields -; -; The call "(def-struct #t foo a b c)" will define the following macros: -; -; (make-foo x y) -- make a record -; (make-constant-foo x y) -- make a record (args must be constants) -; (foo? x) -- test a record -; (foo-a x) -- get field "a" -; (foo-b x) -- get field "b" -; (foo-a-set! x y) -- mutate field "a" -; (foo-b-set! x y) -- mutate field "b" -; (def-foo tag? name fields...) -- define subclass of "foo" - -(def-macro (def-struct tag? name . fields) - `(DEF-SUBSTRUCT () () 0 ,tag? ,name ,@fields)) - -(def-macro (def-substruct sup-fields sup-tags sup-length tag? name . fields) - - (define (err) - (error "Ill-formed `def-substruct'") #f) - - (define (sym . strings) - (string->symbol (apply string-append strings))) - - (if (symbol? name) - (let* ((name-str (symbol->string name)) - (tag (sym "." name-str ".")) - (all-tags (append sup-tags - (if tag? - (list (cons tag sup-length)) - '())))) - (let loop ((l1 fields) - (l2 '()) - (l3 '()) - (i (+ sup-length (if tag? 1 0)))) - (if (pair? l1) - (let ((rest (cdr l1)) (field (car l1))) - (if (symbol? field) - (let* ((field-str (symbol->string field)) - (field-ref (sym name-str "-" field-str)) - (field-set! (sym name-str "-" field-str "-set!"))) - (loop rest - (cons `(DEF-MACRO (,field-set! X Y) - `(VECTOR-SET! ,X ,,i ,Y)) - (cons `(DEF-MACRO (,field-ref X) - `(VECTOR-REF ,X ,,i)) - l2)) - (cons (cons field i) l3) - (+ i 1))) - (err))) - (let ((all-fields (append sup-fields (reverse l3)))) - `(BEGIN - ,@l2 - (DEFINE ,(sym "fields-of-" name-str) - ',all-fields) - (DEF-MACRO (,(sym "def-" name-str) TAG? NAME . FIELDS) - `(DEF-SUBSTRUCT ,',all-fields ,',all-tags ,',i - ,TAG? ,NAME ,@FIELDS)) - (DEF-MACRO (,(sym "make-constant-" name-str) . REST) - (DEFINE (ADD-TAGS I TAGS LST) - (COND ((NULL? TAGS) - LST) - ((= I (CDAR TAGS)) - (CONS (CAAR TAGS) - (ADD-TAGS (+ I 1) (CDR TAGS) LST))) - (ELSE - (CONS (CAR LST) - (ADD-TAGS (+ I 1) TAGS (CDR LST)))))) - `'#(,@(ADD-TAGS 0 ',all-tags REST))) - (DEF-MACRO (,(sym "make-" name-str) . REST) - (DEFINE (ADD-TAGS I TAGS LST) - (COND ((NULL? TAGS) - LST) - ((= I (CDAR TAGS)) - (CONS `',(CAAR TAGS) - (ADD-TAGS (+ I 1) (CDR TAGS) LST))) - (ELSE - (CONS (CAR LST) - (ADD-TAGS (+ I 1) TAGS (CDR LST)))))) - `(VECTOR ,@(ADD-TAGS 0 ',all-tags REST))) - ,@(if tag? - `((DEF-MACRO (,(sym name-str "?") X) - `(EQ? (VECTOR-REF ,X ,,sup-length) ',',tag))) - '()) - ',name))))) - (err))) - ; -- MATH UTILITIES ----------------------------------------------------------- (define constant-pi 3.14159265358979323846) @@ -539,8 +337,6 @@ ; -- POINTS ------------------------------------------------------------------- -(def-struct #f pt x y z) - (define (pt-sub p1 p2) (make-pt (FLOAT- (pt-x p1) (pt-x p2)) (FLOAT- (pt-y p1) (pt-y p2)) @@ -579,8 +375,6 @@ ; ; The components tx, ty, and tz are the translation vector. -(def-struct #f tfo a b c d e f g h i tx ty tz) - (define tfo-id ; the identity transformation matrix '#(1.0 0.0 0.0 0.0 1.0 0.0 @@ -742,21 +536,8 @@ ; Define part common to all 4 nucleotide types. -(def-struct #f nuc - dgf-base-tfo ; defines the standard position for wc and wc-dumas - P-O3*-275-tfo ; defines the standard position for the connect function - P-O3*-180-tfo - P-O3*-60-tfo - P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2* H2** O2* H2* C3* - H3* O3* N1 N3 C2 C4 C5 C6) - ; Define remaining atoms for each nucleotide type. -(def-nuc #t rA N6 N7 N9 C8 H2 H61 H62 H8) -(def-nuc #t rC N4 O2 H41 H42 H5 H6) -(def-nuc #t rG N2 N7 N9 C8 O6 H1 H21 H22 H8) -(def-nuc #t rU O2 O4 H3 H5 H6) - ; Database of nucleotide conformations: (define rA @@ -3167,38 +2948,6 @@ ; -- PARTIAL INSTANTIATIONS --------------------------------------------------- -(def-struct #f var id tfo nuc) - -; Add a single-quote at the start of this line if you want lazy computation -(begin - -(def-macro (mk-var i tfo nuc) - `(make-var ,i ,tfo ,nuc)) - -(def-macro (absolute-pos var p) - `(tfo-apply (var-tfo ,var) ,p)) - -(def-macro (lazy-computation-of expr) - expr) -) - -'; Remove the single-quote from this line if you want lazy computation -(begin - -(def-macro (mk-var i tfo nuc) - `(make-var ,i ,tfo (make-relative-nuc ,tfo ,nuc))) - -(def-macro (absolute-pos var p) - `(force ,p)) - -(def-macro (lazy-computation-of expr) - `(delay ,expr)) -) - -(def-macro (atom-pos atom var) - `(let ((v ,var)) - (absolute-pos v (,atom (var-nuc v))))) - (define (get-var id lst) (let ((v (car lst))) (if (= id (var-id v)) diff --git a/collects/tests/mzscheme/benchmarks/common/peval.sch b/collects/tests/mzscheme/benchmarks/common/peval.sch index dfa6ce3791..40d5047170 100644 --- a/collects/tests/mzscheme/benchmarks/common/peval.sch +++ b/collects/tests/mzscheme/benchmarks/common/peval.sch @@ -627,7 +627,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 20) (v 0)) + (let loop ((n 60) (v 0)) (if (zero? n) v (loop (- n 1) (test (if input 0 17))))))) diff --git a/collects/tests/mzscheme/benchmarks/common/puzzle.sch b/collects/tests/mzscheme/benchmarks/common/puzzle.sch index 9120df4e17..47cbc60208 100644 --- a/collects/tests/mzscheme/benchmarks/common/puzzle.sch +++ b/collects/tests/mzscheme/benchmarks/common/puzzle.sch @@ -30,8 +30,9 @@ (define *piecemax* (make-vector (+ typemax 1) 0)) (define *puzzle* (make-vector (+ size 1))) (define *p* (make-vector (+ typemax 1))) -(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) - (iota (+ typemax 1))) +(define nothing + (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) + (iota (+ typemax 1)))) (define (fit i j) (let ((end (vector-ref *piecemax* i))) diff --git a/collects/tests/mzscheme/benchmarks/common/scheme.sch b/collects/tests/mzscheme/benchmarks/common/scheme.sch index 9761ad7df7..ac891d530d 100644 --- a/collects/tests/mzscheme/benchmarks/common/scheme.sch +++ b/collects/tests/mzscheme/benchmarks/common/scheme.sch @@ -856,6 +856,8 @@ (scheme-global-var name) value)) +(define nothing + (begin (def-proc 'not (lambda (x) (not x))) (def-proc 'boolean? boolean?) (def-proc 'eqv? eqv?) @@ -1032,7 +1034,7 @@ (def-proc 'write write) (def-proc 'display display) (def-proc 'newline newline) -(def-proc 'write-char write-char) +(def-proc 'write-char write-char))) ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/collects/tests/mzscheme/benchmarks/common/scheme2.sch b/collects/tests/mzscheme/benchmarks/common/scheme2.sch index 9a307fbb85..934b5783ec 100644 --- a/collects/tests/mzscheme/benchmarks/common/scheme2.sch +++ b/collects/tests/mzscheme/benchmarks/common/scheme2.sch @@ -862,6 +862,8 @@ (scheme-global-var name) value)) +(define nothing + (begin (def-proc 'not (lambda (x) (not x))) (def-proc 'boolean? boolean?) (def-proc 'eqv? eqv?) @@ -1038,7 +1040,7 @@ (def-proc 'write write) (def-proc 'display display) (def-proc 'newline newline) -(def-proc 'write-char write-char) +(def-proc 'write-char write-char))) ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/collects/tests/mzscheme/benchmarks/common/tabulate.ss b/collects/tests/mzscheme/benchmarks/common/tabulate.ss index 0b2d41d103..4675cf0c59 100755 --- a/collects/tests/mzscheme/benchmarks/common/tabulate.ss +++ b/collects/tests/mzscheme/benchmarks/common/tabulate.ss @@ -3,28 +3,46 @@ exec mzscheme -qu "$0" ${1+"$@"} |# +;; Input format is a sequence of S-expression forms: +;; ( ( ) ) +;; where +;; * is a symbol for an implementation; it can optionally be of the form +;; @, where each is tried in each +;; * is a symbol for the benchmark +;; * and are the run times (CPU and real) in milliseconds +;; * can be #f, or it can be a portion of spent GCing +;; * should be the same for each entry of a particular +;; and combination; it is the time to compile the benchmark + (module tabulate mzscheme (require mzlib/list xml/xml - mzlib/cmdline) + mzlib/cmdline + (only scheme/list argmin)) (define base-link-filename (make-parameter #f)) (define full-page-mode (make-parameter #f)) (define include-links (make-parameter #f)) (define nongc (make-parameter #f)) + (define subtract-nothing (make-parameter #f)) + (define generate-graph (make-parameter #f)) (command-line "tabulate" (current-command-line-arguments) (once-each - [("--no-links") "suppress benchmark links to SVN" - (include-links #f)] + [("--graph") "generate graphs instead of tables (unless --multi)" + (generate-graph #t)] + [("--links") "benchmark links to SVN" + (include-links #t)] [("--multi") name "generate multiple pages for different views of data" (base-link-filename name)] [("--nongc") "show times not including GC" (nongc #t)] [("--index") "generate full page with an index.html link" - (full-page-mode #t)])) + (full-page-mode #t)] + [("--nothing") "subtract compilation time of nothing benchmark" + (subtract-nothing #t)])) (define bm-table (make-hash-table)) (define impls (make-hash-table)) @@ -54,21 +72,55 @@ exec mzscheme -qu "$0" ${1+"$@"} (define average-runs (map (lambda (bm-run) - (cons - (car bm-run) - (map (lambda (runs) - (list (car runs) - (list (average caar (cdr runs)) - (average cadar (cdr runs)) - (average caddar (cdr runs))) - (cadadr runs))) - (hash-table-map (cdr bm-run) cons)))) - bm-runs)) + (let* ([runss (hash-table-map (cdr bm-run) cons)]) + (cons + (car bm-run) + (map (lambda (runs) + (list (car runs) + (list (average caar (cdr runs)) + (average cadar (cdr runs)) + (average caddar (cdr runs))) + (let ([nothing-compile-time + (if (subtract-nothing) + (let ([a (hash-table-get + (hash-table-get bm-table 'nothing #hash()) + (car runs) + #f)]) + (if a + (cadadr a) + 0)) + 0)]) + (max (- (or (cadadr runs) 0) + nothing-compile-time) + 0)))) + runss)))) + (if (subtract-nothing) + (filter (lambda (v) + (not (eq? (car v) 'nothing))) + bm-runs) + bm-runs))) (define (symbolstring a) (symbol->string b))) + (define (modestring impl)]) + (cond + [(regexp-match #rx"^(.*)@(.*)" s) + => (lambda (m) + (if (eq? grouping 'impl) + (cadr m) + (caddr m)))] + [else s]))) + (define sorted-runs (sort average-runs (lambda (a b) (symbolstring r) (if (integer? r) (number->string r) @@ -87,147 +148,329 @@ exec mzscheme -qu "$0" ${1+"$@"} (size "-2")) ,s)) - (define (lookup-color impl) - (let loop ([impls sorted-impls][odd? #f]) - (if (eq? (car impls) impl) - (if odd? - "#EEEEFF" - "#DDFFDD") - (loop (cdr impls) (not odd?))))) - - (define (wrap-page relative-to p) + (define (wrap-page relative-to . ps) (if (full-page-mode) - (let ([title (format "~a normalized to ~a" + (let ([title (format "~a normalized to ~a~a" (or (base-link-filename) "results") + (if (string? relative-to) + "fastest " + "") (or relative-to "fastest"))]) `(html (head (title ,title) (body - (h1 ,title) - (p "See also " (a ((href "index.html")) - "about the benchmarks") - ".") - (p ,p))))) - p)) + (p + (b ,title ".") + " See also " (a ((href "index.html")) + "about the benchmarks") + ".") + ,@(map (lambda (p) `(p ,p)) + ps))))) + `(html (nbody ,@ps)))) (define forever 1000000000) (define (ntime v) - (and (caadr v) (- (caadr v) (caddr (cadr v))))) + (and (caadr v) (- (caadr v) (or (caddr (cadr v)) 0)))) - (define (generate-page relative-to) + (define (grouping->suffix grouping) + (if (eq? grouping 'impl) + "" + (format "-~a" grouping))) + + (define no-modes? (equal? mode-sorted-impls sorted-impls)) + + (define (fixup-filename s) + (regexp-replace* #rx"[^.a-zA-Z0-9-]" s (lambda (s) + (format "_~x" (char->integer (string-ref s 0)))))) + + (define (output-name impl grouping graph?) + (fixup-filename + (if impl + (format "~a-~a~a.html" + (base-link-filename) + impl + (grouping->suffix grouping)) + (format "~a~a~a.html" + (base-link-filename) + (grouping->suffix grouping) + (if graph? "-plot" ""))))) + + (define (resolve-relative-to relative-to grouping runs) + (if (string? relative-to) + ;; Find fastest among entries matching `relative-to': + (car (argmin (lambda (run) + (or (caadr run) forever)) + (cons (list #f (list #f #f #f) #f) + (filter (lambda (run) + (equal? relative-to (extract-column (car run) grouping))) + runs)))) + ;; Nothing to resolve: + relative-to)) + + (define (extract-variants grouping impls) + (let ([ht (make-hash-table 'equal)]) + (for-each (lambda (impl) + (hash-table-put! ht (extract-column impl grouping) #t)) + impls) + (hash-table-map ht (lambda (k v) k)))) + + (define just-impls (sort (extract-variants 'impl sorted-impls) stringxml (wrap-page relative-to - `(table - (tr (td nbsp) - (td ((colspan "2") (align "right")) - ,(if (and (base-link-filename) - relative-to) - `(a ((href ,(format "~a.html" (base-link-filename)))) - "fastest") - "fastest")) - ,@(map (lambda (impl) - `(td ((colspan "2") (align "right")) - (b ,(let ([s (symbol->string impl)]) - (if (and (base-link-filename) - (not (eq? impl relative-to))) - `(a ((href ,(format "~a-~a.html" - (base-link-filename) - impl))) - ,s) - s))) - nbsp)) - sorted-impls)) - ,@(map (lambda (bm-run) - (let ([fastest (apply min (map (lambda (run) - (or (caadr run) forever)) - (cdr bm-run)))] - [n-fastest (apply min (map (lambda (run) - (or (ntime run) forever)) - (cdr bm-run)))] - [c-fastest (apply min (map (lambda (run) - (let ([v (caddr run)]) - (or (and v (positive? v) v) - forever))) - (cdr bm-run)))]) - (let-values ([(base n-base c-base) - (if relative-to - (let ([a (assq relative-to (cdr bm-run))]) - (if a - (values (caadr a) (ntime a) (caddr a)) - (values #f #f #f))) - (values fastest n-fastest c-fastest))]) - `(tr (td ,(if (include-links) - `(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/" - "tests/mzscheme/benchmarks/common/~a.sch") - (car bm-run)))) - ,(symbol->string (car bm-run))) - (symbol->string (car bm-run)))) - (td ((align "right")) - nbsp - ,(small (if (= c-fastest forever) - " " - (number->string c-fastest))) - nbsp) - (td ((align "right")) - ,(format "~a ms" fastest) - nbsp nbsp) - ,@(apply - append - (map (lambda (impl) - (let* ([a (assq impl (cdr bm-run))] - [n (and a (caadr a))] - [n2 (and a (ntime a))]) - `(,(if (= c-fastest forever) - `(td) - `(td ((align "right") - (bgcolor ,(lookup-color impl))) - ,(if (and (caddr a) c-base (positive? c-base)) - (small (ratio->string (/ (caddr a) c-base))) - '"-") - nbsp)) - (td ((bgcolor ,(lookup-color impl))) - ,(if (and n base) - (let ([s (if (= n base) - "1" - (if (zero? base) - "*" - (ratio->string (/ n base))))]) - (if (= n fastest) - `(font ((color "forestgreen")) (b ,s)) - s)) - "-") - ,@(if (nongc) - `(" / " - ,(if (and n2 n-base) - (let ([s (if (zero? base) + (if (not graph?) + `(table + ,@(if no-modes? + null + (list + `(tr + (td (i ,(if (eq? grouping 'mode) + "mode" + "impl"))) + (td nbsp) + (td nbsp) + ,@(let loop ([impls (if (eq? grouping 'mode) + mode-sorted-impls + sorted-impls)]) + (if (null? impls) + null + (let* ([impl (car impls)] + [s (extract-column impl grouping)] + [count (let loop ([impls (cdr impls)]) + (cond + [(null? impls) 0] + [(not (equal? s (extract-column (car impls) grouping))) + 0] + [else (add1 (loop (cdr impls)))]))]) + (cons + `(td ((colspan ,(number->string (* 2 (+ 1 count)))) + (align "center") + (bgcolor "#DDDDFF")) + (b ,(if (equal? s relative-to) + s + `(a ([href ,(fixup-filename + (format "~a-~a~a.html" + (base-link-filename) + s + (grouping->suffix grouping)))]) + ,s)))) + (loop (list-tail impls (+ 1 count)))))))))) + (tr (td ,(if no-modes? + 'nbsp + `(i (a ([href ,(output-name #f (opposite grouping) #f)]) + ,(if (eq? grouping 'mode) + "impl" + "mode"))))) + (td ((colspan "2") (align "right")) + ,(if (and (base-link-filename) + relative-to) + `(a ((href ,(fixup-filename + (format "~a~a.html" + (base-link-filename) + (grouping->suffix grouping))))) + "fastest") + "fastest")) + ,@(map (lambda (impl) + `(td ((colspan "2") (align "right")) + (b ,(let ([s (extract-column impl (opposite grouping))]) + (if (and (base-link-filename) + (not (eq? impl relative-to))) + `(a ((href ,(fixup-filename + (format "~a-~a~a.html" + (base-link-filename) + impl + (grouping->suffix grouping))))) + ,s) + s))) + nbsp)) + (if (eq? grouping 'mode) + mode-sorted-impls + sorted-impls)) + ,@(if has-other? + `((td nbsp nbsp (a ((href ,(output-name #f 'impl #t))) "To plots"))) + null)) + ,@(map (lambda (bm-run) + (define orig-relative-to relative-to) + (call-with-bm-info + bm-run + relative-to + grouping + (lambda (fastest n-fastest c-fastest relative-to + base n-base c-base) + `(tr (td ,(if (include-links) + `(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/" + "tests/mzscheme/benchmarks/common/~a.sch") + (car bm-run)))) + ,(symbol->string (car bm-run))) + (symbol->string (car bm-run)))) + (td ((align "right")) + nbsp + ,(small (if (= c-fastest forever) + " " + (number->string c-fastest))) + nbsp) + (td ((align "right")) + ,(format "~a ms" fastest) + nbsp nbsp) + ,@(apply + append + (map (lambda (impl) + (let* ([a (assq impl (cdr bm-run))] + [n (and a (caadr a))] + [n2 (and a (ntime a))]) + `(,(if (= c-fastest forever) + `(td) + `(td ((align "right") + (bgcolor ,(lookup-color impl))) + ,(if (and a (caddr a) c-base (positive? c-base)) + (small (ratio->string (/ (caddr a) c-base))) + '"-") + nbsp)) + (td ((bgcolor ,(if (and n base (= n base) + (or (not orig-relative-to) + (and (string? orig-relative-to) + (equal? (extract-column impl grouping) + orig-relative-to)))) + "white" + (lookup-color impl))) + (align "right")) + ,(if (and n base) + (let ([s (if (= n base) + "1" + (if (zero? base) + "*" + (ratio->string (/ n base))))]) + (if (= n fastest) + `(font ((color "forestgreen")) (b ,s)) + s)) + "-") + ,@(if (nongc) + `(" / " + ,(if (and n2 n-base) + (let ([s (if (zero? base) "*" (ratio->string (/ n2 base)))]) - (if (= n2 n-fastest) - `(font ((color "forestgreen")) (b ,s)) - s)) - "-")) - null) - nbsp)))) - sorted-impls)))))) - sorted-runs))))) + (if (= n2 n-fastest) + `(font ((color "forestgreen")) (b ,s)) + s)) + "-")) + null) + nbsp)))) + (if (eq? grouping 'mode) + mode-sorted-impls + sorted-impls))))))) + sorted-runs)) + `(table + ((style "border-spacing: 0px 3px;")) + (tr (td ((colspan "2")) + "Longer is better." + ,@(if has-other? + `(nbsp nbsp (a ((href ,(output-name #f 'impl #f))) "Back to tables")) + null))) + ,@(map (lambda (bm-run) + (call-with-bm-info + bm-run + relative-to + grouping + (lambda (fastest n-fastest c-fastest relative-to + base n-base c-base) + `(tr ((style "background-color: #eeeeee")) + (td ((valign "top")) ,(symbol->string (car bm-run))) + (td + (table + ((style "border-spacing: 0px;")) + ,@(map (lambda (impl) + (let* ([a (assq impl (cdr bm-run))] + [n (and a (caadr a))] + [n2 (and a (ntime a))]) + `(tr (td (span ((style "font-size: small;")) + ,(symbol->string impl)) + nbsp) + (td ((style "padding: 0em;")) + ,(if (and n base) + (let ([col (darken (lookup-color impl))]) + `(span ((style ,(format "background-color: ~a; color: ~a;" col col))) + ,(format (make-string (max (floor (* 60 (if (zero? n) 1 (/ base n)))) + 1) + #\x)))) + ""))))) + sorted-impls))))))) + sorted-runs)))))) (newline)) - + (if (base-link-filename) - (for-each (lambda (impl) - (with-output-to-file (if impl - (format "~a-~a.html" - (base-link-filename) - impl) - (format "~a.html" - (base-link-filename))) - (lambda () (generate-page impl)) - 'truncate)) - (cons #f sorted-impls)) - (generate-page #f))) + (begin + (for-each (lambda (grouping) + (for-each + (lambda (impl) + (let ([fn (output-name impl grouping #f)]) + (fprintf (current-error-port) "Generating ~a\n" fn) + (with-output-to-file fn + (lambda () (generate-page impl grouping #f #t)) + 'truncate))) + (append (cons #f sorted-impls) + (if no-modes? + null + (extract-variants grouping sorted-impls))))) + (if no-modes? + '(impl) + '(impl mode))) + (with-output-to-file (output-name #f 'impl #t) + (lambda () (generate-page #f 'impl #t #t)) + 'truncate)) + (generate-page #f 'impl (generate-graph) #f))) diff --git a/collects/tests/mzscheme/benchmarks/common/triangle.sch b/collects/tests/mzscheme/benchmarks/common/triangle.sch index cceb17ed77..baeddd2704 100644 --- a/collects/tests/mzscheme/benchmarks/common/triangle.sch +++ b/collects/tests/mzscheme/benchmarks/common/triangle.sch @@ -15,38 +15,17 @@ (define *board* (make-vector 16 1)) (define *sequence* (make-vector 14 0)) (define *a* (make-vector 37)) -(for-each (lambda (i x) (vector-set! *a* i x)) - '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) - '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 - 13 7 8 4 4 7 11 8 12 13 6 10 - 15 9 14 13 13 14 15 9 10 - 6 6)) (define *b* (make-vector 37)) -(for-each (lambda (i x) (vector-set! *b* i x)) - '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) - '(2 4 7 5 8 9 3 6 10 5 9 8 - 12 13 14 8 9 5 2 4 7 5 8 - 9 3 6 10 5 9 8 12 13 14 - 8 9 5 5)) (define *c* (make-vector 37)) -(for-each (lambda (i x) (vector-set! *c* i x)) - '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) - '(4 7 11 8 12 13 6 10 15 9 14 13 - 13 14 15 9 10 6 1 2 4 3 5 6 1 - 3 6 2 5 4 11 12 13 7 8 4 4)) (define *answer* '()) (define *final* '()) -(vector-set! *board* 5 0) - + (define (last-position) (do ((i 1 (+ i 1))) ((or (= i 16) (= 1 (vector-ref *board* i))) (if (= i 16) 0 i)))) -(define (try i depth) +(define (ttry i depth) (cond ((= depth 14) (let ((lp (last-position))) (if (not (member lp *final*)) @@ -63,7 +42,7 @@ (vector-set! *sequence* depth i) (do ((j 0 (+ j 1)) (depth (+ depth 1))) - ((or (= j 36) (try j depth)) #f)) + ((or (= j 36) (ttry j depth)) #f)) (vector-set! *board* (vector-ref *a* i) 1) (vector-set! *board* (vector-ref *b* i) 1) (vector-set! *board* (vector-ref *c* i) 0) '()) @@ -72,11 +51,33 @@ (define (gogogo i) (let ((*answer* '()) (*final* '())) - (try i 1))) + (ttry i 1))) + +(for-each (lambda (i x) (vector-set! *a* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 + 13 7 8 4 4 7 11 8 12 13 6 10 + 15 9 14 13 13 14 15 9 10 + 6 6)) +(for-each (lambda (i x) (vector-set! *b* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(2 4 7 5 8 9 3 6 10 5 9 8 + 12 13 14 8 9 5 2 4 7 5 8 + 9 3 6 10 5 9 8 12 13 14 + 8 9 5 5)) +(for-each (lambda (i x) (vector-set! *c* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(4 7 11 8 12 13 6 10 15 9 14 13 + 13 14 15 9 10 6 1 2 4 3 5 6 1 + 3 6 2 5 4 11 12 13 7 8 4 4)) +(vector-set! *board* 5 0) ;;; call: (gogogo 22)) -(time (let loop ((n 10000)) +(time (let loop ((n 100000)) (if (zero? n) 'done (begin