Merge branch 'master' of git:plt
This commit is contained in:
Matthias Felleisen
commit
2801ab2db0
|
|
@ -1904,6 +1904,8 @@
|
||||||
(syntax/loc stx (define (name) expr))
|
(syntax/loc stx (define (name) expr))
|
||||||
(list #'name))]
|
(list #'name))]
|
||||||
[(_ (name) expr ...)
|
[(_ (name) expr ...)
|
||||||
|
(and (identifier/non-kw? (syntax name))
|
||||||
|
(ok-definition-context))
|
||||||
(check-single-result-expr (syntax->list (syntax (expr ...)))
|
(check-single-result-expr (syntax->list (syntax (expr ...)))
|
||||||
#f
|
#f
|
||||||
stx
|
stx
|
||||||
|
|
|
||||||
|
|
@ -1154,9 +1154,6 @@ path/s is either such a string or a list of them.
|
||||||
"collects/racket/match" responsible (samth)
|
"collects/racket/match" responsible (samth)
|
||||||
"collects/racket/match.rkt" responsible (samth)
|
"collects/racket/match.rkt" responsible (samth)
|
||||||
"collects/racklog" responsible (jay)
|
"collects/racklog" responsible (jay)
|
||||||
"collects/raco" responsible (mflatt)
|
|
||||||
"collects/raco/main.rkt" drdr:command-line #f
|
|
||||||
"collects/raco/raco.rkt" drdr:command-line #f
|
|
||||||
"collects/rackunit" responsible (jay noel ryanc)
|
"collects/rackunit" responsible (jay noel ryanc)
|
||||||
"collects/rackunit/gui.rkt" responsible (ryanc) drdr:command-line (gracket-text "-t" *)
|
"collects/rackunit/gui.rkt" responsible (ryanc) drdr:command-line (gracket-text "-t" *)
|
||||||
"collects/rackunit/private/gui" responsible (ryanc)
|
"collects/rackunit/private/gui" responsible (ryanc)
|
||||||
|
|
@ -1167,6 +1164,9 @@ path/s is either such a string or a list of them.
|
||||||
"collects/rackunit/private/gui/rml.rkt" drdr:command-line (gracket-text "-t" *)
|
"collects/rackunit/private/gui/rml.rkt" drdr:command-line (gracket-text "-t" *)
|
||||||
"collects/rackunit/private/gui/view.rkt" drdr:command-line (gracket-text "-t" *)
|
"collects/rackunit/private/gui/view.rkt" drdr:command-line (gracket-text "-t" *)
|
||||||
"collects/rackunit/tool.rkt" responsible (ryanc) drdr:command-line (gracket-text "-t" *)
|
"collects/rackunit/tool.rkt" responsible (ryanc) drdr:command-line (gracket-text "-t" *)
|
||||||
|
"collects/raco" responsible (mflatt)
|
||||||
|
"collects/raco/main.rkt" drdr:command-line #f
|
||||||
|
"collects/raco/raco.rkt" drdr:command-line #f
|
||||||
"collects/reader" responsible (mflatt)
|
"collects/reader" responsible (mflatt)
|
||||||
"collects/readline" responsible (mflatt)
|
"collects/readline" responsible (mflatt)
|
||||||
"collects/redex" responsible (clklein)
|
"collects/redex" responsible (clklein)
|
||||||
|
|
@ -1470,31 +1470,93 @@ path/s is either such a string or a list of them.
|
||||||
"collects/tests/racket/beginner.rktl" drdr:command-line (racket "-f" *)
|
"collects/tests/racket/beginner.rktl" drdr:command-line (racket "-f" *)
|
||||||
"collects/tests/racket/benchmarks/common/auto.rkt" drdr:command-line (racket * "--" "racket" "ctak")
|
"collects/tests/racket/benchmarks/common/auto.rkt" drdr:command-line (racket * "--" "racket" "ctak")
|
||||||
"collects/tests/racket/benchmarks/common/conform.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/conform.rkt" drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/cpstack-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/cpstack-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/cpstack-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/ctak-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/ctak-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/ctak-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/ctak.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/ctak.rkt" drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/dderiv-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/dderiv-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/dderiv-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/deriv-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/deriv-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/deriv-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/destruct.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/destruct.rkt" drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/div-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/div-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/div-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/div.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/div.rkt" drdr:command-line (mzc *)
|
||||||
"collects/tests/racket/benchmarks/common/dynamic.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/dynamic.rkt" drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/dynamic2.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/dynamic2.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/fft-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/fft-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/fft-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/graphs-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/graphs-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/graphs-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/graphs.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/graphs.rkt" drdr:command-line (mzc *)
|
||||||
"collects/tests/racket/benchmarks/common/lattice.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/lattice.rkt" drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/lattice2-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/lattice2-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/lattice2-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/maze.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/maze.rkt" drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/maze2.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/maze2.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/mazefun-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/mazefun-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/mazefun-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/mazefun.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/mazefun.rkt" drdr:command-line (mzc *)
|
||||||
"collects/tests/racket/benchmarks/common/mk-bigloo.rktl" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/mk-bigloo.rktl" drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/mk-chicken.rktl" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/mk-chicken.rktl" drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/mk-gambit.rktl" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/mk-gambit.rktl" drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nestedloop-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nestedloop-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nestedloop-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/nestedloop.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/nestedloop.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/nfa-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nfa-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nfa-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nothing-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nothing-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nothing-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nqueens-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nqueens-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/nqueens-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/nqueens.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/nqueens.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/paraffins-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/paraffins-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/paraffins-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/paraffins.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/paraffins.rkt" drdr:command-line (mzc *)
|
||||||
"collects/tests/racket/benchmarks/common/peval.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/peval.rkt" drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/puzzle-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/puzzle-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/puzzle-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/r5rs-wrap.rktl" drdr:command-line (racket "-f" *)
|
"collects/tests/racket/benchmarks/common/r5rs-wrap.rktl" drdr:command-line (racket "-f" *)
|
||||||
"collects/tests/racket/benchmarks/common/scheme.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/scheme.rkt" drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/scheme2.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/scheme2.rkt" drdr:command-line (mzc *)
|
||||||
"collects/tests/racket/benchmarks/common/sort1.rkt" drdr:command-line #f
|
"collects/tests/racket/benchmarks/common/sort1.rkt" drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/tak-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/tak-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/tak-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/tak.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/tak.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/takl-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/takl-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/takl-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/takl.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/takl.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/takr-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/takr-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/takr-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/takr.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/takr.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/takr2-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/takr2-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/takr2-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/common/takr2.rkt" drdr:command-line (mzc *)
|
"collects/tests/racket/benchmarks/common/takr2.rkt" drdr:command-line (mzc *)
|
||||||
|
"collects/tests/racket/benchmarks/common/triangle-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/triangle-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/triangle-typed.rktl" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
|
"collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
|
||||||
"collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *)
|
"collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *)
|
||||||
"collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *)
|
"collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *)
|
||||||
"collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test")
|
"collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test")
|
||||||
|
|
|
||||||
|
|
@ -38,6 +38,32 @@
|
||||||
(current-inspector) #f '(0))])
|
(current-inspector) #f '(0))])
|
||||||
make-))
|
make-))
|
||||||
|
|
||||||
|
(define (first-requiring-module id self)
|
||||||
|
(define (resolved-module-path->module-path rmp)
|
||||||
|
(cond
|
||||||
|
[(not rmp) 'top-level]
|
||||||
|
[(path? (resolved-module-path-name rmp))
|
||||||
|
`(file ,(path->string (resolved-module-path-name rmp)))]
|
||||||
|
[(symbol? (resolved-module-path-name rmp))
|
||||||
|
`(module ,(resolved-module-path-name rmp))]))
|
||||||
|
;; Here we get the module-path-index corresponding to the identifier.
|
||||||
|
;; We know we can split it at least once, because the contracted identifier
|
||||||
|
;; we've provided must have been required. If the second returned value is #f,
|
||||||
|
;; we just fall back on the old behavior. If we split again without getting
|
||||||
|
;; either "self", that is, the first value returned is not #f, then we should
|
||||||
|
;; use the second mpi result as the module that required the value.
|
||||||
|
(let ([mpi (syntax-source-module id)])
|
||||||
|
(let*-values ([(first-mp second-mpi)
|
||||||
|
(module-path-index-split mpi)]
|
||||||
|
[(second-mp third-mpi)
|
||||||
|
(if second-mpi
|
||||||
|
(module-path-index-split second-mpi)
|
||||||
|
(values #f #f))])
|
||||||
|
(if second-mp
|
||||||
|
(resolved-module-path->module-path
|
||||||
|
(module-path-index-resolve second-mpi))
|
||||||
|
self))))
|
||||||
|
|
||||||
(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
|
(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
|
||||||
(make-set!-transformer
|
(make-set!-transformer
|
||||||
(let ([saved-id-table (make-hasheq)])
|
(let ([saved-id-table (make-hasheq)])
|
||||||
|
|
@ -52,21 +78,13 @@
|
||||||
(with-syntax ([contract-id contract-id]
|
(with-syntax ([contract-id contract-id]
|
||||||
[id id]
|
[id id]
|
||||||
[external-id external-id]
|
[external-id external-id]
|
||||||
[pos-module-source pos-module-source]
|
[pos-module-source pos-module-source])
|
||||||
[id-ref (syntax-case stx (set!)
|
|
||||||
[(set! whatever e)
|
|
||||||
id] ;; just avoid an error here, signal the error later
|
|
||||||
[(id . x)
|
|
||||||
#'id]
|
|
||||||
[id
|
|
||||||
(identifier? #'id)
|
|
||||||
#'id])])
|
|
||||||
(syntax-local-introduce
|
(syntax-local-introduce
|
||||||
(syntax-local-lift-expression
|
(syntax-local-lift-expression
|
||||||
#`(contract contract-id
|
#`(contract contract-id
|
||||||
id
|
id
|
||||||
pos-module-source
|
pos-module-source
|
||||||
(quote-module-path)
|
(first-requiring-module (quote-syntax id) (quote-module-path))
|
||||||
'external-id
|
'external-id
|
||||||
(quote-srcloc id))))))])
|
(quote-srcloc id))))))])
|
||||||
(when key
|
(when key
|
||||||
|
|
|
||||||
|
|
@ -19,7 +19,11 @@ Racket installation.
|
||||||
you'd like to compile it to bytecode, along with all of its
|
you'd like to compile it to bytecode, along with all of its
|
||||||
dependencies, so that it loads more quickly, then run
|
dependencies, so that it loads more quickly, then run
|
||||||
|
|
||||||
@commandline{raco make take-over-the-world.rkt}}
|
@commandline{raco make take-over-the-world.rkt}
|
||||||
|
|
||||||
|
The bytecode file is written as @filepath{take-over-the-world_rkt.zo}
|
||||||
|
in a @filepath{compiled} subdirectory; @index[".zo"]{@filepath{.zo}}
|
||||||
|
is the file suffix for a bytecode file.}
|
||||||
|
|
||||||
|
|
||||||
@item{@exec{raco setup} manages a Racket installation, including
|
@item{@exec{raco setup} manages a Racket installation, including
|
||||||
|
|
|
||||||
|
|
@ -653,6 +653,12 @@ Like @cpp{scheme_malloc}, but in 3m, the type tag determines how the
|
||||||
Like @cpp{scheme_malloc}, but in 3m, pointers are allowed to
|
Like @cpp{scheme_malloc}, but in 3m, pointers are allowed to
|
||||||
reference the middle of the object; see @secref["im:memoryalloc"].}
|
reference the middle of the object; see @secref["im:memoryalloc"].}
|
||||||
|
|
||||||
|
@function[(void* scheme_malloc_atomic_allow_interior
|
||||||
|
[size_t n])]{
|
||||||
|
|
||||||
|
Like @cpp{scheme_malloc_atomic}, but in 3m, pointers are allowed to
|
||||||
|
reference the middle of the object; see @secref["im:memoryalloc"].}
|
||||||
|
|
||||||
@function[(char* scheme_strdup
|
@function[(char* scheme_strdup
|
||||||
[char* str])]{
|
[char* str])]{
|
||||||
|
|
||||||
|
|
@ -807,6 +813,21 @@ difference between the actual stack start and the reported stack base,
|
||||||
in addition to the margin needed for detecting and handling stack
|
in addition to the margin needed for detecting and handling stack
|
||||||
overflow.}
|
overflow.}
|
||||||
|
|
||||||
|
@function[(void scheme_register_tls_space
|
||||||
|
[void* ptr]
|
||||||
|
[int tls_index])]{
|
||||||
|
|
||||||
|
Only available under Windows; registers @var{ptr} as the address of a
|
||||||
|
thread-local pointer variable that is declared in the main
|
||||||
|
executable. The variable's storage will be used to implement
|
||||||
|
thread-local storage within the Racket run-time. See
|
||||||
|
@secref["embedding"].
|
||||||
|
|
||||||
|
The @var{tls_index} argument must be @cpp{0}. It is currently
|
||||||
|
ignored, but a future version may use the argument to allow
|
||||||
|
declaration of the thread-local variable in a dynamically linked
|
||||||
|
DLL.}
|
||||||
|
|
||||||
@function[(void scheme_register_static
|
@function[(void scheme_register_static
|
||||||
[void* ptr]
|
[void* ptr]
|
||||||
[long size])]{
|
[long size])]{
|
||||||
|
|
|
||||||
|
|
@ -359,7 +359,23 @@ To embed Racket CGC in a program, follow these steps:
|
||||||
@cppi{scheme_basic_env} and passing the result to the function
|
@cppi{scheme_basic_env} and passing the result to the function
|
||||||
provided to @cpp{scheme_main_setup}. (The
|
provided to @cpp{scheme_main_setup}. (The
|
||||||
@cpp{scheme_main_stack_setup} trampoline registers the C stack with
|
@cpp{scheme_main_stack_setup} trampoline registers the C stack with
|
||||||
the memory manager without creating a namespace.)}
|
the memory manager without creating a namespace.)
|
||||||
|
|
||||||
|
Under Windows, when support for parallelism is enabled in the Racket
|
||||||
|
build (as is the default), then before calling
|
||||||
|
@cpp{scheme_main_setup}, your embedding application must first call
|
||||||
|
@cppi{scheme_register_tls_space}:
|
||||||
|
|
||||||
|
@verbatim[#:indent 2]{
|
||||||
|
scheme_register_tls_space(&tls_space, 0);
|
||||||
|
}
|
||||||
|
|
||||||
|
where @cpp{tls_space} is declared as a thread-local pointer variable
|
||||||
|
in the main executable (i.e., not in a dynamically linked DLL):
|
||||||
|
|
||||||
|
@verbatim[#:indent 2]{
|
||||||
|
static __declspec(thread) void *tls_space;
|
||||||
|
}}
|
||||||
|
|
||||||
@item{Configure the namespace by adding module declarations. The
|
@item{Configure the namespace by adding module declarations. The
|
||||||
initial namespace contains declarations only for a few primitive
|
initial namespace contains declarations only for a few primitive
|
||||||
|
|
|
||||||
|
|
@ -10,6 +10,7 @@
|
||||||
(htdp-syntax-test #'(define x))
|
(htdp-syntax-test #'(define x))
|
||||||
(htdp-syntax-test #'(define x 10 12))
|
(htdp-syntax-test #'(define x 10 12))
|
||||||
(htdp-syntax-test #'(define (10 y) 12))
|
(htdp-syntax-test #'(define (10 y) 12))
|
||||||
|
(htdp-syntax-test #'(define (10) 12))
|
||||||
(htdp-syntax-test #'(define ("x" y) 12))
|
(htdp-syntax-test #'(define ("x" y) 12))
|
||||||
(htdp-syntax-test #'(define (y 10) 12))
|
(htdp-syntax-test #'(define (y 10) 12))
|
||||||
(htdp-syntax-test #'(define (y "x") 12))
|
(htdp-syntax-test #'(define (y "x") 12))
|
||||||
|
|
|
||||||
|
|
@ -397,6 +397,26 @@ exec racket -qu "$0" ${1+"$@"}
|
||||||
clean-up-zo
|
clean-up-zo
|
||||||
(append '(nucleic2)
|
(append '(nucleic2)
|
||||||
mutable-pair-progs))
|
mutable-pair-progs))
|
||||||
|
(make-impl 'typed-scheme
|
||||||
|
void
|
||||||
|
mk-racket
|
||||||
|
(lambda (bm)
|
||||||
|
(system (format "racket -u ~a-typed-non-optimizing.rkt" bm)))
|
||||||
|
extract-racket-times
|
||||||
|
clean-up-zo
|
||||||
|
(append mutable-pair-progs
|
||||||
|
'(dynamic2 earley maze2 nboyer nucleic2 sboyer
|
||||||
|
scheme2)))
|
||||||
|
(make-impl 'typed-scheme-optimizing
|
||||||
|
void
|
||||||
|
mk-racket
|
||||||
|
(lambda (bm)
|
||||||
|
(system (format "racket -u ~a-typed-optimizing.rkt" bm)))
|
||||||
|
extract-racket-times
|
||||||
|
clean-up-zo
|
||||||
|
(append mutable-pair-progs
|
||||||
|
'(dynamic2 earley maze2 nboyer nucleic2 sboyer
|
||||||
|
scheme2)))
|
||||||
(make-impl 'chicken
|
(make-impl 'chicken
|
||||||
void
|
void
|
||||||
(run-mk "mk-chicken.rktl")
|
(run-mk "mk-chicken.rktl")
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module cpstack-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module cpstack-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
37
collects/tests/racket/benchmarks/common/cpstack-typed.rktl
Normal file
37
collects/tests/racket/benchmarks/common/cpstack-typed.rktl
Normal file
|
|
@ -0,0 +1,37 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: cpstak.sch
|
||||||
|
; Description: continuation-passing version of TAK
|
||||||
|
; Author: Will Clinger
|
||||||
|
; Created: 20-Aug-87
|
||||||
|
; Modified: 3-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
|
||||||
|
;;; A good test of first class procedures and tail recursion.
|
||||||
|
|
||||||
|
(: cpstak (Integer Integer Integer -> Integer))
|
||||||
|
(define (cpstak x y z)
|
||||||
|
(: tak (Integer Integer Integer (Integer -> Integer) -> Integer))
|
||||||
|
(define (tak x y z k)
|
||||||
|
(if (not (< y x))
|
||||||
|
(k z)
|
||||||
|
(tak (- x 1)
|
||||||
|
y
|
||||||
|
z
|
||||||
|
(lambda (v1)
|
||||||
|
(tak (- y 1)
|
||||||
|
z
|
||||||
|
x
|
||||||
|
(lambda (v2)
|
||||||
|
(tak (- z 1)
|
||||||
|
x
|
||||||
|
y
|
||||||
|
(lambda (v3)
|
||||||
|
(tak v1 v2 v3 k)))))))))
|
||||||
|
(tak x y z (lambda (a) a)))
|
||||||
|
|
||||||
|
;;; call: (cpstak 18 12 6)
|
||||||
|
|
||||||
|
(time (cpstak 18 12 2))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module ctak-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module ctak-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
65
collects/tests/racket/benchmarks/common/ctak-typed.rktl
Normal file
65
collects/tests/racket/benchmarks/common/ctak-typed.rktl
Normal file
|
|
@ -0,0 +1,65 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: ctak.sch
|
||||||
|
; Description: The ctak benchmark
|
||||||
|
; Author: Richard Gabriel
|
||||||
|
; Created: 5-Apr-85
|
||||||
|
; Modified: 10-Apr-85 14:53:02 (Bob Shaw)
|
||||||
|
; 24-Jul-87 (Will Clinger)
|
||||||
|
; 3-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
; The original version of this benchmark used a continuation mechanism that
|
||||||
|
; is less powerful than call-with-current-continuation and also relied on
|
||||||
|
; dynamic binding, which is not provided in standard Scheme. Since the
|
||||||
|
; intent of the benchmark seemed to be to test non-local exits, the dynamic
|
||||||
|
; binding has been replaced here by lexical binding.
|
||||||
|
|
||||||
|
; For Scheme the comment that follows should read:
|
||||||
|
;;; CTAK -- A version of the TAK procedure that uses continuations.
|
||||||
|
|
||||||
|
;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility.
|
||||||
|
|
||||||
|
(: ctak (Integer Integer Integer -> Integer))
|
||||||
|
(define (ctak x y z)
|
||||||
|
((inst call-with-current-continuation Integer Integer)
|
||||||
|
(lambda (k)
|
||||||
|
(ctak-aux k x y z))))
|
||||||
|
|
||||||
|
(: ctak-aux ((Integer -> Integer) Integer Integer Integer -> Integer))
|
||||||
|
(define (ctak-aux k x y z)
|
||||||
|
(cond ((not (< y x)) ;xy
|
||||||
|
(k z))
|
||||||
|
(else ((inst call-with-current-continuation Integer Integer)
|
||||||
|
(lambda (dummy)
|
||||||
|
(ctak-aux
|
||||||
|
k
|
||||||
|
((inst call-with-current-continuation Integer Integer)
|
||||||
|
(lambda (k)
|
||||||
|
(ctak-aux k
|
||||||
|
(- x 1)
|
||||||
|
y
|
||||||
|
z)))
|
||||||
|
((inst call-with-current-continuation Integer Integer)
|
||||||
|
(lambda (k)
|
||||||
|
(ctak-aux k
|
||||||
|
(- y 1)
|
||||||
|
z
|
||||||
|
x)))
|
||||||
|
((inst call-with-current-continuation Integer Integer)
|
||||||
|
(lambda (k)
|
||||||
|
(ctak-aux k
|
||||||
|
(- z 1)
|
||||||
|
x
|
||||||
|
y)))))))))
|
||||||
|
|
||||||
|
;;; call: (ctak 18 12 6)
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time (let: loop : Integer
|
||||||
|
((n : Integer 8) (v : Integer 0))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1)
|
||||||
|
(ctak 18 12 (if input 6 0)))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module dderiv-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module dderiv-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
115
collects/tests/racket/benchmarks/common/dderiv-typed.rktl
Normal file
115
collects/tests/racket/benchmarks/common/dderiv-typed.rktl
Normal file
|
|
@ -0,0 +1,115 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: dderiv.sch
|
||||||
|
; Description: DDERIV benchmark from the Gabriel tests
|
||||||
|
; Author: Vaughan Pratt
|
||||||
|
; Created: 8-Apr-85
|
||||||
|
; Modified: 10-Apr-85 14:53:29 (Bob Shaw)
|
||||||
|
; 23-Jul-87 (Will Clinger)
|
||||||
|
; 9-Feb-88 (Will Clinger)
|
||||||
|
; 3-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme (but see note below)
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
; Note: This benchmark uses property lists. The procedures that must
|
||||||
|
; be supplied are get and put, where (put x y z) is equivalent to Common
|
||||||
|
; Lisp's (setf (get x y) z).
|
||||||
|
|
||||||
|
;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
|
||||||
|
|
||||||
|
;;; This benchmark is a variant of the simple symbolic derivative program
|
||||||
|
;;; (DERIV). The main change is that it is `table-driven.' Instead of using a
|
||||||
|
;;; large COND that branches on the CAR of the expression, this program finds
|
||||||
|
;;; the code that will take the derivative on the property list of the atom in
|
||||||
|
;;; the CAR position. So, when the expression is (+ . <rest>), the code
|
||||||
|
;;; stored under the atom '+ with indicator DERIV will take <rest> and
|
||||||
|
;;; return the derivative for '+. The way that MacLisp does this is with the
|
||||||
|
;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
|
||||||
|
;;; atomic name in that it expects an argument list and the compiler compiles
|
||||||
|
;;; code, but the name of the function with that code is stored on the
|
||||||
|
;;; property list of FOO under the indicator BAR, in this case. You may have
|
||||||
|
;;; to do something like:
|
||||||
|
|
||||||
|
;;; :property keyword is not Common Lisp.
|
||||||
|
|
||||||
|
; Returns the wrong answer for quotients.
|
||||||
|
; Fortunately these aren't used in the benchmark.
|
||||||
|
|
||||||
|
(define-type Plist (Listof (Pair Symbol ((Listof Deriv) -> Deriv))))
|
||||||
|
|
||||||
|
(: pg-alist Plist)
|
||||||
|
(define pg-alist '())
|
||||||
|
(: put (Symbol Symbol ((Listof Deriv) -> Deriv) -> Void))
|
||||||
|
(define (put sym d what)
|
||||||
|
(set! pg-alist (cons (cons sym what) pg-alist)))
|
||||||
|
(: get (Symbol Symbol -> (U ((Listof Deriv) -> Deriv) #f)))
|
||||||
|
(define (get sym d)
|
||||||
|
(cond ((assq sym pg-alist) => cdr)
|
||||||
|
(else #f)))
|
||||||
|
|
||||||
|
(define-type Deriv (Rec Deriv (U Number
|
||||||
|
Symbol
|
||||||
|
(Pair (U '+ '- '* '/)
|
||||||
|
(Listof Deriv)))))
|
||||||
|
|
||||||
|
(: dderiv-aux (Deriv -> Deriv))
|
||||||
|
(define (dderiv-aux a)
|
||||||
|
(list '/ (dderiv a) a))
|
||||||
|
|
||||||
|
(: f+dderiv ((Listof Deriv) -> Deriv))
|
||||||
|
(define (f+dderiv a)
|
||||||
|
(cons '+ (map dderiv a)))
|
||||||
|
|
||||||
|
(: f-dderiv ((Listof Deriv) -> Deriv))
|
||||||
|
(define (f-dderiv a)
|
||||||
|
(cons '- (map dderiv a)))
|
||||||
|
|
||||||
|
(: *dderiv ((Listof Deriv) -> Deriv))
|
||||||
|
(define (*dderiv a)
|
||||||
|
(list '*
|
||||||
|
(ann (cons '* a) Deriv)
|
||||||
|
(ann (cons '+ (map dderiv-aux a)) Deriv)))
|
||||||
|
|
||||||
|
(: /dderiv ((Listof Deriv) -> Deriv))
|
||||||
|
(define (/dderiv a)
|
||||||
|
(list '-
|
||||||
|
(list '/
|
||||||
|
(dderiv (car a))
|
||||||
|
(cadr a))
|
||||||
|
(list '/
|
||||||
|
(car a)
|
||||||
|
(list '*
|
||||||
|
(cadr a)
|
||||||
|
(cadr a)
|
||||||
|
(dderiv (cadr a))))))
|
||||||
|
|
||||||
|
(: dderiv (Deriv -> Deriv))
|
||||||
|
(define (dderiv a)
|
||||||
|
(cond
|
||||||
|
((not (pair? a))
|
||||||
|
(cond ((eq? a 'x) 1) (else 0)))
|
||||||
|
(else (let ((dderiv (get (car a) 'dderiv)))
|
||||||
|
(cond (dderiv (dderiv (cdr a)))
|
||||||
|
(else 'error))))))
|
||||||
|
|
||||||
|
(: run ( -> Void))
|
||||||
|
(define (run)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i 50000))
|
||||||
|
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||||
|
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||||
|
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||||
|
(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))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module deriv-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module deriv-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
68
collects/tests/racket/benchmarks/common/deriv-typed.rktl
Normal file
68
collects/tests/racket/benchmarks/common/deriv-typed.rktl
Normal file
|
|
@ -0,0 +1,68 @@
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: deriv.sch
|
||||||
|
; Description: The DERIV benchmark from the Gabriel tests.
|
||||||
|
; Author: Vaughan Pratt
|
||||||
|
; Created: 8-Apr-85
|
||||||
|
; Modified: 10-Apr-85 14:53:50 (Bob Shaw)
|
||||||
|
; 23-Jul-87 (Will Clinger)
|
||||||
|
; 9-Feb-88 (Will Clinger)
|
||||||
|
; 3-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
|
||||||
|
;;; It uses a simple subset of Lisp and does a lot of CONSing.
|
||||||
|
|
||||||
|
; Returns the wrong answer for quotients.
|
||||||
|
; Fortunately these aren't used in the benchmark.
|
||||||
|
|
||||||
|
(define-type Deriv (Rec Deriv (U Number
|
||||||
|
Symbol
|
||||||
|
(Pair (U '+ '- '* '/)
|
||||||
|
(Listof Deriv)))))
|
||||||
|
|
||||||
|
(: deriv-aux (Deriv -> Deriv))
|
||||||
|
(define (deriv-aux a) (list '/ (deriv a) a))
|
||||||
|
|
||||||
|
(: deriv (Deriv -> Deriv))
|
||||||
|
(define (deriv a)
|
||||||
|
(cond
|
||||||
|
((not (pair? a))
|
||||||
|
(cond ((eq? a 'x) 1) (else 0)))
|
||||||
|
((eq? (car a) '+)
|
||||||
|
(cons '+ (map deriv (cdr a))))
|
||||||
|
((eq? (car a) '-)
|
||||||
|
(cons '- (map deriv
|
||||||
|
(cdr a))))
|
||||||
|
((eq? (car a) '*)
|
||||||
|
(list '*
|
||||||
|
a
|
||||||
|
(ann (cons '+ (map deriv-aux (cdr a))) Deriv)))
|
||||||
|
((eq? (car a) '/)
|
||||||
|
(list '-
|
||||||
|
(list '/
|
||||||
|
(deriv (cadr a))
|
||||||
|
(caddr a))
|
||||||
|
(list '/
|
||||||
|
(cadr a)
|
||||||
|
(list '*
|
||||||
|
(caddr a)
|
||||||
|
(caddr a)
|
||||||
|
(deriv (caddr a))))))
|
||||||
|
(else 'error)))
|
||||||
|
|
||||||
|
(: run ( -> Void))
|
||||||
|
(define (run)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i 50000))
|
||||||
|
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||||
|
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||||
|
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||||
|
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||||
|
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
|
||||||
|
|
||||||
|
;;; call: (run)
|
||||||
|
|
||||||
|
(time (run))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module div-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module div-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
67
collects/tests/racket/benchmarks/common/div-typed.rktl
Normal file
67
collects/tests/racket/benchmarks/common/div-typed.rktl
Normal file
|
|
@ -0,0 +1,67 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: div.sch
|
||||||
|
; Description: DIV benchmarks
|
||||||
|
; Author: Richard Gabriel
|
||||||
|
; Created: 8-Apr-85
|
||||||
|
; Modified: 19-Jul-85 18:28:01 (Bob Shaw)
|
||||||
|
; 23-Jul-87 (Will Clinger)
|
||||||
|
; 3-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
|
||||||
|
;;; This file contains a recursive as well as an iterative test.
|
||||||
|
|
||||||
|
(: create-n (Integer -> (Listof Any)))
|
||||||
|
(define (create-n n)
|
||||||
|
(do ((n n (- n 1))
|
||||||
|
(a '() (cons '() a)))
|
||||||
|
((= n 0) a)))
|
||||||
|
|
||||||
|
(: *ll* (Listof Any))
|
||||||
|
(define *ll* (create-n 200))
|
||||||
|
|
||||||
|
(: iterative-div2 ((Listof Any) -> (Listof Any)))
|
||||||
|
(define (iterative-div2 l)
|
||||||
|
(do ((l l (cddr l))
|
||||||
|
(a '() (cons (car l) a)))
|
||||||
|
((null? l) a)))
|
||||||
|
|
||||||
|
(: recursive-div2 ((Listof Any) -> (Listof Any)))
|
||||||
|
(define (recursive-div2 l)
|
||||||
|
(cond ((null? l) '())
|
||||||
|
(else (cons (car l) (recursive-div2 (cddr l))))))
|
||||||
|
|
||||||
|
(: test-1 ((Listof Any) -> (Listof Any)))
|
||||||
|
(define (test-1 l)
|
||||||
|
(do: : (Listof Any)
|
||||||
|
((i : Integer 3000 (- i 1)))
|
||||||
|
((= i 0) '())
|
||||||
|
(iterative-div2 l)
|
||||||
|
(iterative-div2 l)
|
||||||
|
(iterative-div2 l)
|
||||||
|
(iterative-div2 l)))
|
||||||
|
|
||||||
|
(: test-2 ((Listof Any) -> (Listof Any)))
|
||||||
|
(define (test-2 l)
|
||||||
|
(do: : (Listof Any)
|
||||||
|
((i : Integer 3000 (- i 1)))
|
||||||
|
((= i 0) '())
|
||||||
|
(recursive-div2 l)
|
||||||
|
(recursive-div2 l)
|
||||||
|
(recursive-div2 l)
|
||||||
|
(recursive-div2 l)))
|
||||||
|
|
||||||
|
;;; for the iterative test call: (test-1 *ll*)
|
||||||
|
;;; for the recursive test call: (test-2 *ll*)
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time (let: loop : (U Integer (Listof Any))
|
||||||
|
((n : Integer 10) (v : (U Integer (Listof Any)) 0))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1)
|
||||||
|
(cons
|
||||||
|
(test-1 (if input *ll* '()))
|
||||||
|
(test-2 (if input *ll* '()))))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module fft-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module fft-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
127
collects/tests/racket/benchmarks/common/fft-typed.rktl
Normal file
127
collects/tests/racket/benchmarks/common/fft-typed.rktl
Normal file
|
|
@ -0,0 +1,127 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: fft.cl
|
||||||
|
; Description: FFT benchmark from the Gabriel tests.
|
||||||
|
; Author: Harry Barrow
|
||||||
|
; Created: 8-Apr-85
|
||||||
|
; Modified: 6-May-85 09:29:22 (Bob Shaw)
|
||||||
|
; 11-Aug-87 (Will Clinger)
|
||||||
|
; 4-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(: pi Complex)
|
||||||
|
(define pi (atan 0 -1))
|
||||||
|
|
||||||
|
;;; FFT -- This is an FFT benchmark written by Harry Barrow.
|
||||||
|
;;; It tests a variety of floating point operations,
|
||||||
|
;;; including array references.
|
||||||
|
|
||||||
|
(: *re* (Vectorof Complex))
|
||||||
|
(define *re* (make-vector 1025 0.0))
|
||||||
|
|
||||||
|
(: *im* (Vectorof Complex))
|
||||||
|
(define *im* (make-vector 1025 0.0))
|
||||||
|
|
||||||
|
(: fft ((Vectorof Complex) (Vectorof Complex) -> Boolean))
|
||||||
|
(define (fft areal aimag)
|
||||||
|
(let: ((ar : (Vectorof Complex) (vector))
|
||||||
|
(ai : (Vectorof Complex) (vector))
|
||||||
|
(i : Integer 0)
|
||||||
|
(j : Integer 0)
|
||||||
|
(k : Integer 0)
|
||||||
|
(m : Integer 0)
|
||||||
|
(n : Integer 0)
|
||||||
|
(le : Integer 0)
|
||||||
|
(le1 : Integer 0)
|
||||||
|
(ip : Integer 0)
|
||||||
|
(nv2 : Integer 0)
|
||||||
|
(nm1 : Integer 0)
|
||||||
|
(ur : Complex 0)
|
||||||
|
(ui : Complex 0)
|
||||||
|
(wr : Complex 0)
|
||||||
|
(wi : Complex 0)
|
||||||
|
(tr : Complex 0)
|
||||||
|
(ti : Complex 0))
|
||||||
|
;; initialize
|
||||||
|
(set! ar areal)
|
||||||
|
(set! ai aimag)
|
||||||
|
(set! n (vector-length ar))
|
||||||
|
(set! n (- n 1))
|
||||||
|
(set! nv2 (quotient n 2))
|
||||||
|
(set! nm1 (- n 1))
|
||||||
|
(set! m 0) ;compute m = log(n)
|
||||||
|
(set! i 1)
|
||||||
|
(let loop ()
|
||||||
|
(if (< i n)
|
||||||
|
(begin (set! m (+ m 1))
|
||||||
|
(set! i (+ i i))
|
||||||
|
(loop))
|
||||||
|
#t))
|
||||||
|
(cond ((not (= n (expt 2 m)))
|
||||||
|
(error "array size not a power of two.")))
|
||||||
|
;; interchange elements in bit-reversed order
|
||||||
|
(set! j 1)
|
||||||
|
(set! i 1)
|
||||||
|
(let l3 ()
|
||||||
|
(cond ((< i j)
|
||||||
|
(set! tr (vector-ref ar j))
|
||||||
|
(set! ti (vector-ref ai j))
|
||||||
|
(vector-set! ar j (vector-ref ar i))
|
||||||
|
(vector-set! ai j (vector-ref ai i))
|
||||||
|
(vector-set! ar i tr)
|
||||||
|
(vector-set! ai i ti)))
|
||||||
|
(set! k nv2)
|
||||||
|
(let l6 ()
|
||||||
|
(cond ((< k j)
|
||||||
|
(set! j (- j k))
|
||||||
|
(set! k (quotient k 2))
|
||||||
|
(l6))))
|
||||||
|
(set! j (+ j k))
|
||||||
|
(set! i (+ i 1))
|
||||||
|
(cond ((< i n)
|
||||||
|
(l3))))
|
||||||
|
(do: : Null
|
||||||
|
((l : Integer 1 (+ l 1))) ;loop thru stages (syntax converted
|
||||||
|
((> l m) '()) ; from old MACLISP style \bs)
|
||||||
|
(set! le (expt 2 l))
|
||||||
|
(set! le1 (quotient le 2))
|
||||||
|
(set! ur 1.0)
|
||||||
|
(set! ui 0.)
|
||||||
|
(set! wr (cos (/ pi le1)))
|
||||||
|
(set! wi (sin (/ pi le1)))
|
||||||
|
;; loop thru butterflies
|
||||||
|
(do: : Null
|
||||||
|
((j : Integer 1 (+ j 1)))
|
||||||
|
((> j le1) '())
|
||||||
|
;; do a butterfly
|
||||||
|
(do: : Null
|
||||||
|
((i : Integer j (+ i le)))
|
||||||
|
((> i n) '())
|
||||||
|
(set! ip (+ i le1))
|
||||||
|
(set! tr (- (* (vector-ref ar ip) ur)
|
||||||
|
(* (vector-ref ai ip) ui)))
|
||||||
|
(set! ti (+ (* (vector-ref ar ip) ui)
|
||||||
|
(* (vector-ref ai ip) ur)))
|
||||||
|
(vector-set! ar ip (- (vector-ref ar i) tr))
|
||||||
|
(vector-set! ai ip (- (vector-ref ai i) ti))
|
||||||
|
(vector-set! ar i (+ (vector-ref ar i) tr))
|
||||||
|
(vector-set! ai i (+ (vector-ref ai i) ti))))
|
||||||
|
(set! tr (- (* ur wr) (* ui wi)))
|
||||||
|
(set! ti (+ (* ur wi) (* ui wr)))
|
||||||
|
(set! ur tr)
|
||||||
|
(set! ui ti))
|
||||||
|
#t))
|
||||||
|
|
||||||
|
;;; the timer which does 10 calls on fft
|
||||||
|
|
||||||
|
(: fft-bench ( -> Null))
|
||||||
|
(define (fft-bench)
|
||||||
|
(do: : Null
|
||||||
|
((ntimes : Integer 0 (+ ntimes 1)))
|
||||||
|
((= ntimes 1000) '())
|
||||||
|
(fft *re* *im*)))
|
||||||
|
|
||||||
|
;;; call: (fft-bench)
|
||||||
|
|
||||||
|
(time (fft-bench))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module graphs-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module graphs-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
719
collects/tests/racket/benchmarks/common/graphs-typed.rktl
Normal file
719
collects/tests/racket/benchmarks/common/graphs-typed.rktl
Normal file
|
|
@ -0,0 +1,719 @@
|
||||||
|
; Modified 2 March 1997 by Will Clinger to add graphs-benchmark
|
||||||
|
; and to expand the four macros below.
|
||||||
|
; Modified 11 June 1997 by Will Clinger to eliminate assertions
|
||||||
|
; and to replace a use of "recur" with a named let.
|
||||||
|
; Modified 4 May 2010 by Vincent St-Amour to get rid of one-armed ifs
|
||||||
|
; Modified 10 May 2010 by Vincent St-Amour to convert to Typed Scheme
|
||||||
|
;
|
||||||
|
; Performance note: (graphs-benchmark 7) allocates
|
||||||
|
; 34509143 pairs
|
||||||
|
; 389625 vectors with 2551590 elements
|
||||||
|
; 56653504 closures (not counting top level and known procedures)
|
||||||
|
|
||||||
|
; End of new code.
|
||||||
|
|
||||||
|
;;; ==== std.ss ====
|
||||||
|
|
||||||
|
; (define-syntax assert
|
||||||
|
; (syntax-rules ()
|
||||||
|
; ((assert test info-rest ...)
|
||||||
|
; #f)))
|
||||||
|
;
|
||||||
|
; (define-syntax deny
|
||||||
|
; (syntax-rules ()
|
||||||
|
; ((deny test info-rest ...)
|
||||||
|
; #f)))
|
||||||
|
;
|
||||||
|
; (define-syntax when
|
||||||
|
; (syntax-rules ()
|
||||||
|
; ((when test e-first e-rest ...)
|
||||||
|
; (if test
|
||||||
|
; (begin e-first
|
||||||
|
; e-rest ...)))))
|
||||||
|
;
|
||||||
|
; (define-syntax unless
|
||||||
|
; (syntax-rules ()
|
||||||
|
; ((unless test e-first e-rest ...)
|
||||||
|
; (if (not test)
|
||||||
|
; (begin e-first
|
||||||
|
; e-rest ...)))))
|
||||||
|
|
||||||
|
;;; ==== util.ss ====
|
||||||
|
|
||||||
|
|
||||||
|
; Fold over list elements, associating to the left.
|
||||||
|
(: fold (All (X Y) ((Listof X) (X Y -> Y) Y -> Y)))
|
||||||
|
(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 indices to desired vector elements, create
|
||||||
|
; and return the vector.
|
||||||
|
(: proc->vector (All (X) (Integer (Integer -> X) -> (Vectorof X))))
|
||||||
|
(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 ; [wdc - was when]
|
||||||
|
(vector-set! x i (f i))
|
||||||
|
(loop (+ i 1)))
|
||||||
|
#t))
|
||||||
|
x))))
|
||||||
|
|
||||||
|
(: vector-fold (All (X Y) ((Vectorof X) (X Y -> Y) Y -> Y)))
|
||||||
|
(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)))))
|
||||||
|
|
||||||
|
(: vec-map (All (X Y) ((Vectorof X) (X -> Y) -> (Vectorof Y))))
|
||||||
|
(define vec-map
|
||||||
|
(lambda (vec proc)
|
||||||
|
(proc->vector (vector-length vec)
|
||||||
|
(lambda: ((i : Integer))
|
||||||
|
(proc (vector-ref vec i))))))
|
||||||
|
|
||||||
|
; Given limit, return the list 0, 1, ..., limit-1.
|
||||||
|
(: giota (Integer -> (Listof Integer)))
|
||||||
|
(define giota
|
||||||
|
(lambda (limit)
|
||||||
|
'(assert (and (integer? limit)
|
||||||
|
(exact? limit)
|
||||||
|
(>= limit 0))
|
||||||
|
limit)
|
||||||
|
(let: _-*- : (Listof Integer)
|
||||||
|
((limit : Integer
|
||||||
|
limit)
|
||||||
|
(res : (Listof Integer)
|
||||||
|
'()))
|
||||||
|
(if (zero? limit)
|
||||||
|
res
|
||||||
|
(let ((limit
|
||||||
|
(- limit 1)))
|
||||||
|
(_-*- limit
|
||||||
|
(cons limit res)))))))
|
||||||
|
|
||||||
|
; Fold over the integers [0, limit).
|
||||||
|
(: gnatural-fold (All (X) (Integer (Integer X -> X) X -> X)))
|
||||||
|
(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).
|
||||||
|
(: gnatural-for-each (Integer (Integer -> Any) -> Null))
|
||||||
|
(define gnatural-for-each
|
||||||
|
(lambda (limit proc!)
|
||||||
|
'(assert (and (integer? limit)
|
||||||
|
(exact? limit)
|
||||||
|
(>= limit 0))
|
||||||
|
limit)
|
||||||
|
'(assert (procedure? proc!)
|
||||||
|
proc!)
|
||||||
|
(do: : Null
|
||||||
|
((i : Integer 0
|
||||||
|
(+ i 1)))
|
||||||
|
((= i limit) '())
|
||||||
|
(proc! i))))
|
||||||
|
|
||||||
|
(: natural-for-all? (Integer (Integer -> Boolean) -> Boolean))
|
||||||
|
(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)))))))
|
||||||
|
|
||||||
|
(: natural-there-exists? (Integer (Integer -> Boolean) -> Boolean))
|
||||||
|
(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)))))))
|
||||||
|
|
||||||
|
(: there-exists? (All (X) ((Listof X) (X -> Boolean) -> Boolean)))
|
||||||
|
(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.
|
||||||
|
(: fold-over-perm-tree (All (Elem BState TState)
|
||||||
|
((Listof Elem)
|
||||||
|
(Elem BState TState
|
||||||
|
(BState TState -> TState)
|
||||||
|
(TState -> TState)
|
||||||
|
-> TState)
|
||||||
|
BState
|
||||||
|
(BState TState (TState -> TState) -> TState)
|
||||||
|
TState
|
||||||
|
-> TState)))
|
||||||
|
(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: _-*- : TState
|
||||||
|
((universe : (Listof Elem)
|
||||||
|
universe)
|
||||||
|
(b-state : BState
|
||||||
|
b-state)
|
||||||
|
(t-state : TState
|
||||||
|
t-state)
|
||||||
|
(accross : (TState -> TState)
|
||||||
|
(lambda (final-t-state)
|
||||||
|
final-t-state)))
|
||||||
|
(if (null? universe)
|
||||||
|
(t-folder b-state t-state accross)
|
||||||
|
(let: _-**- : TState
|
||||||
|
((in : (Listof Elem)
|
||||||
|
universe)
|
||||||
|
(out : (Listof Elem)
|
||||||
|
'())
|
||||||
|
(t-state : TState
|
||||||
|
t-state))
|
||||||
|
(let*: ((first : Elem
|
||||||
|
(car in))
|
||||||
|
(rest : (Listof Elem)
|
||||||
|
(cdr in))
|
||||||
|
(accross : (TState -> TState)
|
||||||
|
(if (null? rest)
|
||||||
|
accross
|
||||||
|
(lambda: ((new-t-state : TState))
|
||||||
|
(_-**- rest
|
||||||
|
(cons first out)
|
||||||
|
new-t-state)))))
|
||||||
|
(b-folder first
|
||||||
|
b-state
|
||||||
|
t-state
|
||||||
|
(lambda: ((new-b-state : BState)
|
||||||
|
(new-t-state : TState))
|
||||||
|
(_-*- (fold out
|
||||||
|
(ann cons
|
||||||
|
(Elem (Listof Elem)
|
||||||
|
-> (Listof Elem)))
|
||||||
|
rest)
|
||||||
|
new-b-state
|
||||||
|
new-t-state
|
||||||
|
accross))
|
||||||
|
accross)))))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ==== minimal.ss ====
|
||||||
|
|
||||||
|
(define-type Graph (Vectorof (Vectorof Boolean)))
|
||||||
|
|
||||||
|
; 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 vertices 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
|
||||||
|
; ...
|
||||||
|
(: make-minimal? (All (State)
|
||||||
|
(Integer ->
|
||||||
|
(Integer
|
||||||
|
Graph
|
||||||
|
((Vectorof Integer)
|
||||||
|
Boolean
|
||||||
|
(Boolean -> Boolean)
|
||||||
|
-> Boolean)
|
||||||
|
Boolean
|
||||||
|
-> Boolean))))
|
||||||
|
(define make-minimal?
|
||||||
|
(lambda (max-size)
|
||||||
|
'(assert (and (integer? max-size)
|
||||||
|
(exact? max-size)
|
||||||
|
(>= max-size 0))
|
||||||
|
max-size)
|
||||||
|
(let: ((iotas : (Vectorof (Listof Integer))
|
||||||
|
(proc->vector (+ max-size 1)
|
||||||
|
giota))
|
||||||
|
(perm : (Vectorof Integer)
|
||||||
|
(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 : Integer)
|
||||||
|
(x : Integer)
|
||||||
|
(state : Boolean)
|
||||||
|
(deeper : (Integer Boolean
|
||||||
|
-> Boolean))
|
||||||
|
(accross : (Boolean
|
||||||
|
-> Boolean)))
|
||||||
|
(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
|
||||||
|
(error "can't happen"))))
|
||||||
|
0
|
||||||
|
(lambda: ((leaf-depth : Integer)
|
||||||
|
(state : Boolean)
|
||||||
|
(accross : (Boolean -> Boolean)))
|
||||||
|
'(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.
|
||||||
|
(: cmp-next-vertex (Graph (Vectorof Integer) Integer Integer
|
||||||
|
-> (U 'less 'equal 'more)))
|
||||||
|
(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 ====
|
||||||
|
|
||||||
|
(define-type RDG (Vectorof (Listof Integer)))
|
||||||
|
|
||||||
|
; Fold over rooted directed graphs with bounded out-degree.
|
||||||
|
; Size is the number of vertices (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 vertices j for which there is an edge from i to j.
|
||||||
|
; The last vertex is the root.
|
||||||
|
(: fold-over-rdg (All (State) (Integer
|
||||||
|
Integer
|
||||||
|
(RDG State -> State)
|
||||||
|
State
|
||||||
|
-> State)))
|
||||||
|
(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 : Integer
|
||||||
|
(- size 1))
|
||||||
|
(edge? : Graph
|
||||||
|
(proc->vector size
|
||||||
|
(lambda: ((from : Integer))
|
||||||
|
(ann (make-vector size #f)
|
||||||
|
(Vectorof Boolean)))))
|
||||||
|
(edges : RDG
|
||||||
|
(make-vector size '()))
|
||||||
|
(out-degrees : (Vectorof Integer)
|
||||||
|
(make-vector size 0))
|
||||||
|
(minimal-folder : (Integer
|
||||||
|
Graph
|
||||||
|
((Vectorof Integer)
|
||||||
|
Boolean
|
||||||
|
(Boolean -> Boolean)
|
||||||
|
-> Boolean)
|
||||||
|
Boolean
|
||||||
|
-> Boolean)
|
||||||
|
;; make-minimal?'s type says it can return #f, but it won't
|
||||||
|
(or (make-minimal? root)
|
||||||
|
(error "can't happen")))
|
||||||
|
(non-root-minimal? : (Integer -> Boolean)
|
||||||
|
(let ((cont
|
||||||
|
(lambda: ((perm : (Vectorof Integer))
|
||||||
|
(state : Boolean)
|
||||||
|
(accross : (Boolean -> Boolean)))
|
||||||
|
'(assert (eq? state #t)
|
||||||
|
state)
|
||||||
|
(accross #t))))
|
||||||
|
(lambda: ((size : Integer))
|
||||||
|
(minimal-folder size
|
||||||
|
edge?
|
||||||
|
cont
|
||||||
|
#t))))
|
||||||
|
(root-minimal? : ( -> Boolean)
|
||||||
|
(let ((cont
|
||||||
|
(lambda: ((perm : (Vectorof Integer))
|
||||||
|
(state : Boolean)
|
||||||
|
(accross : (Boolean -> Boolean)))
|
||||||
|
'(assert (eq? state #t)
|
||||||
|
state)
|
||||||
|
(case (cmp-next-vertex edge? perm root root)
|
||||||
|
((less)
|
||||||
|
#f)
|
||||||
|
((equal more)
|
||||||
|
(accross #t))
|
||||||
|
(else
|
||||||
|
(error "can't happen"))))))
|
||||||
|
(lambda ()
|
||||||
|
(minimal-folder root
|
||||||
|
edge?
|
||||||
|
cont
|
||||||
|
#t)))))
|
||||||
|
(let: _-*- : State
|
||||||
|
((vertex : Integer
|
||||||
|
0)
|
||||||
|
(state : 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: _-*- : State
|
||||||
|
((v : Integer
|
||||||
|
0)
|
||||||
|
(outs : Integer
|
||||||
|
0)
|
||||||
|
(efr : (Listof Integer)
|
||||||
|
'())
|
||||||
|
(efrr : (Listof (Vectorof Boolean))
|
||||||
|
'())
|
||||||
|
(state : 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 : (Vectorof Boolean)))
|
||||||
|
(vector-ref r v)))))
|
||||||
|
(root-minimal?))
|
||||||
|
(vector-set! edges root efr)
|
||||||
|
(folder
|
||||||
|
(proc->vector size
|
||||||
|
(lambda: ((i : Integer))
|
||||||
|
(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.
|
||||||
|
(: make-reach? (Integer RDG -> Graph))
|
||||||
|
(define make-reach?
|
||||||
|
(lambda (size vertex->out)
|
||||||
|
(let ((res
|
||||||
|
(proc->vector size
|
||||||
|
(lambda: ((v : Integer))
|
||||||
|
(let: ((from-v : (Vectorof Boolean)
|
||||||
|
(make-vector size #f)))
|
||||||
|
(vector-set! from-v v #t)
|
||||||
|
(for-each
|
||||||
|
(lambda: ((x : Integer))
|
||||||
|
(vector-set! from-v x #t))
|
||||||
|
(vector-ref vertex->out v))
|
||||||
|
from-v)))))
|
||||||
|
(gnatural-for-each size
|
||||||
|
(lambda: ((m : Integer))
|
||||||
|
(let ((from-m
|
||||||
|
(vector-ref res m)))
|
||||||
|
(gnatural-for-each size
|
||||||
|
(lambda: ((f : Integer))
|
||||||
|
(let ((from-f
|
||||||
|
(vector-ref res f)))
|
||||||
|
(if (vector-ref from-f m); [wdc - was when]
|
||||||
|
(begin
|
||||||
|
(gnatural-for-each size
|
||||||
|
(lambda: ((t : Integer))
|
||||||
|
(if (vector-ref from-m t)
|
||||||
|
(begin ; [wdc - was when]
|
||||||
|
(vector-set! from-f t #t)
|
||||||
|
#t)
|
||||||
|
#t)))
|
||||||
|
#t)
|
||||||
|
#t)))))))
|
||||||
|
res)))
|
||||||
|
|
||||||
|
|
||||||
|
;;; ==== test input ====
|
||||||
|
|
||||||
|
; Produces all directed graphs with N vertices, distinguished root,
|
||||||
|
; and out-degree bounded by 2, upto isomorphism (there are 44).
|
||||||
|
|
||||||
|
;(define go
|
||||||
|
; (let ((N 7))
|
||||||
|
; (fold-over-rdg N
|
||||||
|
; 2
|
||||||
|
; cons
|
||||||
|
; '())))
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time
|
||||||
|
(let: loop : (Listof RDG)
|
||||||
|
((n : Integer 3) (v : (Listof RDG) '()))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1)
|
||||||
|
(fold-over-rdg (if input 6 0)
|
||||||
|
2
|
||||||
|
(ann cons (RDG (Listof RDG) -> (Listof RDG)))
|
||||||
|
(ann '() (Listof RDG))))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module lattice2-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module lattice2-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
234
collects/tests/racket/benchmarks/common/lattice2-typed.rktl
Normal file
234
collects/tests/racket/benchmarks/common/lattice2-typed.rktl
Normal file
|
|
@ -0,0 +1,234 @@
|
||||||
|
;; Like "lattice.sch", but uses `reverse' instead of
|
||||||
|
;; defining `reverse!' (to avoid `set-cdr!')
|
||||||
|
|
||||||
|
;;; LATTICE -- Obtained from Andrew Wright.
|
||||||
|
|
||||||
|
(define-type Verdict (U 'less 'more 'equal 'uncomparable))
|
||||||
|
|
||||||
|
;; Given a comparison routine that returns one of
|
||||||
|
;; less
|
||||||
|
;; more
|
||||||
|
;; equal
|
||||||
|
;; uncomparable
|
||||||
|
;; return a new comparison routine that applies to sequences.
|
||||||
|
(: lexico (All (X) ((X X -> Verdict) -> ((Listof X) (Listof X) -> Verdict))))
|
||||||
|
(define lexico
|
||||||
|
(lambda (base)
|
||||||
|
(: lex-fixed (Verdict (Listof X) (Listof X) -> Verdict))
|
||||||
|
(define lex-fixed
|
||||||
|
(lambda (fixed lhs rhs)
|
||||||
|
(: check ((Listof X) (Listof X) -> Verdict))
|
||||||
|
(define check
|
||||||
|
(lambda (lhs rhs)
|
||||||
|
(if (null? lhs)
|
||||||
|
fixed
|
||||||
|
(let ((probe
|
||||||
|
(base (car lhs)
|
||||||
|
(car rhs))))
|
||||||
|
(if (or (eq? probe 'equal)
|
||||||
|
(eq? probe fixed))
|
||||||
|
(check (cdr lhs)
|
||||||
|
(cdr rhs))
|
||||||
|
'uncomparable)))))
|
||||||
|
(check lhs rhs)))
|
||||||
|
(: lex-first ((Listof X) (Listof X) -> Verdict))
|
||||||
|
(define lex-first
|
||||||
|
(lambda (lhs rhs)
|
||||||
|
(if (null? lhs)
|
||||||
|
'equal
|
||||||
|
(let: ((probe : Verdict
|
||||||
|
(base (car lhs)
|
||||||
|
(car rhs))))
|
||||||
|
(case probe
|
||||||
|
((less more)
|
||||||
|
(lex-fixed probe
|
||||||
|
(cdr lhs)
|
||||||
|
(cdr rhs)))
|
||||||
|
((equal)
|
||||||
|
(lex-first (cdr lhs)
|
||||||
|
(cdr rhs)))
|
||||||
|
(else
|
||||||
|
'uncomparable))))))
|
||||||
|
lex-first))
|
||||||
|
|
||||||
|
(define-type (Lattice X) (Pair (Listof X) (X X -> Verdict)))
|
||||||
|
|
||||||
|
(: make-lattice (All (X) ((Listof X) (X X -> Verdict) -> (Lattice X))))
|
||||||
|
(define (make-lattice elem-list cmp-func)
|
||||||
|
(cons elem-list cmp-func))
|
||||||
|
|
||||||
|
(: lattice->elements (All (X) ((Lattice X) -> (Listof X))))
|
||||||
|
(define (lattice->elements l) (car l))
|
||||||
|
|
||||||
|
(: lattice->cmp (All (X) ((Lattice X) -> (X X -> Verdict))))
|
||||||
|
(define (lattice->cmp l) (cdr l))
|
||||||
|
|
||||||
|
;; Select elements of a list which pass some test.
|
||||||
|
(: zulu-select (All (X) ((X -> Any) (Listof X) -> (Listof X))))
|
||||||
|
(define zulu-select
|
||||||
|
(lambda (test lst)
|
||||||
|
(: select-a (All (X) ((Listof X) (Listof X) -> (Listof X))))
|
||||||
|
(define select-a
|
||||||
|
(lambda (ac lst)
|
||||||
|
(if (null? lst)
|
||||||
|
(reverse ac)
|
||||||
|
(select-a
|
||||||
|
(let ((head (car lst)))
|
||||||
|
(if (test head)
|
||||||
|
(cons head ac)
|
||||||
|
ac))
|
||||||
|
(cdr lst)))))
|
||||||
|
(select-a '() lst)))
|
||||||
|
|
||||||
|
;; Select elements of a list which pass some test and map a function
|
||||||
|
;; over the result. Note, only efficiency prevents this from being the
|
||||||
|
;; composition of select and map.
|
||||||
|
(: select-map (All (X Y) ((X -> Any) (X -> Y) (Listof X) -> (Listof Y))))
|
||||||
|
(define select-map
|
||||||
|
(lambda (test func lst)
|
||||||
|
(: select-a (All (X Y) ((Listof Y) (Listof X) -> (Listof Y))))
|
||||||
|
(define select-a
|
||||||
|
(lambda (ac lst)
|
||||||
|
(if (null? lst)
|
||||||
|
(reverse ac)
|
||||||
|
(select-a
|
||||||
|
(let ((head (car lst)))
|
||||||
|
(if (test head)
|
||||||
|
(cons (func head)
|
||||||
|
ac)
|
||||||
|
ac))
|
||||||
|
(cdr lst)))))
|
||||||
|
(select-a '() lst)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;; This version of map-and tail-recurses on the last test.
|
||||||
|
(: map-and (All (X) ((X -> Any) (Listof X) -> Any)))
|
||||||
|
(define map-and
|
||||||
|
(lambda (proc lst)
|
||||||
|
(if (null? lst)
|
||||||
|
#t
|
||||||
|
(letrec: ((drudge : (All (X) ((Listof X) -> Any))
|
||||||
|
(lambda (lst)
|
||||||
|
(let ((rest (cdr lst)))
|
||||||
|
(if (null? rest)
|
||||||
|
(proc (car lst))
|
||||||
|
(and (proc (car lst))
|
||||||
|
(drudge rest)))))))
|
||||||
|
(drudge lst)))))
|
||||||
|
|
||||||
|
(: maps-1 (All (X Y) ((Lattice X) (Lattice Y) (Listof (Pair X Y)) X
|
||||||
|
-> (Listof Y))))
|
||||||
|
(define (maps-1 source target pas new)
|
||||||
|
(let ((scmp (lattice->cmp source))
|
||||||
|
(tcmp (lattice->cmp target)))
|
||||||
|
(let ((less
|
||||||
|
((inst select-map (Pair X Y) Y)
|
||||||
|
(lambda: ((p : (Pair X Y)))
|
||||||
|
(eq? 'less
|
||||||
|
(scmp (car p) new)))
|
||||||
|
cdr
|
||||||
|
pas))
|
||||||
|
(more
|
||||||
|
((inst select-map (Pair X Y) Y)
|
||||||
|
(lambda: ((p : (Pair X Y)))
|
||||||
|
(eq? 'more
|
||||||
|
(scmp (car p) new)))
|
||||||
|
cdr
|
||||||
|
pas)))
|
||||||
|
(zulu-select
|
||||||
|
(lambda: ((t : Y))
|
||||||
|
(and
|
||||||
|
((inst map-and Y)
|
||||||
|
(lambda: ((t2 : Y))
|
||||||
|
((inst memq Verdict) (tcmp t2 t) '(less equal)))
|
||||||
|
less)
|
||||||
|
((inst map-and Y)
|
||||||
|
(lambda: ((t2 : Y))
|
||||||
|
((inst memq Verdict) (tcmp t2 t) '(more equal)))
|
||||||
|
more)))
|
||||||
|
(lattice->elements target)))))
|
||||||
|
|
||||||
|
(: maps-rest (All (X Y Z) ((Lattice X) (Lattice Y) (Listof (Pair X Y))
|
||||||
|
(Listof X) ((Listof (Pair X Y)) -> Z)
|
||||||
|
((Listof Z) -> Z)
|
||||||
|
-> Z)))
|
||||||
|
(define (maps-rest source target pas rest to-1 to-collect)
|
||||||
|
(if (null? rest)
|
||||||
|
(to-1 pas)
|
||||||
|
(let ((next (car rest))
|
||||||
|
(rest (cdr rest)))
|
||||||
|
(to-collect
|
||||||
|
(map
|
||||||
|
(lambda: ((x : Y))
|
||||||
|
(maps-rest source target
|
||||||
|
(cons
|
||||||
|
(cons next x)
|
||||||
|
pas)
|
||||||
|
rest
|
||||||
|
to-1
|
||||||
|
to-collect))
|
||||||
|
(maps-1 source target pas next))))))
|
||||||
|
|
||||||
|
(: maps (All (X Y) ((Lattice X) (Lattice Y) -> (Lattice (Listof Y)))))
|
||||||
|
(define (maps source target)
|
||||||
|
(make-lattice
|
||||||
|
(maps-rest source
|
||||||
|
target
|
||||||
|
'()
|
||||||
|
(lattice->elements source)
|
||||||
|
(lambda: ((x : (Listof (Pair X Y))))
|
||||||
|
(list ((inst map Y (Pair X Y)) cdr x)))
|
||||||
|
(lambda: ((x : (Listof (Listof (Listof Y)))))
|
||||||
|
(apply append x)))
|
||||||
|
|
||||||
|
(lexico (lattice->cmp target))))
|
||||||
|
|
||||||
|
(: count-maps (All (X Y) ((Lattice X) (Lattice Y) -> Integer)))
|
||||||
|
(define (count-maps source target)
|
||||||
|
((inst maps-rest X Y Integer) source
|
||||||
|
target
|
||||||
|
'()
|
||||||
|
(lattice->elements source)
|
||||||
|
(lambda (x) 1)
|
||||||
|
sum))
|
||||||
|
|
||||||
|
(: sum ((Listof Integer) -> Integer))
|
||||||
|
(define (sum lst)
|
||||||
|
(if (null? lst)
|
||||||
|
0
|
||||||
|
(+ (car lst) (sum (cdr lst)))))
|
||||||
|
|
||||||
|
(: run ( -> Integer))
|
||||||
|
(define (run)
|
||||||
|
(let* ((l2
|
||||||
|
(make-lattice '(low high)
|
||||||
|
(lambda (lhs rhs)
|
||||||
|
(case lhs
|
||||||
|
((low)
|
||||||
|
(case rhs
|
||||||
|
((low)
|
||||||
|
'equal)
|
||||||
|
((high)
|
||||||
|
'less)
|
||||||
|
(else
|
||||||
|
(error 'make-lattice "base" rhs))))
|
||||||
|
((high)
|
||||||
|
(case rhs
|
||||||
|
((low)
|
||||||
|
'more)
|
||||||
|
((high)
|
||||||
|
'equal)
|
||||||
|
(else
|
||||||
|
(error 'make-lattice "base" rhs))))
|
||||||
|
(else
|
||||||
|
(error 'make-lattice "base" lhs))))))
|
||||||
|
(l3 (maps l2 l2))
|
||||||
|
(l4 (maps l3 l3)))
|
||||||
|
(count-maps l2 l2)
|
||||||
|
(count-maps l3 l3)
|
||||||
|
(count-maps l2 l3)
|
||||||
|
(count-maps l3 l2)
|
||||||
|
(count-maps l4 l4)))
|
||||||
|
|
||||||
|
(time (run))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module mazefun-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module mazefun-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
244
collects/tests/racket/benchmarks/common/mazefun-typed.rktl
Normal file
244
collects/tests/racket/benchmarks/common/mazefun-typed.rktl
Normal file
|
|
@ -0,0 +1,244 @@
|
||||||
|
;;; MAZEFUN -- Constructs a maze in a purely functional way,
|
||||||
|
;;; written by Marc Feeley.
|
||||||
|
|
||||||
|
(: iota (Integer -> (Listof Integer)))
|
||||||
|
(define iota
|
||||||
|
(lambda (n)
|
||||||
|
(iota-iter n '())))
|
||||||
|
|
||||||
|
(: iota-iter (Integer (Listof Integer) -> (Listof Integer)))
|
||||||
|
(define iota-iter
|
||||||
|
(lambda (n lst)
|
||||||
|
(if (= n 0)
|
||||||
|
lst
|
||||||
|
(iota-iter (- n 1) (cons n lst)))))
|
||||||
|
|
||||||
|
(: foldr (All (X Y) ((X Y -> Y) Y (Listof X) -> Y)))
|
||||||
|
(define foldr
|
||||||
|
(lambda (f base lst)
|
||||||
|
|
||||||
|
(: foldr-aux ((Listof X) -> Y))
|
||||||
|
(define foldr-aux
|
||||||
|
(lambda (lst)
|
||||||
|
(if (null? lst)
|
||||||
|
base
|
||||||
|
(f (car lst) (foldr-aux (cdr lst))))))
|
||||||
|
|
||||||
|
(foldr-aux lst)))
|
||||||
|
|
||||||
|
(: foldl (All (X Y) ((Y X -> Y) Y (Listof X) -> Y)))
|
||||||
|
(define foldl
|
||||||
|
(lambda (f base lst)
|
||||||
|
|
||||||
|
(: foldl-aux (Y (Listof X) -> Y))
|
||||||
|
(define foldl-aux
|
||||||
|
(lambda (base lst)
|
||||||
|
(if (null? lst)
|
||||||
|
base
|
||||||
|
(foldl-aux (f base (car lst)) (cdr lst)))))
|
||||||
|
|
||||||
|
(foldl-aux base lst)))
|
||||||
|
|
||||||
|
(: for (All (X) (Integer Integer (Integer -> X) -> (Listof X))))
|
||||||
|
(define for
|
||||||
|
(lambda (lo hi f)
|
||||||
|
|
||||||
|
(: for-aux (Integer -> (Listof X)))
|
||||||
|
(define for-aux
|
||||||
|
(lambda (lo)
|
||||||
|
(if (< lo hi)
|
||||||
|
(cons (f lo) (for-aux (+ lo 1)))
|
||||||
|
'())))
|
||||||
|
|
||||||
|
(for-aux lo)))
|
||||||
|
|
||||||
|
(: concat (All (X) ((Listof (Listof X)) -> (Listof X))))
|
||||||
|
(define concat
|
||||||
|
(lambda (lists)
|
||||||
|
((inst foldr (Listof X) (Listof X)) append '() lists)))
|
||||||
|
|
||||||
|
(: list-read (All (X) ((Listof X) Integer -> X)))
|
||||||
|
(define list-read
|
||||||
|
(lambda (lst i)
|
||||||
|
(if (= i 0)
|
||||||
|
(car lst)
|
||||||
|
(list-read (cdr lst) (- i 1)))))
|
||||||
|
|
||||||
|
(: list-write (All (X) ((Listof X) Integer X -> (Listof X))))
|
||||||
|
(define list-write
|
||||||
|
(lambda (lst i val)
|
||||||
|
(if (= i 0)
|
||||||
|
(cons val (cdr lst))
|
||||||
|
(cons (car lst) (list-write (cdr lst) (- i 1) val)))))
|
||||||
|
|
||||||
|
(: list-remove-pos (All (X) ((Listof X) Integer -> (Listof X))))
|
||||||
|
(define list-remove-pos
|
||||||
|
(lambda (lst i)
|
||||||
|
(if (= i 0)
|
||||||
|
(cdr lst)
|
||||||
|
(cons (car lst) (list-remove-pos (cdr lst) (- i 1))))))
|
||||||
|
|
||||||
|
(: duplicates? (All (X) ((Listof X) -> Any)))
|
||||||
|
(define duplicates?
|
||||||
|
(lambda (lst)
|
||||||
|
(if (null? lst)
|
||||||
|
#f
|
||||||
|
(or (member (car lst) (cdr lst))
|
||||||
|
(duplicates? (cdr lst))))))
|
||||||
|
|
||||||
|
;; Manipulation de matrices.
|
||||||
|
|
||||||
|
(define-type (Matrix X) (Listof (Listof X)))
|
||||||
|
(: make-matrix (All (X) (Integer Integer (Integer Integer -> X)
|
||||||
|
-> (Matrix X))))
|
||||||
|
(define make-matrix
|
||||||
|
(lambda (n m init)
|
||||||
|
(for 0 n (lambda: ((i : Integer))
|
||||||
|
(for 0 m (lambda: ((j : Integer))
|
||||||
|
(init i j)))))))
|
||||||
|
|
||||||
|
(: matrix-read (All (X) ((Matrix X) Integer Integer -> X)))
|
||||||
|
(define matrix-read
|
||||||
|
(lambda (mat i j)
|
||||||
|
(list-read (list-read mat i) j)))
|
||||||
|
|
||||||
|
(: matrix-write (All (X) ((Matrix X) Integer Integer X -> (Matrix X))))
|
||||||
|
(define matrix-write
|
||||||
|
(lambda (mat i j val)
|
||||||
|
(list-write mat i (list-write (list-read mat i) j val))))
|
||||||
|
|
||||||
|
(define-type Pos (Pair Integer Integer))
|
||||||
|
(: matrix-size (All (X) ((Matrix X) -> Pos)))
|
||||||
|
(define matrix-size
|
||||||
|
(lambda (mat)
|
||||||
|
(cons (length mat) (length (car mat)))))
|
||||||
|
|
||||||
|
(: matrix-map (All (X Y) ((X -> Y) (Matrix X) -> (Matrix Y))))
|
||||||
|
(define matrix-map
|
||||||
|
(lambda (f mat)
|
||||||
|
(map (lambda: ((lst : (Listof X))) (map f lst)) mat)))
|
||||||
|
|
||||||
|
(define initial-random 0)
|
||||||
|
|
||||||
|
(: next-random (Integer -> Integer))
|
||||||
|
(define next-random
|
||||||
|
(lambda (current-random)
|
||||||
|
(remainder (+ (* current-random 3581) 12751) 131072)))
|
||||||
|
|
||||||
|
(: shuffle (All (X) ((Listof X) -> (Listof X))))
|
||||||
|
(define shuffle
|
||||||
|
(lambda (lst)
|
||||||
|
(shuffle-aux lst initial-random)))
|
||||||
|
|
||||||
|
(: shuffle-aux (All (X) ((Listof X) Integer -> (Listof X))))
|
||||||
|
(define shuffle-aux
|
||||||
|
(lambda (lst current-random)
|
||||||
|
(if (null? lst)
|
||||||
|
'()
|
||||||
|
(let ((new-random (next-random current-random)))
|
||||||
|
(let ((i (modulo new-random (length lst))))
|
||||||
|
(cons (list-read lst i)
|
||||||
|
(shuffle-aux (list-remove-pos lst i)
|
||||||
|
new-random)))))))
|
||||||
|
|
||||||
|
(: make-maze (Integer Integer -> (U (Matrix (U '_ '*)) 'error)))
|
||||||
|
(define make-maze
|
||||||
|
(lambda (n m) ; n and m must be odd
|
||||||
|
(if (not (and (odd? n) (odd? m)))
|
||||||
|
'error
|
||||||
|
(let ((cave
|
||||||
|
(make-matrix n m (lambda: ((i : Integer) (j : Integer))
|
||||||
|
(if (and (even? i) (even? j))
|
||||||
|
(cons i j)
|
||||||
|
'(0 . 0)))))
|
||||||
|
(possible-holes
|
||||||
|
(concat
|
||||||
|
(for 0 n (lambda: ((i : Integer))
|
||||||
|
(concat
|
||||||
|
(for 0 m (lambda: ((j : Integer))
|
||||||
|
(if (equal? (even? i) (even? j))
|
||||||
|
'()
|
||||||
|
(list (cons i j)))))))))))
|
||||||
|
(cave-to-maze (pierce-randomly (shuffle possible-holes) cave))))))
|
||||||
|
|
||||||
|
(: cave-to-maze (All (X) ((Matrix X) -> (Matrix (U '_ '*)))))
|
||||||
|
(define cave-to-maze
|
||||||
|
(lambda (cave)
|
||||||
|
(matrix-map (lambda (x) (if x '_ '*)) cave)))
|
||||||
|
|
||||||
|
(: pierce (Pos (Matrix Pos) -> (Matrix Pos)))
|
||||||
|
(define pierce
|
||||||
|
(lambda (pos cave)
|
||||||
|
(let: ((i : Integer (car pos)) (j : Integer (cdr pos)))
|
||||||
|
(matrix-write cave i j pos))))
|
||||||
|
|
||||||
|
(: pierce-randomly ((Listof Pos) (Matrix Pos) -> (Matrix Pos)))
|
||||||
|
(define pierce-randomly
|
||||||
|
(lambda (possible-holes cave)
|
||||||
|
(if (null? possible-holes)
|
||||||
|
cave
|
||||||
|
(let ((hole (car possible-holes)))
|
||||||
|
(pierce-randomly (cdr possible-holes)
|
||||||
|
(try-to-pierce hole cave))))))
|
||||||
|
|
||||||
|
(: try-to-pierce (Pos (Matrix Pos) -> (Matrix Pos)))
|
||||||
|
(define try-to-pierce
|
||||||
|
(lambda (pos cave)
|
||||||
|
(let ((i (car pos)) (j (cdr pos)))
|
||||||
|
(let ((ncs (neighboring-cavities pos cave)))
|
||||||
|
(if (duplicates?
|
||||||
|
(map (lambda: ((nc : Pos))
|
||||||
|
(matrix-read cave (car nc) (cdr nc)))
|
||||||
|
ncs))
|
||||||
|
cave
|
||||||
|
(pierce pos
|
||||||
|
(foldl (lambda: ((c : (Matrix Pos)) (nc : Pos))
|
||||||
|
(change-cavity c nc pos))
|
||||||
|
cave
|
||||||
|
ncs)))))))
|
||||||
|
|
||||||
|
(: change-cavity ((Matrix Pos) Pos Pos -> (Matrix Pos)))
|
||||||
|
(define change-cavity
|
||||||
|
(lambda (cave pos new-cavity-id)
|
||||||
|
(let ((i (car pos)) (j (cdr pos)))
|
||||||
|
(change-cavity-aux cave pos new-cavity-id (matrix-read cave i j)))))
|
||||||
|
|
||||||
|
(: change-cavity-aux ((Matrix Pos) Pos Pos Pos -> (Matrix Pos)))
|
||||||
|
(define change-cavity-aux
|
||||||
|
(lambda (cave pos new-cavity-id old-cavity-id)
|
||||||
|
(let ((i (car pos)) (j (cdr pos)))
|
||||||
|
(let ((cavity-id (matrix-read cave i j)))
|
||||||
|
(if (equal? cavity-id old-cavity-id)
|
||||||
|
(foldl (lambda: ((c : (Matrix Pos)) (nc : Pos))
|
||||||
|
(change-cavity-aux c nc new-cavity-id old-cavity-id))
|
||||||
|
(matrix-write cave i j new-cavity-id)
|
||||||
|
(neighboring-cavities pos cave))
|
||||||
|
cave)))))
|
||||||
|
|
||||||
|
(: neighboring-cavities (All (X) (Pos (Matrix X) -> (Listof Pos))))
|
||||||
|
(define neighboring-cavities
|
||||||
|
(lambda (pos cave)
|
||||||
|
(let ((size (matrix-size cave)))
|
||||||
|
(let ((n (car size)) (m (cdr size)))
|
||||||
|
(let ((i (car pos)) (j (cdr pos)))
|
||||||
|
(append (if (and (> i 0) (matrix-read cave (- i 1) j))
|
||||||
|
(list (cons (- i 1) j))
|
||||||
|
'())
|
||||||
|
(if (and (< i (- n 1)) (matrix-read cave (+ i 1) j))
|
||||||
|
(list (cons (+ i 1) j))
|
||||||
|
'())
|
||||||
|
(if (and (> j 0) (matrix-read cave i (- j 1)))
|
||||||
|
(list (cons i (- j 1)))
|
||||||
|
'())
|
||||||
|
(if (and (< j (- m 1)) (matrix-read cave i (+ j 1)))
|
||||||
|
(list (cons i (+ j 1)))
|
||||||
|
'())))))))
|
||||||
|
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time (let: loop : (U (Matrix (U '_ '*)) 'error)
|
||||||
|
((n : Integer 500) (v : (U (Matrix (U '_ '*)) 'error) '()))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1)
|
||||||
|
(make-maze 11 (if input 11 0)))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nestedloop-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nestedloop-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,64 @@
|
||||||
|
;; Imperative body:
|
||||||
|
(: loops (Integer -> Integer))
|
||||||
|
(define (loops n)
|
||||||
|
(let: ((result : Integer 0))
|
||||||
|
(let loop1 ((i1 1))
|
||||||
|
(if (> i1 n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(let loop2 ((i2 1))
|
||||||
|
(if (> i2 n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(let loop3 ((i3 1))
|
||||||
|
(if (> i3 n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(let loop4 ((i4 1))
|
||||||
|
(if (> i4 n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(let loop5 ((i5 1))
|
||||||
|
(if (> i5 n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(let loop6 ((i6 1))
|
||||||
|
(if (> i6 n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(set! result (+ result 1))
|
||||||
|
(loop6 (+ i6 1)))))
|
||||||
|
(loop5 (+ i5 1)))))
|
||||||
|
(loop4 (+ i4 1)))))
|
||||||
|
(loop3 (+ i3 1)))))
|
||||||
|
(loop2 (+ i2 1)))))
|
||||||
|
(loop1 (+ i1 1)))))
|
||||||
|
result))
|
||||||
|
|
||||||
|
;; Functional body:
|
||||||
|
(: func-loops (Integer -> Integer))
|
||||||
|
(define (func-loops n)
|
||||||
|
(let loop1 ((i1 1)(result 0))
|
||||||
|
(if (> i1 n)
|
||||||
|
result
|
||||||
|
(let loop2 ((i2 1)(result result))
|
||||||
|
(if (> i2 n)
|
||||||
|
(loop1 (+ i1 1) result)
|
||||||
|
(let loop3 ((i3 1)(result result))
|
||||||
|
(if (> i3 n)
|
||||||
|
(loop2 (+ i2 1) result)
|
||||||
|
(let loop4 ((i4 1)(result result))
|
||||||
|
(if (> i4 n)
|
||||||
|
(loop3 (+ i3 1) result)
|
||||||
|
(let loop5 ((i5 1)(result result))
|
||||||
|
(if (> i5 n)
|
||||||
|
(loop4 (+ i4 1) result)
|
||||||
|
(let loop6 ((i6 1)(result result))
|
||||||
|
(if (> i6 n)
|
||||||
|
(loop5 (+ i5 1) result)
|
||||||
|
(loop6 (+ i6 1) (+ result 1)))))))))))))))
|
||||||
|
|
||||||
|
(let ((cnt (if (with-input-from-file "input.txt" read) 18 1)))
|
||||||
|
(time (list
|
||||||
|
(loops cnt)
|
||||||
|
(func-loops cnt))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nfa-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nfa-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
58
collects/tests/racket/benchmarks/common/nfa-typed.rktl
Normal file
58
collects/tests/racket/benchmarks/common/nfa-typed.rktl
Normal file
|
|
@ -0,0 +1,58 @@
|
||||||
|
;; The recursive-nfa benchmark. (Figure 45, page 143.)
|
||||||
|
|
||||||
|
;; Changed by Matthew 2006/08/21 to move string->list out of the loop
|
||||||
|
;; Changed by Vincent 2010/04/05 to convert to typed Scheme
|
||||||
|
|
||||||
|
(define-type Result (U 'state2 'state4 #f))
|
||||||
|
|
||||||
|
(: recursive-nfa ((Listof Char) -> (U 'state2 'state4 'fail)))
|
||||||
|
(define (recursive-nfa input)
|
||||||
|
|
||||||
|
(: state0 ((Listof Char) -> Result))
|
||||||
|
(define (state0 input)
|
||||||
|
(or (state1 input) (state3 input) #f))
|
||||||
|
|
||||||
|
(: state1 ((Listof Char) -> Result))
|
||||||
|
(define (state1 input)
|
||||||
|
(and (not (null? input))
|
||||||
|
(or (and (char=? (car input) #\a)
|
||||||
|
(state1 (cdr input)))
|
||||||
|
(and (char=? (car input) #\c)
|
||||||
|
(state1 input))
|
||||||
|
(state2 input))))
|
||||||
|
|
||||||
|
(: state2 ((Listof Char) -> Result))
|
||||||
|
(define (state2 input)
|
||||||
|
(and (not (null? input))
|
||||||
|
(char=? (car input) #\b)
|
||||||
|
(not (null? (cdr input)))
|
||||||
|
(char=? (cadr input) #\c)
|
||||||
|
(not (null? (cddr input)))
|
||||||
|
(char=? (caddr input) #\d)
|
||||||
|
'state2))
|
||||||
|
|
||||||
|
(: state3 ((Listof Char) -> Result))
|
||||||
|
(define (state3 input)
|
||||||
|
(and (not (null? input))
|
||||||
|
(or (and (char=? (car input) #\a)
|
||||||
|
(state3 (cdr input)))
|
||||||
|
(state4 input))))
|
||||||
|
|
||||||
|
(: state4 ((Listof Char) -> Result))
|
||||||
|
(define (state4 input)
|
||||||
|
(and (not (null? input))
|
||||||
|
(char=? (car input) #\b)
|
||||||
|
(not (null? (cdr input)))
|
||||||
|
(char=? (cadr input) #\c)
|
||||||
|
'state4))
|
||||||
|
|
||||||
|
(or (state0 input)
|
||||||
|
'fail))
|
||||||
|
|
||||||
|
(time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
|
||||||
|
(let: loop : 'done ((n : Integer 150000))
|
||||||
|
(if (zero? n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(recursive-nfa input)
|
||||||
|
(loop (- n 1)))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nothing-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nothing-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
(time 1)
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nqueens-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module nqueens-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
43
collects/tests/racket/benchmarks/common/nqueens-typed.rktl
Normal file
43
collects/tests/racket/benchmarks/common/nqueens-typed.rktl
Normal file
|
|
@ -0,0 +1,43 @@
|
||||||
|
;;; NQUEENS -- Compute number of solutions to 8-queens problem.
|
||||||
|
;; 2006/08 -- renamed `try' to `try-it' to avoid Bigloo collision (mflatt)
|
||||||
|
;; 2010/04 -- got rid of the one-armed id (stamourv)
|
||||||
|
;; 2010/05 -- ported to typed Scheme (stamourv)
|
||||||
|
|
||||||
|
(define trace? #f)
|
||||||
|
|
||||||
|
(: nqueens (Integer -> Integer))
|
||||||
|
(define (nqueens n)
|
||||||
|
|
||||||
|
(: one-to (Integer -> (Listof Integer)))
|
||||||
|
(define (one-to n)
|
||||||
|
(let: loop : (Listof Integer)
|
||||||
|
((i : Integer n) (l : (Listof Integer) '()))
|
||||||
|
(if (= i 0) l (loop (- i 1) (cons i l)))))
|
||||||
|
|
||||||
|
(: try-it ((Listof Integer) (Listof Integer) (Listof Integer) -> Integer))
|
||||||
|
(define (try-it x y z)
|
||||||
|
(if (null? x)
|
||||||
|
(if (null? y)
|
||||||
|
(begin (if trace? (begin (write z) (newline)) #t) 1)
|
||||||
|
0)
|
||||||
|
(+ (if (ok? (car x) 1 z)
|
||||||
|
(try-it (append (cdr x) y) '() (cons (car x) z))
|
||||||
|
0)
|
||||||
|
(try-it (cdr x) (cons (car x) y) z))))
|
||||||
|
|
||||||
|
(: ok? (Integer Integer (Listof Integer) -> Boolean))
|
||||||
|
(define (ok? row dist placed)
|
||||||
|
(if (null? placed)
|
||||||
|
#t
|
||||||
|
(and (not (= (car placed) (+ row dist)))
|
||||||
|
(not (= (car placed) (- row dist)))
|
||||||
|
(ok? row (+ dist 1) (cdr placed)))))
|
||||||
|
|
||||||
|
(try-it (one-to n) '() '()))
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time
|
||||||
|
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1) (nqueens (if input 8 0)))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module paraffins-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module paraffins-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
196
collects/tests/racket/benchmarks/common/paraffins-typed.rktl
Normal file
196
collects/tests/racket/benchmarks/common/paraffins-typed.rktl
Normal file
|
|
@ -0,0 +1,196 @@
|
||||||
|
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
|
||||||
|
|
||||||
|
(require/typed scheme/base (collect-garbage ( -> Void)))
|
||||||
|
|
||||||
|
(define-type Radical (Rec Radical (U 'C 'H 'BCP 'CCP (Vectorof Radical))))
|
||||||
|
|
||||||
|
(: gen (Integer -> (Vectorof (Listof Radical))))
|
||||||
|
(define (gen n)
|
||||||
|
(let*: ((n/2 : Integer (quotient n 2))
|
||||||
|
(radicals : (Vectorof (Listof Radical)) (make-vector (+ n/2 1) '(H))))
|
||||||
|
|
||||||
|
(: rads-of-size (Integer -> (Listof Radical)))
|
||||||
|
(define (rads-of-size n)
|
||||||
|
(let: loop1 : (Listof Radical)
|
||||||
|
((ps : (Listof (Vectorof Integer))
|
||||||
|
(three-partitions (- n 1)))
|
||||||
|
(lst : (Listof Radical)
|
||||||
|
'()))
|
||||||
|
(if (null? ps)
|
||||||
|
lst
|
||||||
|
(let* ((p (car ps))
|
||||||
|
(nc1 (vector-ref p 0))
|
||||||
|
(nc2 (vector-ref p 1))
|
||||||
|
(nc3 (vector-ref p 2)))
|
||||||
|
(let: loop2 : (Listof Radical)
|
||||||
|
((rads1 : (Listof Radical)
|
||||||
|
(vector-ref radicals nc1))
|
||||||
|
(lst : (Listof Radical)
|
||||||
|
(loop1 (cdr ps)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads1)
|
||||||
|
lst
|
||||||
|
(let: loop3 : (Listof Radical)
|
||||||
|
((rads2 : (Listof Radical)
|
||||||
|
(if (= nc1 nc2)
|
||||||
|
rads1
|
||||||
|
(vector-ref radicals nc2)))
|
||||||
|
(lst : (Listof Radical)
|
||||||
|
(loop2 (cdr rads1)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads2)
|
||||||
|
lst
|
||||||
|
(let: loop4 : (Listof Radical)
|
||||||
|
((rads3 : (Listof Radical)
|
||||||
|
(if (= nc2 nc3)
|
||||||
|
rads2
|
||||||
|
(vector-ref radicals nc3)))
|
||||||
|
(lst : (Listof Radical)
|
||||||
|
(loop3 (cdr rads2)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads3)
|
||||||
|
lst
|
||||||
|
(cons (vector 'C
|
||||||
|
(car rads1)
|
||||||
|
(car rads2)
|
||||||
|
(car rads3))
|
||||||
|
(loop4 (cdr rads3)
|
||||||
|
lst))))))))))))
|
||||||
|
|
||||||
|
(: bcp-generator (Integer -> (Listof Radical)))
|
||||||
|
(define (bcp-generator j)
|
||||||
|
(if (odd? j)
|
||||||
|
'()
|
||||||
|
(let: loop1 : (Listof Radical)
|
||||||
|
((rads1 : (Listof Radical)
|
||||||
|
(vector-ref radicals (quotient j 2)))
|
||||||
|
(lst : (Listof Radical)
|
||||||
|
'()))
|
||||||
|
(if (null? rads1)
|
||||||
|
lst
|
||||||
|
(let loop2 ((rads2
|
||||||
|
rads1)
|
||||||
|
(lst
|
||||||
|
(loop1 (cdr rads1)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads2)
|
||||||
|
lst
|
||||||
|
(cons (vector 'BCP
|
||||||
|
(car rads1)
|
||||||
|
(car rads2))
|
||||||
|
(loop2 (cdr rads2)
|
||||||
|
lst))))))))
|
||||||
|
|
||||||
|
(: ccp-generator (Integer -> (Listof Radical)))
|
||||||
|
(define (ccp-generator j)
|
||||||
|
(let: loop1 : (Listof Radical)
|
||||||
|
((ps : (Listof (Vectorof Integer))
|
||||||
|
(four-partitions (- j 1)))
|
||||||
|
(lst : (Listof Radical)
|
||||||
|
'()))
|
||||||
|
(if (null? ps)
|
||||||
|
lst
|
||||||
|
(let* ((p (car ps))
|
||||||
|
(nc1 (vector-ref p 0))
|
||||||
|
(nc2 (vector-ref p 1))
|
||||||
|
(nc3 (vector-ref p 2))
|
||||||
|
(nc4 (vector-ref p 3)))
|
||||||
|
(let loop2 ((rads1
|
||||||
|
(vector-ref radicals nc1))
|
||||||
|
(lst
|
||||||
|
(loop1 (cdr ps)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads1)
|
||||||
|
lst
|
||||||
|
(let loop3 ((rads2
|
||||||
|
(if (= nc1 nc2)
|
||||||
|
rads1
|
||||||
|
(vector-ref radicals nc2)))
|
||||||
|
(lst
|
||||||
|
(loop2 (cdr rads1)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads2)
|
||||||
|
lst
|
||||||
|
(let loop4 ((rads3
|
||||||
|
(if (= nc2 nc3)
|
||||||
|
rads2
|
||||||
|
(vector-ref radicals nc3)))
|
||||||
|
(lst
|
||||||
|
(loop3 (cdr rads2)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads3)
|
||||||
|
lst
|
||||||
|
(let loop5 ((rads4
|
||||||
|
(if (= nc3 nc4)
|
||||||
|
rads3
|
||||||
|
(vector-ref radicals nc4)))
|
||||||
|
(lst
|
||||||
|
(loop4 (cdr rads3)
|
||||||
|
lst)))
|
||||||
|
(if (null? rads4)
|
||||||
|
lst
|
||||||
|
(cons (vector 'CCP
|
||||||
|
(car rads1)
|
||||||
|
(car rads2)
|
||||||
|
(car rads3)
|
||||||
|
(car rads4))
|
||||||
|
(loop5 (cdr rads4)
|
||||||
|
lst))))))))))))))
|
||||||
|
|
||||||
|
(let loop ((i 1))
|
||||||
|
(if (> i n/2)
|
||||||
|
(vector (bcp-generator n)
|
||||||
|
(ccp-generator n))
|
||||||
|
(begin
|
||||||
|
(vector-set! radicals i (rads-of-size i))
|
||||||
|
(loop (+ i 1)))))))
|
||||||
|
|
||||||
|
(: three-partitions (Integer -> (Listof (Vectorof Integer))))
|
||||||
|
(define (three-partitions m)
|
||||||
|
(let: loop1 : (Listof (Vectorof Integer))
|
||||||
|
((lst : (Listof (Vectorof Integer)) '())
|
||||||
|
(nc1 : Integer (quotient m 3)))
|
||||||
|
(if (< nc1 0)
|
||||||
|
lst
|
||||||
|
(let loop2 ((lst lst)
|
||||||
|
(nc2 (quotient (- m nc1) 2)))
|
||||||
|
(if (< nc2 nc1)
|
||||||
|
(loop1 lst
|
||||||
|
(- nc1 1))
|
||||||
|
(loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst)
|
||||||
|
(- nc2 1)))))))
|
||||||
|
|
||||||
|
(: four-partitions (Integer -> (Listof (Vectorof Integer))))
|
||||||
|
(define (four-partitions m)
|
||||||
|
(let: loop1 : (Listof (Vectorof Integer))
|
||||||
|
((lst : (Listof (Vectorof Integer)) '())
|
||||||
|
(nc1 : Integer (quotient m 4)))
|
||||||
|
(if (< nc1 0)
|
||||||
|
lst
|
||||||
|
(let loop2 ((lst lst)
|
||||||
|
(nc2 (quotient (- m nc1) 3)))
|
||||||
|
(if (< nc2 nc1)
|
||||||
|
(loop1 lst
|
||||||
|
(- nc1 1))
|
||||||
|
(let ((start (max nc2 (- (quotient (+ m 1) 2) (+ nc1 nc2)))))
|
||||||
|
(let loop3 ((lst lst)
|
||||||
|
(nc3 (quotient (- m (+ nc1 nc2)) 2)))
|
||||||
|
(if (< nc3 start)
|
||||||
|
(loop2 lst (- nc2 1))
|
||||||
|
(loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst)
|
||||||
|
(- nc3 1))))))))))
|
||||||
|
|
||||||
|
(: nb (Integer -> Integer))
|
||||||
|
(define (nb n)
|
||||||
|
(let ((x (gen n)))
|
||||||
|
(+ (length (vector-ref x 0))
|
||||||
|
(length (vector-ref x 1)))))
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time
|
||||||
|
(let: loop : Integer
|
||||||
|
((n : Integer 100) (v : Integer 0))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1) (nb (if input 17 0)))))))
|
||||||
|
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module puzzle-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module puzzle-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
197
collects/tests/racket/benchmarks/common/puzzle-typed.rktl
Normal file
197
collects/tests/racket/benchmarks/common/puzzle-typed.rktl
Normal file
|
|
@ -0,0 +1,197 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: puzzle.sch
|
||||||
|
; Description: PUZZLE benchmark
|
||||||
|
; Author: Richard Gabriel, after Forrest Baskett
|
||||||
|
; Created: 12-Apr-85
|
||||||
|
; Modified: 12-Apr-85 14:20:23 (Bob Shaw)
|
||||||
|
; 11-Aug-87 (Will Clinger)
|
||||||
|
; 22-Jan-88 (Will Clinger)
|
||||||
|
; Language: Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(: iota (Integer -> (Listof Integer)))
|
||||||
|
(define (iota n)
|
||||||
|
(do: : (Listof Integer)
|
||||||
|
((n : Integer n (- n 1))
|
||||||
|
(list : (Listof Integer) '() (cons (- n 1) list)))
|
||||||
|
((zero? n) list)))
|
||||||
|
|
||||||
|
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
|
||||||
|
|
||||||
|
(define size 1048575)
|
||||||
|
(define classmax 3)
|
||||||
|
(define typemax 12)
|
||||||
|
|
||||||
|
(: *iii* Integer)
|
||||||
|
(define *iii* 0)
|
||||||
|
(: *kount* Integer)
|
||||||
|
(define *kount* 0)
|
||||||
|
(define *d* 8)
|
||||||
|
|
||||||
|
(: *piececount* (Vectorof Integer))
|
||||||
|
(define *piececount* (make-vector (+ classmax 1) 0))
|
||||||
|
(: *class* (Vectorof Integer))
|
||||||
|
(define *class* (make-vector (+ typemax 1) 0))
|
||||||
|
(: *piecemax* (Vectorof Integer))
|
||||||
|
(define *piecemax* (make-vector (+ typemax 1) 0))
|
||||||
|
(: *puzzle* (Vectorof Boolean))
|
||||||
|
(define *puzzle* (make-vector (+ size 1) #f))
|
||||||
|
(: *p* (Vectorof (Vectorof Boolean)))
|
||||||
|
;; the references (vector #f) will be overwritten
|
||||||
|
;; but it's needed to appease the typechecker
|
||||||
|
(define *p* (make-vector (+ typemax 1)
|
||||||
|
(ann (vector #f)
|
||||||
|
(Vectorof Boolean))))
|
||||||
|
(define nothing
|
||||||
|
(for-each (lambda: ((i : Integer))
|
||||||
|
(vector-set! *p* i
|
||||||
|
(ann (make-vector (+ size 1) #f)
|
||||||
|
(Vectorof Boolean))))
|
||||||
|
(iota (+ typemax 1))))
|
||||||
|
|
||||||
|
(: fit (Integer Integer -> Boolean))
|
||||||
|
(define (fit i j)
|
||||||
|
(let ((end (vector-ref *piecemax* i)))
|
||||||
|
(do ((k 0 (+ k 1)))
|
||||||
|
((or (> k end)
|
||||||
|
(and (vector-ref (vector-ref *p* i) k)
|
||||||
|
(vector-ref *puzzle* (+ j k))))
|
||||||
|
(if (> k end) #t #f)))))
|
||||||
|
|
||||||
|
(: place (Integer Integer -> Integer))
|
||||||
|
(define (place i j)
|
||||||
|
(let ((end (vector-ref *piecemax* i)))
|
||||||
|
(do ((k 0 (+ k 1)))
|
||||||
|
((> k end))
|
||||||
|
(cond ((vector-ref (vector-ref *p* i) k)
|
||||||
|
(vector-set! *puzzle* (+ j k) #t)
|
||||||
|
#t)))
|
||||||
|
(vector-set! *piececount*
|
||||||
|
(vector-ref *class* i)
|
||||||
|
(- (vector-ref *piececount* (vector-ref *class* i)) 1))
|
||||||
|
(do ((k j (+ k 1)))
|
||||||
|
((or (> k size) (not (vector-ref *puzzle* k)))
|
||||||
|
; (newline)
|
||||||
|
; (display "*Puzzle* filled")
|
||||||
|
(if (> k size) 0 k)))))
|
||||||
|
|
||||||
|
(: puzzle-remove (Integer Integer -> Void))
|
||||||
|
(define (puzzle-remove i j)
|
||||||
|
(let ((end (vector-ref *piecemax* i)))
|
||||||
|
(do ((k 0 (+ k 1)))
|
||||||
|
((> k end))
|
||||||
|
(cond ((vector-ref (vector-ref *p* i) k)
|
||||||
|
(vector-set! *puzzle* (+ j k) #f)
|
||||||
|
#f)))
|
||||||
|
(vector-set! *piececount*
|
||||||
|
(vector-ref *class* i)
|
||||||
|
(+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
|
||||||
|
|
||||||
|
|
||||||
|
(: trial (Integer -> Boolean))
|
||||||
|
(define (trial j)
|
||||||
|
(let: ((k : Integer 0))
|
||||||
|
(call-with-current-continuation
|
||||||
|
(lambda: ((return : (Boolean -> Nothing)))
|
||||||
|
(do: : Boolean
|
||||||
|
((i : Integer 0 (+ i 1)))
|
||||||
|
((> i typemax) (set! *kount* (+ *kount* 1)) #f)
|
||||||
|
(cond
|
||||||
|
((not
|
||||||
|
(zero?
|
||||||
|
(vector-ref *piececount* (vector-ref *class* i))))
|
||||||
|
(cond
|
||||||
|
((fit i j)
|
||||||
|
(set! k (place i j))
|
||||||
|
(cond
|
||||||
|
((or (trial k) (zero? k))
|
||||||
|
;(trial-output (+ i 1) (+ k 1))
|
||||||
|
(set! *kount* (+ *kount* 1))
|
||||||
|
(return #t))
|
||||||
|
(else (puzzle-remove i j))))))))))))
|
||||||
|
|
||||||
|
(: trial-output (Integer Integer -> Void))
|
||||||
|
(define (trial-output x y)
|
||||||
|
(newline)
|
||||||
|
(display (string-append "Piece "
|
||||||
|
(number->string x #;'(int))
|
||||||
|
" at "
|
||||||
|
(number->string y #;'(int))
|
||||||
|
".")))
|
||||||
|
|
||||||
|
(: definePiece (Integer Integer Integer Integer -> Void))
|
||||||
|
(define (definePiece iclass ii jj kk)
|
||||||
|
(let: ((index : Integer 0))
|
||||||
|
(do: : Null
|
||||||
|
((i : Integer 0 (+ i 1)))
|
||||||
|
((> i ii) '())
|
||||||
|
(do: : Null
|
||||||
|
((j : Integer 0 (+ j 1)))
|
||||||
|
((> j jj) '())
|
||||||
|
(do: : Null
|
||||||
|
((k : Integer 0 (+ k 1)))
|
||||||
|
((> k kk) '())
|
||||||
|
(set! index (+ i (* *d* (+ j (* *d* k)))))
|
||||||
|
(vector-set! (vector-ref *p* *iii*) index #t))))
|
||||||
|
(vector-set! *class* *iii* iclass)
|
||||||
|
(vector-set! *piecemax* *iii* index)
|
||||||
|
(cond ((not (= *iii* typemax))
|
||||||
|
(set! *iii* (+ *iii* 1))))))
|
||||||
|
|
||||||
|
(: start ( -> Void))
|
||||||
|
(define (start)
|
||||||
|
(do ((m 0 (+ m 1)))
|
||||||
|
((> m size))
|
||||||
|
(vector-set! *puzzle* m #t))
|
||||||
|
(do ((i 1 (+ i 1)))
|
||||||
|
((> i 5))
|
||||||
|
(do ((j 1 (+ j 1)))
|
||||||
|
((> j 5))
|
||||||
|
(do ((k 1 (+ k 1)))
|
||||||
|
((> k 5))
|
||||||
|
(vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f))))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((> i typemax))
|
||||||
|
(do ((m 0 (+ m 1)))
|
||||||
|
((> m size))
|
||||||
|
(vector-set! (vector-ref *p* i) m #f)))
|
||||||
|
(set! *iii* 0)
|
||||||
|
(definePiece 0 3 1 0)
|
||||||
|
(definePiece 0 1 0 3)
|
||||||
|
(definePiece 0 0 3 1)
|
||||||
|
(definePiece 0 1 3 0)
|
||||||
|
(definePiece 0 3 0 1)
|
||||||
|
(definePiece 0 0 1 3)
|
||||||
|
|
||||||
|
(definePiece 1 2 0 0)
|
||||||
|
(definePiece 1 0 2 0)
|
||||||
|
(definePiece 1 0 0 2)
|
||||||
|
|
||||||
|
(definePiece 2 1 1 0)
|
||||||
|
(definePiece 2 1 0 1)
|
||||||
|
(definePiece 2 0 1 1)
|
||||||
|
|
||||||
|
(definePiece 3 1 1 1)
|
||||||
|
|
||||||
|
(vector-set! *piececount* 0 13)
|
||||||
|
(vector-set! *piececount* 1 3)
|
||||||
|
(vector-set! *piececount* 2 1)
|
||||||
|
(vector-set! *piececount* 3 1)
|
||||||
|
(let: ((m : Integer (+ (* *d* (+ *d* 1)) 1))
|
||||||
|
(n : Integer 0))
|
||||||
|
(cond ((fit 0 m) (set! n (place 0 m)))
|
||||||
|
(else (begin (newline) (display "Error."))))
|
||||||
|
(cond ((trial n)
|
||||||
|
(begin (newline)
|
||||||
|
(display "Success in ")
|
||||||
|
(write *kount*)
|
||||||
|
(display " trials.")
|
||||||
|
(newline)))
|
||||||
|
(else (begin (newline) (display "Failure."))))))
|
||||||
|
|
||||||
|
;;; call: (start)
|
||||||
|
|
||||||
|
(time (start))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module tak-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module tak-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
30
collects/tests/racket/benchmarks/common/tak-typed.rktl
Normal file
30
collects/tests/racket/benchmarks/common/tak-typed.rktl
Normal file
|
|
@ -0,0 +1,30 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: tak.sch
|
||||||
|
; Description: TAK benchmark from the Gabriel tests
|
||||||
|
; Author: Richard Gabriel
|
||||||
|
; Created: 12-Apr-85
|
||||||
|
; Modified: 12-Apr-85 09:58:18 (Bob Shaw)
|
||||||
|
; 22-Jul-87 (Will Clinger)
|
||||||
|
; 10-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; TAK -- A vanilla version of the TAKeuchi function
|
||||||
|
|
||||||
|
(: tak (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak x y z)
|
||||||
|
(if (not (< y x))
|
||||||
|
z
|
||||||
|
(tak (tak (- x 1) y z)
|
||||||
|
(tak (- y 1) z x)
|
||||||
|
(tak (- z 1) x y))))
|
||||||
|
|
||||||
|
;;; call: (tak 18 12 6)
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time
|
||||||
|
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1) (tak 18 12 (if input 6 0)))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module takl-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module takl-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
47
collects/tests/racket/benchmarks/common/takl-typed.rktl
Normal file
47
collects/tests/racket/benchmarks/common/takl-typed.rktl
Normal file
|
|
@ -0,0 +1,47 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: takl.sch
|
||||||
|
; Description: TAKL benchmark from the Gabriel tests
|
||||||
|
; Author: Richard Gabriel
|
||||||
|
; Created: 12-Apr-85
|
||||||
|
; Modified: 12-Apr-85 10:07:00 (Bob Shaw)
|
||||||
|
; 22-Jul-87 (Will Clinger)
|
||||||
|
; 10-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; TAKL -- The TAKeuchi function using lists as counters.
|
||||||
|
|
||||||
|
(: listn (Integer -> (Listof Integer)))
|
||||||
|
(define (listn n)
|
||||||
|
(if (not (= 0 n))
|
||||||
|
(cons n (listn (- n 1)))
|
||||||
|
'()))
|
||||||
|
|
||||||
|
(define l18l (listn 18))
|
||||||
|
(define l12l (listn 12))
|
||||||
|
(define l6l (listn 2))
|
||||||
|
|
||||||
|
(: mas (All (X) ((Listof X) (Listof X) (Listof X) -> (Listof X))))
|
||||||
|
(define (mas x y z)
|
||||||
|
(if (not (shorterp y x))
|
||||||
|
z
|
||||||
|
(mas (mas (cdr x)
|
||||||
|
y z)
|
||||||
|
(mas (cdr y)
|
||||||
|
z x)
|
||||||
|
(mas (cdr z)
|
||||||
|
x y))))
|
||||||
|
|
||||||
|
(: shorterp (All (X) ((Listof X) (Listof X) -> Boolean)))
|
||||||
|
(define (shorterp x y)
|
||||||
|
(and (not (null? y))
|
||||||
|
(or (null? x)
|
||||||
|
(shorterp (cdr x)
|
||||||
|
(cdr y)))))
|
||||||
|
|
||||||
|
;;; call: (mas 18l 12l 6l)
|
||||||
|
|
||||||
|
|
||||||
|
(let ((v (if (with-input-from-file "input.txt" read) l6l '())))
|
||||||
|
(time (mas l18l l12l v)))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module takr-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module takr-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
625
collects/tests/racket/benchmarks/common/takr-typed.rktl
Normal file
625
collects/tests/racket/benchmarks/common/takr-typed.rktl
Normal file
|
|
@ -0,0 +1,625 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: takr.sch
|
||||||
|
; Description: TAKR benchmark
|
||||||
|
; Author: Richard Gabriel
|
||||||
|
; Created: 12-Apr-85
|
||||||
|
; Modified: 12-Apr-85 10:12:43 (Bob Shaw)
|
||||||
|
; 22-Jul-87 (Will Clinger)
|
||||||
|
; 10-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache
|
||||||
|
;;; memory effects. Results should be the same as for TAK on stack machines.
|
||||||
|
;;; Distribution of calls is not completely flat.
|
||||||
|
|
||||||
|
(: tak0 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak0 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak1 (tak37 (- x 1) y z)
|
||||||
|
(tak11 (- y 1) z x)
|
||||||
|
(tak17 (- z 1) x y)))))
|
||||||
|
(: tak1 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak1 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak2 (tak74 (- x 1) y z)
|
||||||
|
(tak22 (- y 1) z x)
|
||||||
|
(tak34 (- z 1) x y)))))
|
||||||
|
(: tak2 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak2 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak3 (tak11 (- x 1) y z)
|
||||||
|
(tak33 (- y 1) z x)
|
||||||
|
(tak51 (- z 1) x y)))))
|
||||||
|
(: tak3 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak3 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak4 (tak48 (- x 1) y z)
|
||||||
|
(tak44 (- y 1) z x)
|
||||||
|
(tak68 (- z 1) x y)))))
|
||||||
|
(: tak4 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak4 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak5 (tak85 (- x 1) y z)
|
||||||
|
(tak55 (- y 1) z x)
|
||||||
|
(tak85 (- z 1) x y)))))
|
||||||
|
(: tak5 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak5 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak6 (tak22 (- x 1) y z)
|
||||||
|
(tak66 (- y 1) z x)
|
||||||
|
(tak2 (- z 1) x y)))))
|
||||||
|
(: tak6 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak6 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak7 (tak59 (- x 1) y z)
|
||||||
|
(tak77 (- y 1) z x)
|
||||||
|
(tak19 (- z 1) x y)))))
|
||||||
|
(: tak7 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak7 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak8 (tak96 (- x 1) y z)
|
||||||
|
(tak88 (- y 1) z x)
|
||||||
|
(tak36 (- z 1) x y)))))
|
||||||
|
(: tak8 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak8 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak9 (tak33 (- x 1) y z)
|
||||||
|
(tak99 (- y 1) z x)
|
||||||
|
(tak53 (- z 1) x y)))))
|
||||||
|
(: tak9 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak9 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak10 (tak70 (- x 1) y z)
|
||||||
|
(tak10 (- y 1) z x)
|
||||||
|
(tak70 (- z 1) x y)))))
|
||||||
|
(: tak10 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak10 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak11 (tak7 (- x 1) y z)
|
||||||
|
(tak21 (- y 1) z x)
|
||||||
|
(tak87 (- z 1) x y)))))
|
||||||
|
(: tak11 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak11 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak12 (tak44 (- x 1) y z)
|
||||||
|
(tak32 (- y 1) z x)
|
||||||
|
(tak4 (- z 1) x y)))))
|
||||||
|
(: tak12 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak12 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak13 (tak81 (- x 1) y z)
|
||||||
|
(tak43 (- y 1) z x)
|
||||||
|
(tak21 (- z 1) x y)))))
|
||||||
|
(: tak13 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak13 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak14 (tak18 (- x 1) y z)
|
||||||
|
(tak54 (- y 1) z x)
|
||||||
|
(tak38 (- z 1) x y)))))
|
||||||
|
(: tak14 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak14 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak15 (tak55 (- x 1) y z)
|
||||||
|
(tak65 (- y 1) z x)
|
||||||
|
(tak55 (- z 1) x y)))))
|
||||||
|
(: tak15 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak15 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak16 (tak92 (- x 1) y z)
|
||||||
|
(tak76 (- y 1) z x)
|
||||||
|
(tak72 (- z 1) x y)))))
|
||||||
|
(: tak16 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak16 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak17 (tak29 (- x 1) y z)
|
||||||
|
(tak87 (- y 1) z x)
|
||||||
|
(tak89 (- z 1) x y)))))
|
||||||
|
(: tak17 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak17 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak18 (tak66 (- x 1) y z)
|
||||||
|
(tak98 (- y 1) z x)
|
||||||
|
(tak6 (- z 1) x y)))))
|
||||||
|
(: tak18 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak18 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak19 (tak3 (- x 1) y z)
|
||||||
|
(tak9 (- y 1) z x)
|
||||||
|
(tak23 (- z 1) x y)))))
|
||||||
|
(: tak19 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak19 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak20 (tak40 (- x 1) y z)
|
||||||
|
(tak20 (- y 1) z x)
|
||||||
|
(tak40 (- z 1) x y)))))
|
||||||
|
(: tak20 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak20 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak21 (tak77 (- x 1) y z)
|
||||||
|
(tak31 (- y 1) z x)
|
||||||
|
(tak57 (- z 1) x y)))))
|
||||||
|
(: tak21 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak21 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak22 (tak14 (- x 1) y z)
|
||||||
|
(tak42 (- y 1) z x)
|
||||||
|
(tak74 (- z 1) x y)))))
|
||||||
|
(: tak22 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak22 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak23 (tak51 (- x 1) y z)
|
||||||
|
(tak53 (- y 1) z x)
|
||||||
|
(tak91 (- z 1) x y)))))
|
||||||
|
(: tak23 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak23 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak24 (tak88 (- x 1) y z)
|
||||||
|
(tak64 (- y 1) z x)
|
||||||
|
(tak8 (- z 1) x y)))))
|
||||||
|
(: tak24 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak24 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak25 (tak25 (- x 1) y z)
|
||||||
|
(tak75 (- y 1) z x)
|
||||||
|
(tak25 (- z 1) x y)))))
|
||||||
|
(: tak25 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak25 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak26 (tak62 (- x 1) y z)
|
||||||
|
(tak86 (- y 1) z x)
|
||||||
|
(tak42 (- z 1) x y)))))
|
||||||
|
(: tak26 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak26 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak27 (tak99 (- x 1) y z)
|
||||||
|
(tak97 (- y 1) z x)
|
||||||
|
(tak59 (- z 1) x y)))))
|
||||||
|
(: tak27 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak27 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak28 (tak36 (- x 1) y z)
|
||||||
|
(tak8 (- y 1) z x)
|
||||||
|
(tak76 (- z 1) x y)))))
|
||||||
|
(: tak28 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak28 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak29 (tak73 (- x 1) y z)
|
||||||
|
(tak19 (- y 1) z x)
|
||||||
|
(tak93 (- z 1) x y)))))
|
||||||
|
(: tak29 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak29 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak30 (tak10 (- x 1) y z)
|
||||||
|
(tak30 (- y 1) z x)
|
||||||
|
(tak10 (- z 1) x y)))))
|
||||||
|
(: tak30 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak30 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak31 (tak47 (- x 1) y z)
|
||||||
|
(tak41 (- y 1) z x)
|
||||||
|
(tak27 (- z 1) x y)))))
|
||||||
|
(: tak31 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak31 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak32 (tak84 (- x 1) y z)
|
||||||
|
(tak52 (- y 1) z x)
|
||||||
|
(tak44 (- z 1) x y)))))
|
||||||
|
(: tak32 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak32 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak33 (tak21 (- x 1) y z)
|
||||||
|
(tak63 (- y 1) z x)
|
||||||
|
(tak61 (- z 1) x y)))))
|
||||||
|
(: tak33 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak33 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak34 (tak58 (- x 1) y z)
|
||||||
|
(tak74 (- y 1) z x)
|
||||||
|
(tak78 (- z 1) x y)))))
|
||||||
|
(: tak34 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak34 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak35 (tak95 (- x 1) y z)
|
||||||
|
(tak85 (- y 1) z x)
|
||||||
|
(tak95 (- z 1) x y)))))
|
||||||
|
(: tak35 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak35 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak36 (tak32 (- x 1) y z)
|
||||||
|
(tak96 (- y 1) z x)
|
||||||
|
(tak12 (- z 1) x y)))))
|
||||||
|
(: tak36 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak36 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak37 (tak69 (- x 1) y z)
|
||||||
|
(tak7 (- y 1) z x)
|
||||||
|
(tak29 (- z 1) x y)))))
|
||||||
|
(: tak37 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak37 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak38 (tak6 (- x 1) y z)
|
||||||
|
(tak18 (- y 1) z x)
|
||||||
|
(tak46 (- z 1) x y)))))
|
||||||
|
(: tak38 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak38 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak39 (tak43 (- x 1) y z)
|
||||||
|
(tak29 (- y 1) z x)
|
||||||
|
(tak63 (- z 1) x y)))))
|
||||||
|
(: tak39 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak39 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak40 (tak80 (- x 1) y z)
|
||||||
|
(tak40 (- y 1) z x)
|
||||||
|
(tak80 (- z 1) x y)))))
|
||||||
|
(: tak40 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak40 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak41 (tak17 (- x 1) y z)
|
||||||
|
(tak51 (- y 1) z x)
|
||||||
|
(tak97 (- z 1) x y)))))
|
||||||
|
(: tak41 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak41 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak42 (tak54 (- x 1) y z)
|
||||||
|
(tak62 (- y 1) z x)
|
||||||
|
(tak14 (- z 1) x y)))))
|
||||||
|
(: tak42 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak42 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak43 (tak91 (- x 1) y z)
|
||||||
|
(tak73 (- y 1) z x)
|
||||||
|
(tak31 (- z 1) x y)))))
|
||||||
|
(: tak43 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak43 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak44 (tak28 (- x 1) y z)
|
||||||
|
(tak84 (- y 1) z x)
|
||||||
|
(tak48 (- z 1) x y)))))
|
||||||
|
(: tak44 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak44 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak45 (tak65 (- x 1) y z)
|
||||||
|
(tak95 (- y 1) z x)
|
||||||
|
(tak65 (- z 1) x y)))))
|
||||||
|
(: tak45 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak45 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak46 (tak2 (- x 1) y z)
|
||||||
|
(tak6 (- y 1) z x)
|
||||||
|
(tak82 (- z 1) x y)))))
|
||||||
|
(: tak46 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak46 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak47 (tak39 (- x 1) y z)
|
||||||
|
(tak17 (- y 1) z x)
|
||||||
|
(tak99 (- z 1) x y)))))
|
||||||
|
(: tak47 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak47 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak48 (tak76 (- x 1) y z)
|
||||||
|
(tak28 (- y 1) z x)
|
||||||
|
(tak16 (- z 1) x y)))))
|
||||||
|
(: tak48 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak48 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak49 (tak13 (- x 1) y z)
|
||||||
|
(tak39 (- y 1) z x)
|
||||||
|
(tak33 (- z 1) x y)))))
|
||||||
|
(: tak49 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak49 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak50 (tak50 (- x 1) y z)
|
||||||
|
(tak50 (- y 1) z x)
|
||||||
|
(tak50 (- z 1) x y)))))
|
||||||
|
(: tak50 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak50 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak51 (tak87 (- x 1) y z)
|
||||||
|
(tak61 (- y 1) z x)
|
||||||
|
(tak67 (- z 1) x y)))))
|
||||||
|
(: tak51 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak51 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak52 (tak24 (- x 1) y z)
|
||||||
|
(tak72 (- y 1) z x)
|
||||||
|
(tak84 (- z 1) x y)))))
|
||||||
|
(: tak52 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak52 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak53 (tak61 (- x 1) y z)
|
||||||
|
(tak83 (- y 1) z x)
|
||||||
|
(tak1 (- z 1) x y)))))
|
||||||
|
(: tak53 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak53 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak54 (tak98 (- x 1) y z)
|
||||||
|
(tak94 (- y 1) z x)
|
||||||
|
(tak18 (- z 1) x y)))))
|
||||||
|
(: tak54 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak54 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak55 (tak35 (- x 1) y z)
|
||||||
|
(tak5 (- y 1) z x)
|
||||||
|
(tak35 (- z 1) x y)))))
|
||||||
|
(: tak55 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak55 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak56 (tak72 (- x 1) y z)
|
||||||
|
(tak16 (- y 1) z x)
|
||||||
|
(tak52 (- z 1) x y)))))
|
||||||
|
(: tak56 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak56 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak57 (tak9 (- x 1) y z)
|
||||||
|
(tak27 (- y 1) z x)
|
||||||
|
(tak69 (- z 1) x y)))))
|
||||||
|
(: tak57 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak57 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak58 (tak46 (- x 1) y z)
|
||||||
|
(tak38 (- y 1) z x)
|
||||||
|
(tak86 (- z 1) x y)))))
|
||||||
|
(: tak58 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak58 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak59 (tak83 (- x 1) y z)
|
||||||
|
(tak49 (- y 1) z x)
|
||||||
|
(tak3 (- z 1) x y)))))
|
||||||
|
(: tak59 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak59 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak60 (tak20 (- x 1) y z)
|
||||||
|
(tak60 (- y 1) z x)
|
||||||
|
(tak20 (- z 1) x y)))))
|
||||||
|
(: tak60 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak60 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak61 (tak57 (- x 1) y z)
|
||||||
|
(tak71 (- y 1) z x)
|
||||||
|
(tak37 (- z 1) x y)))))
|
||||||
|
(: tak61 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak61 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak62 (tak94 (- x 1) y z)
|
||||||
|
(tak82 (- y 1) z x)
|
||||||
|
(tak54 (- z 1) x y)))))
|
||||||
|
(: tak62 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak62 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak63 (tak31 (- x 1) y z)
|
||||||
|
(tak93 (- y 1) z x)
|
||||||
|
(tak71 (- z 1) x y)))))
|
||||||
|
(: tak63 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak63 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak64 (tak68 (- x 1) y z)
|
||||||
|
(tak4 (- y 1) z x)
|
||||||
|
(tak88 (- z 1) x y)))))
|
||||||
|
(: tak64 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak64 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak65 (tak5 (- x 1) y z)
|
||||||
|
(tak15 (- y 1) z x)
|
||||||
|
(tak5 (- z 1) x y)))))
|
||||||
|
(: tak65 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak65 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak66 (tak42 (- x 1) y z)
|
||||||
|
(tak26 (- y 1) z x)
|
||||||
|
(tak22 (- z 1) x y)))))
|
||||||
|
(: tak66 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak66 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak67 (tak79 (- x 1) y z)
|
||||||
|
(tak37 (- y 1) z x)
|
||||||
|
(tak39 (- z 1) x y)))))
|
||||||
|
(: tak67 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak67 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak68 (tak16 (- x 1) y z)
|
||||||
|
(tak48 (- y 1) z x)
|
||||||
|
(tak56 (- z 1) x y)))))
|
||||||
|
(: tak68 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak68 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak69 (tak53 (- x 1) y z)
|
||||||
|
(tak59 (- y 1) z x)
|
||||||
|
(tak73 (- z 1) x y)))))
|
||||||
|
(: tak69 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak69 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak70 (tak90 (- x 1) y z)
|
||||||
|
(tak70 (- y 1) z x)
|
||||||
|
(tak90 (- z 1) x y)))))
|
||||||
|
(: tak70 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak70 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak71 (tak27 (- x 1) y z)
|
||||||
|
(tak81 (- y 1) z x)
|
||||||
|
(tak7 (- z 1) x y)))))
|
||||||
|
(: tak71 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak71 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak72 (tak64 (- x 1) y z)
|
||||||
|
(tak92 (- y 1) z x)
|
||||||
|
(tak24 (- z 1) x y)))))
|
||||||
|
(: tak72 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak72 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak73 (tak1 (- x 1) y z)
|
||||||
|
(tak3 (- y 1) z x)
|
||||||
|
(tak41 (- z 1) x y)))))
|
||||||
|
(: tak73 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak73 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak74 (tak38 (- x 1) y z)
|
||||||
|
(tak14 (- y 1) z x)
|
||||||
|
(tak58 (- z 1) x y)))))
|
||||||
|
(: tak74 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak74 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak75 (tak75 (- x 1) y z)
|
||||||
|
(tak25 (- y 1) z x)
|
||||||
|
(tak75 (- z 1) x y)))))
|
||||||
|
(: tak75 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak75 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak76 (tak12 (- x 1) y z)
|
||||||
|
(tak36 (- y 1) z x)
|
||||||
|
(tak92 (- z 1) x y)))))
|
||||||
|
(: tak76 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak76 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak77 (tak49 (- x 1) y z)
|
||||||
|
(tak47 (- y 1) z x)
|
||||||
|
(tak9 (- z 1) x y)))))
|
||||||
|
(: tak77 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak77 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak78 (tak86 (- x 1) y z)
|
||||||
|
(tak58 (- y 1) z x)
|
||||||
|
(tak26 (- z 1) x y)))))
|
||||||
|
(: tak78 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak78 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak79 (tak23 (- x 1) y z)
|
||||||
|
(tak69 (- y 1) z x)
|
||||||
|
(tak43 (- z 1) x y)))))
|
||||||
|
(: tak79 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak79 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak80 (tak60 (- x 1) y z)
|
||||||
|
(tak80 (- y 1) z x)
|
||||||
|
(tak60 (- z 1) x y)))))
|
||||||
|
(: tak80 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak80 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak81 (tak97 (- x 1) y z)
|
||||||
|
(tak91 (- y 1) z x)
|
||||||
|
(tak77 (- z 1) x y)))))
|
||||||
|
(: tak81 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak81 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak82 (tak34 (- x 1) y z)
|
||||||
|
(tak2 (- y 1) z x)
|
||||||
|
(tak94 (- z 1) x y)))))
|
||||||
|
(: tak82 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak82 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak83 (tak71 (- x 1) y z)
|
||||||
|
(tak13 (- y 1) z x)
|
||||||
|
(tak11 (- z 1) x y)))))
|
||||||
|
(: tak83 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak83 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak84 (tak8 (- x 1) y z)
|
||||||
|
(tak24 (- y 1) z x)
|
||||||
|
(tak28 (- z 1) x y)))))
|
||||||
|
(: tak84 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak84 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak85 (tak45 (- x 1) y z)
|
||||||
|
(tak35 (- y 1) z x)
|
||||||
|
(tak45 (- z 1) x y)))))
|
||||||
|
(: tak85 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak85 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak86 (tak82 (- x 1) y z)
|
||||||
|
(tak46 (- y 1) z x)
|
||||||
|
(tak62 (- z 1) x y)))))
|
||||||
|
(: tak86 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak86 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak87 (tak19 (- x 1) y z)
|
||||||
|
(tak57 (- y 1) z x)
|
||||||
|
(tak79 (- z 1) x y)))))
|
||||||
|
(: tak87 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak87 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak88 (tak56 (- x 1) y z)
|
||||||
|
(tak68 (- y 1) z x)
|
||||||
|
(tak96 (- z 1) x y)))))
|
||||||
|
(: tak88 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak88 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak89 (tak93 (- x 1) y z)
|
||||||
|
(tak79 (- y 1) z x)
|
||||||
|
(tak13 (- z 1) x y)))))
|
||||||
|
(: tak89 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak89 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak90 (tak30 (- x 1) y z)
|
||||||
|
(tak90 (- y 1) z x)
|
||||||
|
(tak30 (- z 1) x y)))))
|
||||||
|
(: tak90 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak90 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak91 (tak67 (- x 1) y z)
|
||||||
|
(tak1 (- y 1) z x)
|
||||||
|
(tak47 (- z 1) x y)))))
|
||||||
|
(: tak91 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak91 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak92 (tak4 (- x 1) y z)
|
||||||
|
(tak12 (- y 1) z x)
|
||||||
|
(tak64 (- z 1) x y)))))
|
||||||
|
(: tak92 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak92 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak93 (tak41 (- x 1) y z)
|
||||||
|
(tak23 (- y 1) z x)
|
||||||
|
(tak81 (- z 1) x y)))))
|
||||||
|
(: tak93 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak93 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak94 (tak78 (- x 1) y z)
|
||||||
|
(tak34 (- y 1) z x)
|
||||||
|
(tak98 (- z 1) x y)))))
|
||||||
|
(: tak94 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak94 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak95 (tak15 (- x 1) y z)
|
||||||
|
(tak45 (- y 1) z x)
|
||||||
|
(tak15 (- z 1) x y)))))
|
||||||
|
(: tak95 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak95 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak96 (tak52 (- x 1) y z)
|
||||||
|
(tak56 (- y 1) z x)
|
||||||
|
(tak32 (- z 1) x y)))))
|
||||||
|
(: tak96 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak96 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak97 (tak89 (- x 1) y z)
|
||||||
|
(tak67 (- y 1) z x)
|
||||||
|
(tak49 (- z 1) x y)))))
|
||||||
|
(: tak97 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak97 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak98 (tak26 (- x 1) y z)
|
||||||
|
(tak78 (- y 1) z x)
|
||||||
|
(tak66 (- z 1) x y)))))
|
||||||
|
(: tak98 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak98 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak99 (tak63 (- x 1) y z)
|
||||||
|
(tak89 (- y 1) z x)
|
||||||
|
(tak83 (- z 1) x y)))))
|
||||||
|
(: tak99 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak99 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak0 (tak0 (- x 1) y z)
|
||||||
|
(tak0 (- y 1) z x)
|
||||||
|
(tak0 (- z 1) x y)))))
|
||||||
|
|
||||||
|
;;; call: (tak0 18 12 6)
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time
|
||||||
|
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1) (tak0 18 12 (if input 6 0)))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module takr2-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module takr2-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
629
collects/tests/racket/benchmarks/common/takr2-typed.rktl
Normal file
629
collects/tests/racket/benchmarks/common/takr2-typed.rktl
Normal file
|
|
@ -0,0 +1,629 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: takr.sch
|
||||||
|
; Description: TAKR benchmark
|
||||||
|
; Author: Richard Gabriel
|
||||||
|
; Created: 12-Apr-85
|
||||||
|
; Modified: 12-Apr-85 10:12:43 (Bob Shaw)
|
||||||
|
; 22-Jul-87 (Will Clinger)
|
||||||
|
; 10-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache
|
||||||
|
;;; memory effects. Results should be the same as for TAK on stack machines.
|
||||||
|
;;; Distribution of calls is not completely flat.
|
||||||
|
|
||||||
|
(: tak (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak x y z)
|
||||||
|
(: tak0 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak0 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak1 (tak37 (- x 1) y z)
|
||||||
|
(tak11 (- y 1) z x)
|
||||||
|
(tak17 (- z 1) x y)))))
|
||||||
|
(: tak1 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak1 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak2 (tak74 (- x 1) y z)
|
||||||
|
(tak22 (- y 1) z x)
|
||||||
|
(tak34 (- z 1) x y)))))
|
||||||
|
(: tak2 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak2 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak3 (tak11 (- x 1) y z)
|
||||||
|
(tak33 (- y 1) z x)
|
||||||
|
(tak51 (- z 1) x y)))))
|
||||||
|
(: tak3 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak3 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak4 (tak48 (- x 1) y z)
|
||||||
|
(tak44 (- y 1) z x)
|
||||||
|
(tak68 (- z 1) x y)))))
|
||||||
|
(: tak4 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak4 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak5 (tak85 (- x 1) y z)
|
||||||
|
(tak55 (- y 1) z x)
|
||||||
|
(tak85 (- z 1) x y)))))
|
||||||
|
(: tak5 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak5 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak6 (tak22 (- x 1) y z)
|
||||||
|
(tak66 (- y 1) z x)
|
||||||
|
(tak2 (- z 1) x y)))))
|
||||||
|
(: tak6 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak6 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak7 (tak59 (- x 1) y z)
|
||||||
|
(tak77 (- y 1) z x)
|
||||||
|
(tak19 (- z 1) x y)))))
|
||||||
|
(: tak7 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak7 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak8 (tak96 (- x 1) y z)
|
||||||
|
(tak88 (- y 1) z x)
|
||||||
|
(tak36 (- z 1) x y)))))
|
||||||
|
(: tak8 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak8 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak9 (tak33 (- x 1) y z)
|
||||||
|
(tak99 (- y 1) z x)
|
||||||
|
(tak53 (- z 1) x y)))))
|
||||||
|
(: tak9 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak9 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak10 (tak70 (- x 1) y z)
|
||||||
|
(tak10 (- y 1) z x)
|
||||||
|
(tak70 (- z 1) x y)))))
|
||||||
|
(: tak10 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak10 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak11 (tak7 (- x 1) y z)
|
||||||
|
(tak21 (- y 1) z x)
|
||||||
|
(tak87 (- z 1) x y)))))
|
||||||
|
(: tak11 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak11 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak12 (tak44 (- x 1) y z)
|
||||||
|
(tak32 (- y 1) z x)
|
||||||
|
(tak4 (- z 1) x y)))))
|
||||||
|
(: tak12 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak12 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak13 (tak81 (- x 1) y z)
|
||||||
|
(tak43 (- y 1) z x)
|
||||||
|
(tak21 (- z 1) x y)))))
|
||||||
|
(: tak13 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak13 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak14 (tak18 (- x 1) y z)
|
||||||
|
(tak54 (- y 1) z x)
|
||||||
|
(tak38 (- z 1) x y)))))
|
||||||
|
(: tak14 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak14 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak15 (tak55 (- x 1) y z)
|
||||||
|
(tak65 (- y 1) z x)
|
||||||
|
(tak55 (- z 1) x y)))))
|
||||||
|
(: tak15 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak15 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak16 (tak92 (- x 1) y z)
|
||||||
|
(tak76 (- y 1) z x)
|
||||||
|
(tak72 (- z 1) x y)))))
|
||||||
|
(: tak16 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak16 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak17 (tak29 (- x 1) y z)
|
||||||
|
(tak87 (- y 1) z x)
|
||||||
|
(tak89 (- z 1) x y)))))
|
||||||
|
(: tak17 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak17 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak18 (tak66 (- x 1) y z)
|
||||||
|
(tak98 (- y 1) z x)
|
||||||
|
(tak6 (- z 1) x y)))))
|
||||||
|
(: tak18 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak18 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak19 (tak3 (- x 1) y z)
|
||||||
|
(tak9 (- y 1) z x)
|
||||||
|
(tak23 (- z 1) x y)))))
|
||||||
|
(: tak19 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak19 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak20 (tak40 (- x 1) y z)
|
||||||
|
(tak20 (- y 1) z x)
|
||||||
|
(tak40 (- z 1) x y)))))
|
||||||
|
(: tak20 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak20 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak21 (tak77 (- x 1) y z)
|
||||||
|
(tak31 (- y 1) z x)
|
||||||
|
(tak57 (- z 1) x y)))))
|
||||||
|
(: tak21 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak21 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak22 (tak14 (- x 1) y z)
|
||||||
|
(tak42 (- y 1) z x)
|
||||||
|
(tak74 (- z 1) x y)))))
|
||||||
|
(: tak22 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak22 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak23 (tak51 (- x 1) y z)
|
||||||
|
(tak53 (- y 1) z x)
|
||||||
|
(tak91 (- z 1) x y)))))
|
||||||
|
(: tak23 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak23 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak24 (tak88 (- x 1) y z)
|
||||||
|
(tak64 (- y 1) z x)
|
||||||
|
(tak8 (- z 1) x y)))))
|
||||||
|
(: tak24 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak24 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak25 (tak25 (- x 1) y z)
|
||||||
|
(tak75 (- y 1) z x)
|
||||||
|
(tak25 (- z 1) x y)))))
|
||||||
|
(: tak25 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak25 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak26 (tak62 (- x 1) y z)
|
||||||
|
(tak86 (- y 1) z x)
|
||||||
|
(tak42 (- z 1) x y)))))
|
||||||
|
(: tak26 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak26 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak27 (tak99 (- x 1) y z)
|
||||||
|
(tak97 (- y 1) z x)
|
||||||
|
(tak59 (- z 1) x y)))))
|
||||||
|
(: tak27 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak27 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak28 (tak36 (- x 1) y z)
|
||||||
|
(tak8 (- y 1) z x)
|
||||||
|
(tak76 (- z 1) x y)))))
|
||||||
|
(: tak28 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak28 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak29 (tak73 (- x 1) y z)
|
||||||
|
(tak19 (- y 1) z x)
|
||||||
|
(tak93 (- z 1) x y)))))
|
||||||
|
(: tak29 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak29 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak30 (tak10 (- x 1) y z)
|
||||||
|
(tak30 (- y 1) z x)
|
||||||
|
(tak10 (- z 1) x y)))))
|
||||||
|
(: tak30 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak30 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak31 (tak47 (- x 1) y z)
|
||||||
|
(tak41 (- y 1) z x)
|
||||||
|
(tak27 (- z 1) x y)))))
|
||||||
|
(: tak31 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak31 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak32 (tak84 (- x 1) y z)
|
||||||
|
(tak52 (- y 1) z x)
|
||||||
|
(tak44 (- z 1) x y)))))
|
||||||
|
(: tak32 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak32 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak33 (tak21 (- x 1) y z)
|
||||||
|
(tak63 (- y 1) z x)
|
||||||
|
(tak61 (- z 1) x y)))))
|
||||||
|
(: tak33 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak33 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak34 (tak58 (- x 1) y z)
|
||||||
|
(tak74 (- y 1) z x)
|
||||||
|
(tak78 (- z 1) x y)))))
|
||||||
|
(: tak34 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak34 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak35 (tak95 (- x 1) y z)
|
||||||
|
(tak85 (- y 1) z x)
|
||||||
|
(tak95 (- z 1) x y)))))
|
||||||
|
(: tak35 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak35 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak36 (tak32 (- x 1) y z)
|
||||||
|
(tak96 (- y 1) z x)
|
||||||
|
(tak12 (- z 1) x y)))))
|
||||||
|
(: tak36 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak36 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak37 (tak69 (- x 1) y z)
|
||||||
|
(tak7 (- y 1) z x)
|
||||||
|
(tak29 (- z 1) x y)))))
|
||||||
|
(: tak37 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak37 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak38 (tak6 (- x 1) y z)
|
||||||
|
(tak18 (- y 1) z x)
|
||||||
|
(tak46 (- z 1) x y)))))
|
||||||
|
(: tak38 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak38 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak39 (tak43 (- x 1) y z)
|
||||||
|
(tak29 (- y 1) z x)
|
||||||
|
(tak63 (- z 1) x y)))))
|
||||||
|
(: tak39 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak39 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak40 (tak80 (- x 1) y z)
|
||||||
|
(tak40 (- y 1) z x)
|
||||||
|
(tak80 (- z 1) x y)))))
|
||||||
|
(: tak40 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak40 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak41 (tak17 (- x 1) y z)
|
||||||
|
(tak51 (- y 1) z x)
|
||||||
|
(tak97 (- z 1) x y)))))
|
||||||
|
(: tak41 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak41 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak42 (tak54 (- x 1) y z)
|
||||||
|
(tak62 (- y 1) z x)
|
||||||
|
(tak14 (- z 1) x y)))))
|
||||||
|
(: tak42 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak42 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak43 (tak91 (- x 1) y z)
|
||||||
|
(tak73 (- y 1) z x)
|
||||||
|
(tak31 (- z 1) x y)))))
|
||||||
|
(: tak43 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak43 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak44 (tak28 (- x 1) y z)
|
||||||
|
(tak84 (- y 1) z x)
|
||||||
|
(tak48 (- z 1) x y)))))
|
||||||
|
(: tak44 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak44 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak45 (tak65 (- x 1) y z)
|
||||||
|
(tak95 (- y 1) z x)
|
||||||
|
(tak65 (- z 1) x y)))))
|
||||||
|
(: tak45 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak45 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak46 (tak2 (- x 1) y z)
|
||||||
|
(tak6 (- y 1) z x)
|
||||||
|
(tak82 (- z 1) x y)))))
|
||||||
|
(: tak46 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak46 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak47 (tak39 (- x 1) y z)
|
||||||
|
(tak17 (- y 1) z x)
|
||||||
|
(tak99 (- z 1) x y)))))
|
||||||
|
(: tak47 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak47 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak48 (tak76 (- x 1) y z)
|
||||||
|
(tak28 (- y 1) z x)
|
||||||
|
(tak16 (- z 1) x y)))))
|
||||||
|
(: tak48 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak48 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak49 (tak13 (- x 1) y z)
|
||||||
|
(tak39 (- y 1) z x)
|
||||||
|
(tak33 (- z 1) x y)))))
|
||||||
|
(: tak49 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak49 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak50 (tak50 (- x 1) y z)
|
||||||
|
(tak50 (- y 1) z x)
|
||||||
|
(tak50 (- z 1) x y)))))
|
||||||
|
(: tak50 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak50 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak51 (tak87 (- x 1) y z)
|
||||||
|
(tak61 (- y 1) z x)
|
||||||
|
(tak67 (- z 1) x y)))))
|
||||||
|
(: tak51 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak51 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak52 (tak24 (- x 1) y z)
|
||||||
|
(tak72 (- y 1) z x)
|
||||||
|
(tak84 (- z 1) x y)))))
|
||||||
|
(: tak52 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak52 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak53 (tak61 (- x 1) y z)
|
||||||
|
(tak83 (- y 1) z x)
|
||||||
|
(tak1 (- z 1) x y)))))
|
||||||
|
(: tak53 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak53 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak54 (tak98 (- x 1) y z)
|
||||||
|
(tak94 (- y 1) z x)
|
||||||
|
(tak18 (- z 1) x y)))))
|
||||||
|
(: tak54 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak54 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak55 (tak35 (- x 1) y z)
|
||||||
|
(tak5 (- y 1) z x)
|
||||||
|
(tak35 (- z 1) x y)))))
|
||||||
|
(: tak55 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak55 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak56 (tak72 (- x 1) y z)
|
||||||
|
(tak16 (- y 1) z x)
|
||||||
|
(tak52 (- z 1) x y)))))
|
||||||
|
(: tak56 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak56 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak57 (tak9 (- x 1) y z)
|
||||||
|
(tak27 (- y 1) z x)
|
||||||
|
(tak69 (- z 1) x y)))))
|
||||||
|
(: tak57 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak57 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak58 (tak46 (- x 1) y z)
|
||||||
|
(tak38 (- y 1) z x)
|
||||||
|
(tak86 (- z 1) x y)))))
|
||||||
|
(: tak58 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak58 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak59 (tak83 (- x 1) y z)
|
||||||
|
(tak49 (- y 1) z x)
|
||||||
|
(tak3 (- z 1) x y)))))
|
||||||
|
(: tak59 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak59 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak60 (tak20 (- x 1) y z)
|
||||||
|
(tak60 (- y 1) z x)
|
||||||
|
(tak20 (- z 1) x y)))))
|
||||||
|
(: tak60 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak60 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak61 (tak57 (- x 1) y z)
|
||||||
|
(tak71 (- y 1) z x)
|
||||||
|
(tak37 (- z 1) x y)))))
|
||||||
|
(: tak61 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak61 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak62 (tak94 (- x 1) y z)
|
||||||
|
(tak82 (- y 1) z x)
|
||||||
|
(tak54 (- z 1) x y)))))
|
||||||
|
(: tak62 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak62 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak63 (tak31 (- x 1) y z)
|
||||||
|
(tak93 (- y 1) z x)
|
||||||
|
(tak71 (- z 1) x y)))))
|
||||||
|
(: tak63 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak63 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak64 (tak68 (- x 1) y z)
|
||||||
|
(tak4 (- y 1) z x)
|
||||||
|
(tak88 (- z 1) x y)))))
|
||||||
|
(: tak64 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak64 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak65 (tak5 (- x 1) y z)
|
||||||
|
(tak15 (- y 1) z x)
|
||||||
|
(tak5 (- z 1) x y)))))
|
||||||
|
(: tak65 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak65 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak66 (tak42 (- x 1) y z)
|
||||||
|
(tak26 (- y 1) z x)
|
||||||
|
(tak22 (- z 1) x y)))))
|
||||||
|
(: tak66 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak66 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak67 (tak79 (- x 1) y z)
|
||||||
|
(tak37 (- y 1) z x)
|
||||||
|
(tak39 (- z 1) x y)))))
|
||||||
|
(: tak67 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak67 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak68 (tak16 (- x 1) y z)
|
||||||
|
(tak48 (- y 1) z x)
|
||||||
|
(tak56 (- z 1) x y)))))
|
||||||
|
(: tak68 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak68 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak69 (tak53 (- x 1) y z)
|
||||||
|
(tak59 (- y 1) z x)
|
||||||
|
(tak73 (- z 1) x y)))))
|
||||||
|
(: tak69 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak69 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak70 (tak90 (- x 1) y z)
|
||||||
|
(tak70 (- y 1) z x)
|
||||||
|
(tak90 (- z 1) x y)))))
|
||||||
|
(: tak70 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak70 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak71 (tak27 (- x 1) y z)
|
||||||
|
(tak81 (- y 1) z x)
|
||||||
|
(tak7 (- z 1) x y)))))
|
||||||
|
(: tak71 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak71 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak72 (tak64 (- x 1) y z)
|
||||||
|
(tak92 (- y 1) z x)
|
||||||
|
(tak24 (- z 1) x y)))))
|
||||||
|
(: tak72 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak72 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak73 (tak1 (- x 1) y z)
|
||||||
|
(tak3 (- y 1) z x)
|
||||||
|
(tak41 (- z 1) x y)))))
|
||||||
|
(: tak73 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak73 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak74 (tak38 (- x 1) y z)
|
||||||
|
(tak14 (- y 1) z x)
|
||||||
|
(tak58 (- z 1) x y)))))
|
||||||
|
(: tak74 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak74 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak75 (tak75 (- x 1) y z)
|
||||||
|
(tak25 (- y 1) z x)
|
||||||
|
(tak75 (- z 1) x y)))))
|
||||||
|
(: tak75 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak75 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak76 (tak12 (- x 1) y z)
|
||||||
|
(tak36 (- y 1) z x)
|
||||||
|
(tak92 (- z 1) x y)))))
|
||||||
|
(: tak76 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak76 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak77 (tak49 (- x 1) y z)
|
||||||
|
(tak47 (- y 1) z x)
|
||||||
|
(tak9 (- z 1) x y)))))
|
||||||
|
(: tak77 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak77 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak78 (tak86 (- x 1) y z)
|
||||||
|
(tak58 (- y 1) z x)
|
||||||
|
(tak26 (- z 1) x y)))))
|
||||||
|
(: tak78 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak78 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak79 (tak23 (- x 1) y z)
|
||||||
|
(tak69 (- y 1) z x)
|
||||||
|
(tak43 (- z 1) x y)))))
|
||||||
|
(: tak79 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak79 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak80 (tak60 (- x 1) y z)
|
||||||
|
(tak80 (- y 1) z x)
|
||||||
|
(tak60 (- z 1) x y)))))
|
||||||
|
(: tak80 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak80 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak81 (tak97 (- x 1) y z)
|
||||||
|
(tak91 (- y 1) z x)
|
||||||
|
(tak77 (- z 1) x y)))))
|
||||||
|
(: tak81 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak81 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak82 (tak34 (- x 1) y z)
|
||||||
|
(tak2 (- y 1) z x)
|
||||||
|
(tak94 (- z 1) x y)))))
|
||||||
|
(: tak82 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak82 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak83 (tak71 (- x 1) y z)
|
||||||
|
(tak13 (- y 1) z x)
|
||||||
|
(tak11 (- z 1) x y)))))
|
||||||
|
(: tak83 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak83 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak84 (tak8 (- x 1) y z)
|
||||||
|
(tak24 (- y 1) z x)
|
||||||
|
(tak28 (- z 1) x y)))))
|
||||||
|
(: tak84 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak84 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak85 (tak45 (- x 1) y z)
|
||||||
|
(tak35 (- y 1) z x)
|
||||||
|
(tak45 (- z 1) x y)))))
|
||||||
|
(: tak85 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak85 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak86 (tak82 (- x 1) y z)
|
||||||
|
(tak46 (- y 1) z x)
|
||||||
|
(tak62 (- z 1) x y)))))
|
||||||
|
(: tak86 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak86 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak87 (tak19 (- x 1) y z)
|
||||||
|
(tak57 (- y 1) z x)
|
||||||
|
(tak79 (- z 1) x y)))))
|
||||||
|
(: tak87 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak87 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak88 (tak56 (- x 1) y z)
|
||||||
|
(tak68 (- y 1) z x)
|
||||||
|
(tak96 (- z 1) x y)))))
|
||||||
|
(: tak88 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak88 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak89 (tak93 (- x 1) y z)
|
||||||
|
(tak79 (- y 1) z x)
|
||||||
|
(tak13 (- z 1) x y)))))
|
||||||
|
(: tak89 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak89 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak90 (tak30 (- x 1) y z)
|
||||||
|
(tak90 (- y 1) z x)
|
||||||
|
(tak30 (- z 1) x y)))))
|
||||||
|
(: tak90 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak90 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak91 (tak67 (- x 1) y z)
|
||||||
|
(tak1 (- y 1) z x)
|
||||||
|
(tak47 (- z 1) x y)))))
|
||||||
|
(: tak91 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak91 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak92 (tak4 (- x 1) y z)
|
||||||
|
(tak12 (- y 1) z x)
|
||||||
|
(tak64 (- z 1) x y)))))
|
||||||
|
(: tak92 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak92 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak93 (tak41 (- x 1) y z)
|
||||||
|
(tak23 (- y 1) z x)
|
||||||
|
(tak81 (- z 1) x y)))))
|
||||||
|
(: tak93 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak93 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak94 (tak78 (- x 1) y z)
|
||||||
|
(tak34 (- y 1) z x)
|
||||||
|
(tak98 (- z 1) x y)))))
|
||||||
|
(: tak94 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak94 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak95 (tak15 (- x 1) y z)
|
||||||
|
(tak45 (- y 1) z x)
|
||||||
|
(tak15 (- z 1) x y)))))
|
||||||
|
(: tak95 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak95 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak96 (tak52 (- x 1) y z)
|
||||||
|
(tak56 (- y 1) z x)
|
||||||
|
(tak32 (- z 1) x y)))))
|
||||||
|
(: tak96 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak96 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak97 (tak89 (- x 1) y z)
|
||||||
|
(tak67 (- y 1) z x)
|
||||||
|
(tak49 (- z 1) x y)))))
|
||||||
|
(: tak97 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak97 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak98 (tak26 (- x 1) y z)
|
||||||
|
(tak78 (- y 1) z x)
|
||||||
|
(tak66 (- z 1) x y)))))
|
||||||
|
(: tak98 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak98 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak99 (tak63 (- x 1) y z)
|
||||||
|
(tak89 (- y 1) z x)
|
||||||
|
(tak83 (- z 1) x y)))))
|
||||||
|
(: tak99 (Integer Integer Integer -> Integer))
|
||||||
|
(define (tak99 x y z)
|
||||||
|
(cond ((not (< y x)) z)
|
||||||
|
(else (tak0 (tak0 (- x 1) y z)
|
||||||
|
(tak0 (- y 1) z x)
|
||||||
|
(tak0 (- z 1) x y)))))
|
||||||
|
|
||||||
|
(tak0 x y z))
|
||||||
|
|
||||||
|
;;; call: (tak0 18 12 6)
|
||||||
|
|
||||||
|
(let ((input (with-input-from-file "input.txt" read)))
|
||||||
|
(time
|
||||||
|
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
|
||||||
|
(if (zero? n)
|
||||||
|
v
|
||||||
|
(loop (- n 1) (tak 18 12 (if input 6 0)))))))
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module triangle-typed-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
|
||||||
|
(module triangle-typed-optimizing "wrap-typed-optimizing.ss")
|
||||||
97
collects/tests/racket/benchmarks/common/triangle-typed.rktl
Normal file
97
collects/tests/racket/benchmarks/common/triangle-typed.rktl
Normal file
|
|
@ -0,0 +1,97 @@
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
; File: triangle.sch
|
||||||
|
; Description: TRIANGLE benchmark
|
||||||
|
; Author: Richard Gabriel
|
||||||
|
; Created: 12-Apr-85
|
||||||
|
; Modified: 12-Apr-85 10:30:32 (Bob Shaw)
|
||||||
|
; 11-Aug-87 (Will Clinger)
|
||||||
|
; 22-Jan-88 (Will Clinger)
|
||||||
|
; 10-May-10 (Vincent St-Amour)
|
||||||
|
; Language: Typed Scheme
|
||||||
|
; Status: Public Domain
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; TRIANG -- Board game benchmark.
|
||||||
|
|
||||||
|
(: *board* (Vectorof Integer))
|
||||||
|
(define *board* (make-vector 16 1))
|
||||||
|
(: *sequence* (Vectorof Integer))
|
||||||
|
(define *sequence* (make-vector 14 0))
|
||||||
|
(: *a* (Vectorof Integer))
|
||||||
|
(define *a* (make-vector 37))
|
||||||
|
(: *b* (Vectorof Integer))
|
||||||
|
(define *b* (make-vector 37))
|
||||||
|
(: *c* (Vectorof Integer))
|
||||||
|
(define *c* (make-vector 37))
|
||||||
|
(: *answer* (Listof (Listof Integer)))
|
||||||
|
(define *answer* '())
|
||||||
|
(: *final* (Listof Integer))
|
||||||
|
(define *final* '())
|
||||||
|
|
||||||
|
(: last-position ( -> Integer))
|
||||||
|
(define (last-position)
|
||||||
|
(do ((i 1 (+ i 1)))
|
||||||
|
((or (= i 16) (= 1 (vector-ref *board* i)))
|
||||||
|
(if (= i 16) 0 i))))
|
||||||
|
|
||||||
|
(: ttry (Integer Integer -> Any))
|
||||||
|
(define (ttry i depth)
|
||||||
|
(cond ((= depth 14)
|
||||||
|
(let ((lp (last-position)))
|
||||||
|
(if (not (member lp *final*))
|
||||||
|
(set! *final* (cons lp *final*))
|
||||||
|
#t))
|
||||||
|
(set! *answer*
|
||||||
|
(cons (cdr (vector->list *sequence*)) *answer*))
|
||||||
|
#t)
|
||||||
|
((and (= 1 (vector-ref *board* (vector-ref *a* i)))
|
||||||
|
(= 1 (vector-ref *board* (vector-ref *b* i)))
|
||||||
|
(= 0 (vector-ref *board* (vector-ref *c* i))))
|
||||||
|
(vector-set! *board* (vector-ref *a* i) 0)
|
||||||
|
(vector-set! *board* (vector-ref *b* i) 0)
|
||||||
|
(vector-set! *board* (vector-ref *c* i) 1)
|
||||||
|
(vector-set! *sequence* depth i)
|
||||||
|
(do ((j 0 (+ j 1))
|
||||||
|
(depth (+ depth 1)))
|
||||||
|
((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) '())
|
||||||
|
(else #f)))
|
||||||
|
|
||||||
|
(: gogogo (Integer -> Any))
|
||||||
|
(define (gogogo i)
|
||||||
|
(let ((*answer* '())
|
||||||
|
(*final* '()))
|
||||||
|
(ttry i 1)))
|
||||||
|
|
||||||
|
(for-each (lambda: ((i : Integer) (x : Integer)) (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 : Integer) (x : Integer)) (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 : Integer) (x : Integer)) (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 : 'done ((n : Integer 100000))
|
||||||
|
(if (zero? n)
|
||||||
|
'done
|
||||||
|
(begin
|
||||||
|
(gogogo 22)
|
||||||
|
(loop (- n 1))))))
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
|
||||||
|
(module wrap-typed-non-optimizing racket
|
||||||
|
(provide (rename-out (module-begin #%module-begin)))
|
||||||
|
(require (lib "include.ss"))
|
||||||
|
(require (prefix-in ts: typed/scheme/base))
|
||||||
|
(require typed/scheme/base)
|
||||||
|
(define-syntax (module-begin stx)
|
||||||
|
(let ([name (symbol->string (syntax-property stx 'enclosing-module-name))])
|
||||||
|
#`(ts:#%module-begin
|
||||||
|
(include #,(format "~a.rktl"
|
||||||
|
(substring name
|
||||||
|
0
|
||||||
|
(caar (regexp-match-positions
|
||||||
|
#rx"-non-optimizing"
|
||||||
|
name)))))))))
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
|
||||||
|
(module wrap-typed-optimizing racket
|
||||||
|
(provide (rename-out (module-begin #%module-begin)))
|
||||||
|
(require (lib "include.ss"))
|
||||||
|
(require (prefix-in ts: typed/scheme/base))
|
||||||
|
(require typed/scheme/base)
|
||||||
|
(define-syntax (module-begin stx)
|
||||||
|
(let ([name (symbol->string (syntax-property stx 'enclosing-module-name))])
|
||||||
|
#`(ts:#%module-begin #:optimize
|
||||||
|
(include #,(format "~a.rktl"
|
||||||
|
(substring name
|
||||||
|
0
|
||||||
|
(caar (regexp-match-positions
|
||||||
|
#rx"-optimizing"
|
||||||
|
name)))))))))
|
||||||
|
|
@ -1,22 +1,26 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;;; The Great Computer Language Shootout
|
;;; The Great Computer Language Shootout
|
||||||
;;; http://shootout.alioth.debian.org/
|
;;; http://shootout.alioth.debian.org/
|
||||||
;;; Derived from the Chicken variant by Sven Hartrumpf
|
;;; Derived from the Chicken variant by Sven Hartrumpf
|
||||||
#lang scheme/base
|
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
(define-struct node (left val right))
|
(require racket/cmdline)
|
||||||
|
|
||||||
|
(struct node (left val right))
|
||||||
|
|
||||||
;; Instead of (define-struct leaf (val)):
|
;; Instead of (define-struct leaf (val)):
|
||||||
(define (make-leaf val) (make-node #f val #f))
|
(define (leaf val) (node #f val #f))
|
||||||
(define (leaf? l) (not (node-left l)))
|
(define (leaf? l) (not (node-left l)))
|
||||||
(define (leaf-val l) (node-val l))
|
(define (leaf-val l) (node-val l))
|
||||||
|
|
||||||
(define (make item d)
|
(define (make item d)
|
||||||
(if (= d 0)
|
(if (= d 0)
|
||||||
(make-leaf item)
|
(leaf item)
|
||||||
(let ((item2 (* item 2))
|
(let ((item2 (* item 2))
|
||||||
(d2 (- d 1)))
|
(d2 (- d 1)))
|
||||||
(make-node (make (- item2 1) d2) item (make item2 d2)))))
|
(node (make (- item2 1) d2)
|
||||||
|
item
|
||||||
|
(make item2 d2)))))
|
||||||
|
|
||||||
(define (check t)
|
(define (check t)
|
||||||
(if (leaf? t)
|
(if (leaf? t)
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,12 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;;; The Great Computer Language Shootout
|
;;; The Great Computer Language Shootout
|
||||||
;;; http://shootout.alioth.debian.org/
|
;;; http://shootout.alioth.debian.org/
|
||||||
;;;
|
;;;
|
||||||
;;; Uses PLT Scheme threads
|
;;; Uses Racket threads
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline
|
racket/match)
|
||||||
scheme/match)
|
|
||||||
|
|
||||||
(define (change c1 c2)
|
(define (change c1 c2)
|
||||||
(case c1
|
(case c1
|
||||||
|
|
@ -96,5 +97,3 @@
|
||||||
(go n '(blue red yellow))
|
(go n '(blue red yellow))
|
||||||
(go n '(blue red yellow red yellow blue red yellow red blue))
|
(go n '(blue red yellow red yellow blue red yellow red blue))
|
||||||
(newline))
|
(newline))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,12 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; fannkuch benchmark for The Computer Language Shootout
|
;; fannkuch benchmark for The Computer Language Shootout
|
||||||
;; Written by Dima Dorfman, 2004
|
;; Written by Dima Dorfman, 2004
|
||||||
;; Slightly improved by Sven Hartrumpf, 2005-2006
|
;; Slightly improved by Sven Hartrumpf, 2005-2006
|
||||||
;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham
|
;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham
|
||||||
;; PLT-ized for v4.0 by Matthew
|
;; PLT-ized for v4.0 by Matthew
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
(define (fannkuch n)
|
(define (fannkuch n)
|
||||||
(let ([pi (list->vector
|
(let ([pi (list->vector
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -6,8 +8,7 @@
|
||||||
;; Derived from the Chicken variant, which was
|
;; Derived from the Chicken variant, which was
|
||||||
;; Contributed by Anthony Borla
|
;; Contributed by Anthony Borla
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
(define +alu+
|
(define +alu+
|
||||||
(bytes-append
|
(bytes-append
|
||||||
|
|
@ -40,7 +41,7 @@
|
||||||
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
|
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
|
||||||
(lambda (max)
|
(lambda (max)
|
||||||
(set! last (modulo (+ ic (* last ia)) im))
|
(set! last (modulo (+ ic (* last ia)) im))
|
||||||
(/ (* max last) im) )))
|
(/ (* max last) im))))
|
||||||
|
|
||||||
;; -------------------------------
|
;; -------------------------------
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Shootout
|
;; The Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
|
|
||||||
#lang scheme/base
|
|
||||||
|
|
||||||
(define (all-counts len dna)
|
(define (all-counts len dna)
|
||||||
(let ([table (make-hasheq)]
|
(let ([table (make-hasheq)]
|
||||||
[seq (make-string len)])
|
[seq (make-string len)])
|
||||||
|
|
@ -16,12 +16,10 @@
|
||||||
(define (write-freqs table)
|
(define (write-freqs table)
|
||||||
(let* ([content (hash-map table cons)]
|
(let* ([content (hash-map table cons)]
|
||||||
[total (exact->inexact (apply + (map cdr content)))])
|
[total (exact->inexact (apply + (map cdr content)))])
|
||||||
(for-each
|
(for ([a (sort content > #:key cdr)])
|
||||||
(lambda (a)
|
(printf "~a ~a\n"
|
||||||
(printf "~a ~a\n"
|
(car a)
|
||||||
(car a)
|
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))))
|
||||||
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))
|
|
||||||
(sort content (lambda (a b) (> (cdr a) (cdr b)))))))
|
|
||||||
|
|
||||||
(define (write-one-freq table key)
|
(define (write-one-freq table key)
|
||||||
(let ([cnt (hash-ref table key 0)])
|
(let ([cnt (hash-ref table key 0)])
|
||||||
|
|
@ -33,9 +31,8 @@
|
||||||
(regexp-match #rx#"(?m:^>THREE.*$)" in)
|
(regexp-match #rx#"(?m:^>THREE.*$)" in)
|
||||||
(let ([s (open-output-string)])
|
(let ([s (open-output-string)])
|
||||||
;; Copy everything but newlines to s:
|
;; Copy everything but newlines to s:
|
||||||
(let loop ()
|
(for ([l (in-bytes-lines in)])
|
||||||
(when (regexp-match #rx#"\n" in 0 #f s)
|
(write-bytes l s))
|
||||||
(loop)))
|
|
||||||
;; Extract the string from s:
|
;; Extract the string from s:
|
||||||
(string-upcase (get-output-string s)))))
|
(string-upcase (get-output-string s)))))
|
||||||
|
|
||||||
|
|
@ -48,8 +45,6 @@
|
||||||
(newline)
|
(newline)
|
||||||
|
|
||||||
;; Specific sequences:
|
;; Specific sequences:
|
||||||
(for-each (lambda (seq)
|
(for ([seq '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT")])
|
||||||
(write-one-freq (all-counts (string-length seq) dna)
|
(write-one-freq (all-counts (string-length seq) dna)
|
||||||
(string->symbol seq)))
|
(string->symbol seq)))
|
||||||
'("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
;; ---------------------------------------------------------------------
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -16,8 +17,7 @@
|
||||||
;; [(> (magnitude z) 2.0) 0]
|
;; [(> (magnitude z) 2.0) 0]
|
||||||
;; [else (loop (add1 i) (+ (* z z) c))]))))
|
;; [else (loop (add1 i) (+ (* z z) c))]))))
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
(define +limit-sqr+ 4.0)
|
(define +limit-sqr+ 4.0)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
;; ---------------------------------------------------------------------
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -7,12 +8,11 @@
|
||||||
;;
|
;;
|
||||||
;; This version uses unsafe operations
|
;; This version uses unsafe operations
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline
|
racket/require (for-syntax racket/base)
|
||||||
scheme/require (for-syntax scheme/base)
|
|
||||||
(filtered-in
|
(filtered-in
|
||||||
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||||
scheme/unsafe/ops))
|
racket/unsafe/ops))
|
||||||
|
|
||||||
(define +limit-sqr+ 4.0)
|
(define +limit-sqr+ 4.0)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,13 @@
|
||||||
;; ---------------------------------------------------------------------
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
;; Derived from the Chicken variant, which was
|
;; Derived from the Chicken variant, which was
|
||||||
;; Contributed by Anthony Borla
|
;; Contributed by Anthony Borla
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline
|
racket/flonum)
|
||||||
scheme/flonum)
|
|
||||||
|
|
||||||
(define +limit-sqr+ 4.0)
|
(define +limit-sqr+ 4.0)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Benchmarks Game
|
;; The Computer Language Benchmarks Game
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -7,8 +9,7 @@
|
||||||
;; contributed by Matthew Flatt
|
;; contributed by Matthew Flatt
|
||||||
;; optimized by Eli Barzilay
|
;; optimized by Eli Barzilay
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline scheme/list)
|
|
||||||
|
|
||||||
(define width 5)
|
(define width 5)
|
||||||
(define height 10)
|
(define height 10)
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
#!/usr/bin/mzscheme -qu
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Benchmarks Game
|
;; The Computer Language Benchmarks Game
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -6,7 +7,7 @@
|
||||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||||
;; idioms like 'named let' and 'do' special form.
|
;; idioms like 'named let' and 'do' special form.
|
||||||
;;
|
;;
|
||||||
;; Contributed by Anthony Borla, then converted for mzscheme
|
;; Contributed by Anthony Borla, then converted for Racket
|
||||||
;; by Matthew Flatt and Brent Fulgham
|
;; by Matthew Flatt and Brent Fulgham
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
@ -16,8 +17,7 @@ Correct output N = 1000 is
|
||||||
-0.169087605
|
-0.169087605
|
||||||
|#
|
|#
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
;; ------------------------------
|
;; ------------------------------
|
||||||
;; define planetary masses, initial positions & velocity
|
;; define planetary masses, initial positions & velocity
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
#!/usr/bin/mzscheme -qu
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Benchmarks Game
|
;; The Computer Language Benchmarks Game
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -6,7 +7,7 @@
|
||||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||||
;; idioms like 'named let' and 'do' special form.
|
;; idioms like 'named let' and 'do' special form.
|
||||||
;;
|
;;
|
||||||
;; Contributed by Anthony Borla, then converted for mzscheme
|
;; Contributed by Anthony Borla, then converted for Racket
|
||||||
;; by Matthew Flatt and Brent Fulgham
|
;; by Matthew Flatt and Brent Fulgham
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
@ -16,8 +17,7 @@ Correct output N = 1000 is
|
||||||
-0.169087605
|
-0.169087605
|
||||||
|#
|
|#
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
;; ------------------------------
|
;; ------------------------------
|
||||||
;; define planetary masses, initial positions & velocity
|
;; define planetary masses, initial positions & velocity
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
#!/usr/bin/mzscheme -qu
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Benchmarks Game
|
;; The Computer Language Benchmarks Game
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -6,7 +7,7 @@
|
||||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||||
;; idioms like 'named let' and 'do' special form.
|
;; idioms like 'named let' and 'do' special form.
|
||||||
;;
|
;;
|
||||||
;; Contributed by Anthony Borla, then converted for mzscheme
|
;; Contributed by Anthony Borla, then converted for Racket
|
||||||
;; by Matthew Flatt and Brent Fulgham
|
;; by Matthew Flatt and Brent Fulgham
|
||||||
;; Made unsafe and optimized by Sam TH
|
;; Made unsafe and optimized by Sam TH
|
||||||
#|
|
#|
|
||||||
|
|
@ -16,15 +17,14 @@ Correct output N = 1000 is
|
||||||
-0.169087605
|
-0.169087605
|
||||||
|#
|
|#
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline racket/require
|
||||||
(require scheme/cmdline scheme/require
|
(only-in racket/flonum flvector)
|
||||||
(only-in scheme/flonum flvector)
|
(for-syntax racket/base)
|
||||||
(for-syntax scheme/base)
|
|
||||||
(filtered-in
|
(filtered-in
|
||||||
(lambda (name)
|
(lambda (name)
|
||||||
(regexp-replace
|
(regexp-replace
|
||||||
#rx"unsafe-fl" name "fl"))
|
#rx"unsafe-fl" name "fl"))
|
||||||
scheme/unsafe/ops))
|
racket/unsafe/ops))
|
||||||
|
|
||||||
;; ------------------------------
|
;; ------------------------------
|
||||||
;; define planetary masses, initial positions & velocity
|
;; define planetary masses, initial positions & velocity
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
#!/usr/bin/mzscheme -qu
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Benchmarks Game
|
;; The Computer Language Benchmarks Game
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -6,7 +7,7 @@
|
||||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||||
;; idioms like 'named let' and 'do' special form.
|
;; idioms like 'named let' and 'do' special form.
|
||||||
;;
|
;;
|
||||||
;; Contributed by Anthony Borla, then converted for mzscheme
|
;; Contributed by Anthony Borla, then converted for Racket
|
||||||
;; by Matthew Flatt and Brent Fulgham
|
;; by Matthew Flatt and Brent Fulgham
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
@ -16,9 +17,8 @@ Correct output N = 1000 is
|
||||||
-0.169087605
|
-0.169087605
|
||||||
|#
|
|#
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline
|
racket/flonum)
|
||||||
scheme/flonum)
|
|
||||||
|
|
||||||
;; ------------------------------
|
;; ------------------------------
|
||||||
;; define planetary masses, initial positions & velocity
|
;; define planetary masses, initial positions & velocity
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
#!/usr/bin/mzscheme -qu
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Benchmarks Game
|
;; The Computer Language Benchmarks Game
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
|
|
@ -6,7 +7,7 @@
|
||||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||||
;; idioms like 'named let' and 'do' special form.
|
;; idioms like 'named let' and 'do' special form.
|
||||||
;;
|
;;
|
||||||
;; Contributed by Anthony Borla, then converted for mzscheme
|
;; Contributed by Anthony Borla, then converted for Racket
|
||||||
;; by Matthew Flatt and Brent Fulgham
|
;; by Matthew Flatt and Brent Fulgham
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
@ -16,9 +17,8 @@ Correct output N = 1000 is
|
||||||
-0.169087605
|
-0.169087605
|
||||||
|#
|
|#
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline
|
racket/flonum)
|
||||||
scheme/flonum)
|
|
||||||
|
|
||||||
;; ------------------------------
|
;; ------------------------------
|
||||||
;; define planetary masses, initial positions & velocity
|
;; define planetary masses, initial positions & velocity
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,13 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Shootout
|
;; The Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;; Based on the Perl version of the benchmark
|
;; Based on the Perl version of the benchmark
|
||||||
;; adapted with a GMP interface by Eli Barzilay
|
;; adapted with a GMP interface by Eli Barzilay
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline)
|
(for-syntax racket/base)
|
||||||
(require (for-syntax scheme/base))
|
ffi/unsafe)
|
||||||
(require scheme/foreign) (unsafe!)
|
|
||||||
|
|
||||||
;; quick libgmp interface, limited to what we need below
|
;; quick libgmp interface, limited to what we need below
|
||||||
(define libgmp (ffi-lib "libgmp"))
|
(define libgmp (ffi-lib "libgmp"))
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,11 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Computer Language Shootout
|
;; The Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;; Based on the MLton version of the benchmark
|
;; Based on the MLton version of the benchmark
|
||||||
;; contributed by Scott Cruzen
|
;; contributed by Scott Cruzen
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
(define (floor_ev q r s t x)
|
(define (floor_ev q r s t x)
|
||||||
(quotient (+ (* q x) r) (+ (* s x) t)))
|
(quotient (+ (* q x) r) (+ (* s x) t)))
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
#!/usr/bin/mzscheme -r
|
#lang racket/base
|
||||||
|
|
||||||
; The Computer Language Shootout
|
; The Computer Language Shootout
|
||||||
; http://shootout.alioth.debian.org/
|
; http://shootout.alioth.debian.org/
|
||||||
; Sven Hartrumpf 2005-04-12
|
; Sven Hartrumpf 2005-04-12
|
||||||
|
|
@ -6,52 +7,50 @@
|
||||||
; This program is based on an implementation for SCM by Aubrey Jaffer and
|
; This program is based on an implementation for SCM by Aubrey Jaffer and
|
||||||
; Jerry D. Hedden.
|
; Jerry D. Hedden.
|
||||||
|
|
||||||
(module pidigits1 mzscheme
|
(define (pi n d)
|
||||||
|
(let* ((r (inexact->exact (floor (exp (* d (log 10)))))) ; 10^d
|
||||||
|
(p (+ (quotient n d) 1))
|
||||||
|
(m (quotient (* p d 3322) 1000))
|
||||||
|
(a (make-vector (+ m 1) 2))
|
||||||
|
(out (current-output-port)))
|
||||||
|
(vector-set! a m 4)
|
||||||
|
(let j-loop ([b 2][digits 0])
|
||||||
|
(if (= digits n)
|
||||||
|
;; Add whitespace for ungenerated digits
|
||||||
|
(let ([left (modulo digits 10)])
|
||||||
|
(unless (zero? left)
|
||||||
|
(fprintf out "~a\t:~a\n" (make-string (- 10 left) #\space) n)))
|
||||||
|
;; Compute more digits
|
||||||
|
(let loop ([k m][q 0])
|
||||||
|
(if (zero? k)
|
||||||
|
(let* ((s (let ([s (number->string (+ b (quotient q r)))])
|
||||||
|
(if (zero? digits)
|
||||||
|
s
|
||||||
|
(string-append (make-string (- d (string-length s)) #\0) s)))))
|
||||||
|
(j-loop (remainder q r)
|
||||||
|
(print-digits out s 0 (string-length s) digits n)))
|
||||||
|
(let ([q (+ q (* (vector-ref a k) r))])
|
||||||
|
(let ((t (+ (* k 2) 1)))
|
||||||
|
(let-values ([(qt rr) (quotient/remainder q t)])
|
||||||
|
(vector-set! a k rr)
|
||||||
|
(loop (sub1 k) (* k qt)))))))))))
|
||||||
|
|
||||||
(define (pi n d)
|
(define (print-digits out s start end digits n)
|
||||||
(let* ((r (inexact->exact (floor (exp (* d (log 10)))))) ; 10^d
|
(let* ([len (- end start)]
|
||||||
(p (+ (quotient n d) 1))
|
[cnt (min len (- n digits) (- 10 (modulo digits 10)) len)])
|
||||||
(m (quotient (* p d 3322) 1000))
|
(if (zero? cnt)
|
||||||
(a (make-vector (+ m 1) 2))
|
digits
|
||||||
(out (current-output-port)))
|
(begin
|
||||||
(vector-set! a m 4)
|
(write-string s out start (+ start cnt))
|
||||||
(let j-loop ([b 2][digits 0])
|
(let ([digits (+ digits cnt)])
|
||||||
(if (= digits n)
|
(when (zero? (modulo digits 10))
|
||||||
;; Add whitespace for ungenerated digits
|
(fprintf out "\t:~a\n" digits))
|
||||||
(let ([left (modulo digits 10)])
|
(print-digits out s (+ start cnt) end digits n))))))
|
||||||
(unless (zero? left)
|
|
||||||
(fprintf out "~a\t:~a\n" (make-string (- 10 left) #\space) n)))
|
|
||||||
;; Compute more digits
|
|
||||||
(let loop ([k m][q 0])
|
|
||||||
(if (zero? k)
|
|
||||||
(let* ((s (let ([s (number->string (+ b (quotient q r)))])
|
|
||||||
(if (zero? digits)
|
|
||||||
s
|
|
||||||
(string-append (make-string (- d (string-length s)) #\0) s)))))
|
|
||||||
(j-loop (remainder q r)
|
|
||||||
(print-digits out s 0 (string-length s) digits n)))
|
|
||||||
(let ([q (+ q (* (vector-ref a k) r))])
|
|
||||||
(let ((t (+ (* k 2) 1)))
|
|
||||||
(let-values ([(qt rr) (quotient/remainder q t)])
|
|
||||||
(vector-set! a k rr)
|
|
||||||
(loop (sub1 k) (* k qt)))))))))))
|
|
||||||
|
|
||||||
(define (print-digits out s start end digits n)
|
(define (main args)
|
||||||
(let* ([len (- end start)]
|
(let ((n (if (= (vector-length args) 0)
|
||||||
[cnt (min len (- n digits) (- 10 (modulo digits 10)) len)])
|
1
|
||||||
(if (zero? cnt)
|
(string->number (vector-ref args 0)))))
|
||||||
digits
|
(pi n 10)))
|
||||||
(begin
|
|
||||||
(write-string s out start (+ start cnt))
|
|
||||||
(let ([digits (+ digits cnt)])
|
|
||||||
(when (zero? (modulo digits 10))
|
|
||||||
(fprintf out "\t:~a\n" digits))
|
|
||||||
(print-digits out s (+ start cnt) end digits n))))))
|
|
||||||
|
|
||||||
(define (main args)
|
(main (current-command-line-arguments))
|
||||||
(let ((n (if (= (vector-length args) 0)
|
|
||||||
1
|
|
||||||
(string->number (vector-ref args 0)))))
|
|
||||||
(pi n 10)))
|
|
||||||
|
|
||||||
(main (current-command-line-arguments)))
|
|
||||||
|
|
|
||||||
|
|
@ -1,17 +1,11 @@
|
||||||
;; ---------------------------------------------------------------------
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
;;
|
;;
|
||||||
;; Tested with PCRE [compiler must be built with PCRE already installed
|
;; Based on a version by by Anthony Borla
|
||||||
;; else other regex routines (with different behaviours) will be used].
|
|
||||||
;; Regex performance appears reasonable, but file loading [of 'large'
|
|
||||||
;; files] performance requires tweaking to effect a significant improvement.
|
|
||||||
;;
|
|
||||||
;; Contributed by Anthony Borla
|
|
||||||
;; ---------------------------------------------------------------------
|
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/port)
|
||||||
(require scheme/port)
|
|
||||||
|
|
||||||
;; -------------------------------
|
;; -------------------------------
|
||||||
|
|
||||||
|
|
@ -40,49 +34,22 @@
|
||||||
(match-count str rx (cdar m) (add1 cnt))
|
(match-count str rx (cdar m) (add1 cnt))
|
||||||
cnt)))
|
cnt)))
|
||||||
|
|
||||||
;; --------------
|
|
||||||
|
|
||||||
(define (replace-all rx str new)
|
|
||||||
(let ([out (open-output-bytes)])
|
|
||||||
(let loop ([pos 0])
|
|
||||||
(let ([m (regexp-match-positions rx str pos)])
|
|
||||||
(if m
|
|
||||||
(begin
|
|
||||||
(write-bytes str out pos (caar m))
|
|
||||||
(write-bytes new out)
|
|
||||||
(loop (cdar m)))
|
|
||||||
(write-bytes str out pos))))
|
|
||||||
(get-output-bytes out)))
|
|
||||||
|
|
||||||
;; -------------------------------
|
|
||||||
|
|
||||||
(define (input->bytes)
|
|
||||||
(let ([b (open-output-bytes)])
|
|
||||||
(copy-port (current-input-port) b)
|
|
||||||
(get-output-bytes b)))
|
|
||||||
|
|
||||||
;; -------------------------------
|
;; -------------------------------
|
||||||
|
|
||||||
;; Load sequence and record its length
|
;; Load sequence and record its length
|
||||||
(let* ([orig (input->bytes)]
|
(let* ([orig (port->bytes)]
|
||||||
[filtered (replace-all #rx#"(>.*?\n)|\n" orig #"")])
|
[filtered (regexp-replace* #rx#"(?:>.*?\n)|\n" orig #"")])
|
||||||
|
|
||||||
;; Perform regexp counts
|
;; Perform regexp counts
|
||||||
(for-each
|
(for ([i (in-list VARIANTS)])
|
||||||
(lambda (i)
|
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
|
||||||
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
|
|
||||||
VARIANTS)
|
|
||||||
|
|
||||||
;; Perform regexp replacements, and record sequence length
|
;; Perform regexp replacements, and record sequence length
|
||||||
(let ([replaced
|
(let ([replaced
|
||||||
(let loop ([sequence filtered]
|
(for/fold ([sequence filtered]) ([IUB IUBS])
|
||||||
[IUBS IUBS])
|
(regexp-replace* (byte-regexp (car IUB)) sequence (cadr IUB)))])
|
||||||
(if (null? IUBS)
|
|
||||||
sequence
|
|
||||||
(loop (replace-all (byte-regexp (caar IUBS)) sequence (cadar IUBS))
|
|
||||||
(cdr IUBS))))])
|
|
||||||
;; Print statistics
|
;; Print statistics
|
||||||
(printf "~%~A~%~A~%~A~%"
|
(printf "\n~a\n~a\n~a\n"
|
||||||
(bytes-length orig)
|
(bytes-length orig)
|
||||||
(bytes-length filtered)
|
(bytes-length filtered)
|
||||||
(bytes-length replaced))))
|
(bytes-length replaced))))
|
||||||
|
|
|
||||||
|
|
@ -1,32 +1,34 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
;; The Computer Language Benchmarks Game
|
||||||
|
;; http://shootout.alioth.debian.org/
|
||||||
|
|
||||||
#lang scheme/base
|
|
||||||
(require scheme/cmdline)
|
(require scheme/cmdline)
|
||||||
|
|
||||||
(define translation (make-vector 128))
|
(define translation (make-vector 128))
|
||||||
|
|
||||||
(for-each (lambda (from-to)
|
(for ([from-to '([a t]
|
||||||
(let ([char (lambda (sym)
|
[c g]
|
||||||
(string-ref (symbol->string sym) 0))])
|
[g c]
|
||||||
(let ([from (char (car from-to))]
|
[t a]
|
||||||
[to (char->integer (char-upcase (char (cadr from-to))))])
|
[u a]
|
||||||
(vector-set! translation (char->integer from) to)
|
[m k]
|
||||||
(vector-set! translation (char->integer (char-upcase from)) to))))
|
[r y]
|
||||||
'([a t]
|
[w w]
|
||||||
[c g]
|
[s s]
|
||||||
[g c]
|
[y R]
|
||||||
[t a]
|
[k M]
|
||||||
[u a]
|
[v b]
|
||||||
[m k]
|
[h d]
|
||||||
[r y]
|
[d h]
|
||||||
[w w]
|
[b v]
|
||||||
[s s]
|
[n n])])
|
||||||
[y R]
|
(let ([char (lambda (sym)
|
||||||
[k M]
|
(string-ref (symbol->string sym) 0))])
|
||||||
[v b]
|
(let ([from (char (car from-to))]
|
||||||
[h d]
|
[to (char->integer (char-upcase (char (cadr from-to))))])
|
||||||
[d h]
|
(vector-set! translation (char->integer from) to)
|
||||||
[b v]
|
(vector-set! translation (char->integer (char-upcase from)) to))))
|
||||||
[n n]))
|
|
||||||
|
|
||||||
(define (output lines)
|
(define (output lines)
|
||||||
(let* ([str (apply bytes-append lines)]
|
(let* ([str (apply bytes-append lines)]
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,12 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
|
|
||||||
;; Translated directly from the C# version, which was:
|
;; Translated directly from the C# version, which was:
|
||||||
;; contributed by Isaac Gouy
|
;; contributed by Isaac Gouy
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline)
|
||||||
(require scheme/cmdline)
|
|
||||||
|
|
||||||
(define (Approximate n)
|
(define (Approximate n)
|
||||||
(let ([u (make-vector n 1.0)]
|
(let ([u (make-vector n 1.0)]
|
||||||
|
|
|
||||||
|
|
@ -1,18 +1,19 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
|
|
||||||
;; Translated directly from the C# version, which was:
|
;; Translated directly from the C# version, which was:
|
||||||
;; contributed by Isaac Gouy
|
;; contributed by Isaac Gouy
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline
|
racket/require (for-syntax racket/base)
|
||||||
scheme/require (for-syntax scheme/base)
|
|
||||||
(rename-in
|
(rename-in
|
||||||
(filtered-in
|
(filtered-in
|
||||||
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||||
scheme/unsafe/ops)
|
racket/unsafe/ops)
|
||||||
[fx->fl ->fl])
|
[fx->fl ->fl])
|
||||||
(only-in scheme/flonum make-flvector))
|
(only-in racket/flonum make-flvector))
|
||||||
|
|
||||||
|
|
||||||
(define (Approximate n)
|
(define (Approximate n)
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,13 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
;; The Great Computer Language Shootout
|
;; The Great Computer Language Shootout
|
||||||
;; http://shootout.alioth.debian.org/
|
;; http://shootout.alioth.debian.org/
|
||||||
|
|
||||||
;; Translated directly from the C# version, which was:
|
;; Translated directly from the C# version, which was:
|
||||||
;; contributed by Isaac Gouy
|
;; contributed by Isaac Gouy
|
||||||
|
|
||||||
#lang scheme/base
|
(require racket/cmdline
|
||||||
(require scheme/cmdline
|
racket/flonum)
|
||||||
scheme/flonum)
|
|
||||||
|
|
||||||
(define (Approximate n)
|
(define (Approximate n)
|
||||||
(let ([u (make-flvector n 1.0)]
|
(let ([u (make-flvector n 1.0)]
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,11 @@
|
||||||
;; Uses PLT Scheme threads
|
#lang racket/base
|
||||||
|
|
||||||
#lang scheme/base
|
;; The Great Computer Language Shootout
|
||||||
(require scheme/cmdline)
|
;; http://shootout.alioth.debian.org/
|
||||||
|
;;
|
||||||
|
;; Uses Racket threads
|
||||||
|
|
||||||
|
(require racket/cmdline)
|
||||||
|
|
||||||
;; Each thread runs this loop:
|
;; Each thread runs this loop:
|
||||||
(define (run id next)
|
(define (run id next)
|
||||||
|
|
|
||||||
18
collects/tests/typed-scheme/fail/dup-ann.rkt
Normal file
18
collects/tests/typed-scheme/fail/dup-ann.rkt
Normal file
|
|
@ -0,0 +1,18 @@
|
||||||
|
#;
|
||||||
|
(exn-pred 4)
|
||||||
|
#lang typed/racket
|
||||||
|
(: bar : (String -> String))
|
||||||
|
(: bar : (Number -> Number))
|
||||||
|
(define (bar x)
|
||||||
|
(+ x 1))
|
||||||
|
|
||||||
|
|
||||||
|
(define: (foo) : Number
|
||||||
|
(: bar : (Number -> Number))
|
||||||
|
(define: (bar [x : Number]) : Number
|
||||||
|
(+ x 1))
|
||||||
|
(bar 5))
|
||||||
|
|
||||||
|
|
||||||
|
(: baz Number)
|
||||||
|
(define: baz : Number 7)
|
||||||
8
collects/tests/typed-scheme/fail/internal-ann.rkt
Normal file
8
collects/tests/typed-scheme/fail/internal-ann.rkt
Normal file
|
|
@ -0,0 +1,8 @@
|
||||||
|
|
||||||
|
#lang typed/scheme/base
|
||||||
|
|
||||||
|
(define (f x)
|
||||||
|
(: g (Integer -> Integer))
|
||||||
|
(define (g x)
|
||||||
|
(+ x 2))
|
||||||
|
(g x))
|
||||||
12
collects/tests/typed-scheme/fail/pr10350.rkt
Normal file
12
collects/tests/typed-scheme/fail/pr10350.rkt
Normal file
|
|
@ -0,0 +1,12 @@
|
||||||
|
#lang typed-scheme
|
||||||
|
(require/typed
|
||||||
|
scheme/base
|
||||||
|
[values (All (T) ((Any -> Boolean) -> (Any -> Boolean : T)))])
|
||||||
|
|
||||||
|
(: number->string? (Any -> Boolean : (Number -> String)))
|
||||||
|
(define (number->string? x)
|
||||||
|
(((inst values (Number -> String)) procedure?) x))
|
||||||
|
|
||||||
|
(: f (Number -> String))
|
||||||
|
(define f
|
||||||
|
(if (number->string? +) + number->string))
|
||||||
21
collects/tests/typed-scheme/fail/pr10594.rkt
Normal file
21
collects/tests/typed-scheme/fail/pr10594.rkt
Normal file
|
|
@ -0,0 +1,21 @@
|
||||||
|
#;
|
||||||
|
(exn-pred exn:fail:contract? #rx".*U broke the contract.*")
|
||||||
|
#lang scheme/load
|
||||||
|
|
||||||
|
(module T typed-scheme
|
||||||
|
|
||||||
|
(define-struct: [a] thing ([get : a]))
|
||||||
|
|
||||||
|
(: thing->string ((thing String) -> String))
|
||||||
|
(define (thing->string x)
|
||||||
|
(string-append "foo" (thing-get x)))
|
||||||
|
|
||||||
|
(provide (all-defined-out)))
|
||||||
|
|
||||||
|
(module U scheme
|
||||||
|
|
||||||
|
(require 'T)
|
||||||
|
|
||||||
|
(thing->string (make-thing 5)))
|
||||||
|
|
||||||
|
(require 'U)
|
||||||
48
collects/tests/typed-scheme/succeed/pair-test2.rkt
Normal file
48
collects/tests/typed-scheme/succeed/pair-test2.rkt
Normal file
|
|
@ -0,0 +1,48 @@
|
||||||
|
#lang typed/scheme
|
||||||
|
|
||||||
|
(define: x : (Listof (Listof Integer))
|
||||||
|
'((1 1 1) (2 2 2) (3 3 3) (4 4 4) (5 5 5)))
|
||||||
|
|
||||||
|
(ann (caar x) Integer)
|
||||||
|
(ann (cdar x) (Listof Integer))
|
||||||
|
(ann (cadr x) (Listof Integer))
|
||||||
|
(ann (cddr x) (Listof (Listof Integer)))
|
||||||
|
(ann (caadr x) Integer)
|
||||||
|
(ann (cdadr x) (Listof Integer))
|
||||||
|
(ann (cadar x) Integer)
|
||||||
|
(ann (cddar x) (Listof Integer))
|
||||||
|
(ann (caddr x) (Listof Integer))
|
||||||
|
(ann (cdddr x) (Listof (Listof Integer)))
|
||||||
|
(ann (caddar x) Integer)
|
||||||
|
(ann (cdddar x) (Listof Integer))
|
||||||
|
(ann (cadadr x) Integer)
|
||||||
|
(ann (cddadr x) (Listof Integer))
|
||||||
|
(ann (caaddr x) Integer)
|
||||||
|
(ann (cdaddr x) (Listof Integer))
|
||||||
|
(ann (cadddr x) (Listof Integer))
|
||||||
|
(ann (cddddr x) (Listof (Listof Integer)))
|
||||||
|
|
||||||
|
|
||||||
|
(define: y : (Listof (Listof (Listof Integer)))
|
||||||
|
'(((11 11) (12 12) (13 13))
|
||||||
|
((21 21) (22 22) (23 23))
|
||||||
|
((31 31) (32 32) (33 33))))
|
||||||
|
|
||||||
|
(ann (caaar y) Integer)
|
||||||
|
(ann (cdaar y) (Listof Integer))
|
||||||
|
(ann (cadaar y) Integer)
|
||||||
|
(ann (cddaar y) (Listof Integer))
|
||||||
|
(ann (caadar y) Integer)
|
||||||
|
(ann (cdadar y) (Listof Integer))
|
||||||
|
(ann (caaadr y) Integer)
|
||||||
|
(ann (cdaadr y) (Listof Integer))
|
||||||
|
|
||||||
|
|
||||||
|
(define: z : (Listof (Listof (Listof (Listof Integer))))
|
||||||
|
'((((111 111) (112 112))
|
||||||
|
((121 121) (122 122)))
|
||||||
|
(((211 211) (212 212))
|
||||||
|
((221 221) (222 222)))))
|
||||||
|
|
||||||
|
(ann (caaaar z) Integer)
|
||||||
|
(ann (cdaaar z) (Listof Integer))
|
||||||
48
collects/tests/typed-scheme/succeed/pair-test3.rkt
Normal file
48
collects/tests/typed-scheme/succeed/pair-test3.rkt
Normal file
|
|
@ -0,0 +1,48 @@
|
||||||
|
#lang typed/scheme
|
||||||
|
|
||||||
|
(define: x : (Pair (Pair (Pair (Pair Integer String)
|
||||||
|
(Pair True Null))
|
||||||
|
(Pair (Pair False Char)
|
||||||
|
(Pair String Null)))
|
||||||
|
(Pair (Pair (Pair String Integer)
|
||||||
|
(Pair Float Null))
|
||||||
|
(Pair (Pair (Vectorof Float) True)
|
||||||
|
(Pair (Listof Float) False))))
|
||||||
|
'((((1 . "1") . (#t))
|
||||||
|
. ((#f . #\f) . ("2")))
|
||||||
|
. ((("3" . 4) . (1.0))
|
||||||
|
. ((#(2.0 3.0 4.0) . #t)
|
||||||
|
. ((2.0 3.0 4.0) . #f)))))
|
||||||
|
|
||||||
|
|
||||||
|
(ann (caar x) (Pair (Pair Integer String) (Pair True Null)))
|
||||||
|
(ann (caaar x) (Pair Integer String))
|
||||||
|
(ann (caaaar x) Integer)
|
||||||
|
(ann (cdaaar x) String)
|
||||||
|
(ann (cdaar x) (Pair True Null))
|
||||||
|
(ann (cadaar x) True)
|
||||||
|
(ann (cddaar x) Null)
|
||||||
|
|
||||||
|
(ann (cdar x) (Pair (Pair False Char) (Pair String Null)))
|
||||||
|
(ann (cadar x) (Pair False Char))
|
||||||
|
(ann (caadar x) False)
|
||||||
|
(ann (cdadar x) Char)
|
||||||
|
(ann (cddar x) (Pair String Null))
|
||||||
|
(ann (caddar x) String)
|
||||||
|
(ann (cdddar x) Null)
|
||||||
|
|
||||||
|
(ann (cadr x) (Pair (Pair String Integer) (Pair Float Null)))
|
||||||
|
(ann (caadr x) (Pair String Integer))
|
||||||
|
(ann (caaadr x) String)
|
||||||
|
(ann (cdaadr x) Integer)
|
||||||
|
(ann (cdadr x) (Pair Float Null))
|
||||||
|
(ann (cadadr x) Float)
|
||||||
|
(ann (cddadr x) Null)
|
||||||
|
|
||||||
|
(ann (cddr x) (Pair (Pair (Vectorof Float) True) (Pair (Listof Float) False)))
|
||||||
|
(ann (caddr x) (Pair (Vectorof Float) True))
|
||||||
|
(ann (caaddr x) (Vectorof Float))
|
||||||
|
(ann (cdaddr x) True)
|
||||||
|
(ann (cdddr x) (Pair (Listof Float) False))
|
||||||
|
(ann (cadddr x) (Listof Float))
|
||||||
|
(ann (cddddr x) False)
|
||||||
35
collects/tests/typed-scheme/succeed/pr10318.rkt
Normal file
35
collects/tests/typed-scheme/succeed/pr10318.rkt
Normal file
|
|
@ -0,0 +1,35 @@
|
||||||
|
#lang typed-scheme
|
||||||
|
|
||||||
|
(define-struct: rect ((nw : Symbol) (width : Number) (height : Number)))
|
||||||
|
(define-struct: circ ((cntr : Symbol) (radius : Number)))
|
||||||
|
(define-struct: over ((top : Shape) (bot : Shape)))
|
||||||
|
|
||||||
|
(define-type-alias Shape (Rec Shape (U Plain over [Listof Plain])))
|
||||||
|
(define-type-alias Plain (U rect circ))
|
||||||
|
;; (define-type-alias Rect (U (make-rect Posn Number Number)))
|
||||||
|
;; Circ = (make-circ Posn Number)
|
||||||
|
|
||||||
|
(: area (Shape -> Number))
|
||||||
|
;; the area of all rectangles in this s
|
||||||
|
(define (area s)
|
||||||
|
(cond
|
||||||
|
[(plain? s) (plain-area s)]
|
||||||
|
[(over? s) (+ (area (over-top s)) (area (over-bot s)))]
|
||||||
|
[else (apply + (map rect-area (filter rect? s)))]))
|
||||||
|
|
||||||
|
(: plain? (Any -> Boolean : Plain))
|
||||||
|
;; is this p a plain shape?
|
||||||
|
(define (plain? p)
|
||||||
|
(or (rect? p) (circ? p)))
|
||||||
|
|
||||||
|
(: plain-area (Plain -> Number))
|
||||||
|
;; the area of this plain shape s
|
||||||
|
(define (plain-area s)
|
||||||
|
(cond
|
||||||
|
[(rect? s) (rect-area s)]
|
||||||
|
[(circ? s) 0]))
|
||||||
|
|
||||||
|
(: rect-area (rect -> Number))
|
||||||
|
;; the area of this rectangle r
|
||||||
|
(define (rect-area s)
|
||||||
|
(* (rect-width s) (rect-height s)))
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user