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))
|
||||
(list #'name))]
|
||||
[(_ (name) expr ...)
|
||||
(and (identifier/non-kw? (syntax name))
|
||||
(ok-definition-context))
|
||||
(check-single-result-expr (syntax->list (syntax (expr ...)))
|
||||
#f
|
||||
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.rkt" responsible (samth)
|
||||
"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/gui.rkt" responsible (ryanc) drdr:command-line (gracket-text "-t" *)
|
||||
"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/view.rkt" 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/readline" responsible (mflatt)
|
||||
"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/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/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/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/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/dynamic.rkt" drdr:command-line #f
|
||||
"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/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/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/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-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/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/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/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/scheme.rkt" drdr:command-line #f
|
||||
"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/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/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/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/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/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/parsing.rktl" drdr:command-line (gracket "-f" *)
|
||||
"collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test")
|
||||
|
|
|
|||
|
|
@ -38,6 +38,32 @@
|
|||
(current-inspector) #f '(0))])
|
||||
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)
|
||||
(make-set!-transformer
|
||||
(let ([saved-id-table (make-hasheq)])
|
||||
|
|
@ -52,21 +78,13 @@
|
|||
(with-syntax ([contract-id contract-id]
|
||||
[id id]
|
||||
[external-id external-id]
|
||||
[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])])
|
||||
[pos-module-source pos-module-source])
|
||||
(syntax-local-introduce
|
||||
(syntax-local-lift-expression
|
||||
#`(contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(quote-module-path)
|
||||
(first-requiring-module (quote-syntax id) (quote-module-path))
|
||||
'external-id
|
||||
(quote-srcloc id))))))])
|
||||
(when key
|
||||
|
|
|
|||
|
|
@ -19,7 +19,11 @@ Racket installation.
|
|||
you'd like to compile it to bytecode, along with all of its
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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
|
||||
[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
|
||||
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
|
||||
[void* ptr]
|
||||
[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
|
||||
provided to @cpp{scheme_main_setup}. (The
|
||||
@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
|
||||
initial namespace contains declarations only for a few primitive
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
(htdp-syntax-test #'(define x))
|
||||
(htdp-syntax-test #'(define x 10 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 (y 10) 12))
|
||||
(htdp-syntax-test #'(define (y "x") 12))
|
||||
|
|
|
|||
|
|
@ -397,6 +397,26 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
clean-up-zo
|
||||
(append '(nucleic2)
|
||||
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
|
||||
void
|
||||
(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
|
||||
;;; http://shootout.alioth.debian.org/
|
||||
;;; 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)):
|
||||
(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-val l) (node-val l))
|
||||
|
||||
(define (make item d)
|
||||
(if (= d 0)
|
||||
(make-leaf item)
|
||||
(leaf item)
|
||||
(let ((item2 (* item 2))
|
||||
(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)
|
||||
(if (leaf? t)
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
#lang racket/base
|
||||
|
||||
;;; The Great Computer Language Shootout
|
||||
;;; http://shootout.alioth.debian.org/
|
||||
;;;
|
||||
;;; Uses PLT Scheme threads
|
||||
;;; Uses Racket threads
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
scheme/match)
|
||||
(require racket/cmdline
|
||||
racket/match)
|
||||
|
||||
(define (change c1 c2)
|
||||
(case c1
|
||||
|
|
@ -96,5 +97,3 @@
|
|||
(go n '(blue red yellow))
|
||||
(go n '(blue red yellow red yellow blue red yellow red blue))
|
||||
(newline))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
#lang racket/base
|
||||
|
||||
;; fannkuch benchmark for The Computer Language Shootout
|
||||
;; Written by Dima Dorfman, 2004
|
||||
;; Slightly improved by Sven Hartrumpf, 2005-2006
|
||||
;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham
|
||||
;; PLT-ized for v4.0 by Matthew
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require racket/cmdline)
|
||||
|
||||
(define (fannkuch n)
|
||||
(let ([pi (list->vector
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -6,8 +8,7 @@
|
|||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require racket/cmdline)
|
||||
|
||||
(define +alu+
|
||||
(bytes-append
|
||||
|
|
@ -40,7 +41,7 @@
|
|||
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
|
||||
(lambda (max)
|
||||
(set! last (modulo (+ ic (* last ia)) im))
|
||||
(/ (* max last) im) )))
|
||||
(/ (* max last) im))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
#lang scheme/base
|
||||
|
||||
(define (all-counts len dna)
|
||||
(let ([table (make-hasheq)]
|
||||
[seq (make-string len)])
|
||||
|
|
@ -16,12 +16,10 @@
|
|||
(define (write-freqs table)
|
||||
(let* ([content (hash-map table cons)]
|
||||
[total (exact->inexact (apply + (map cdr content)))])
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(printf "~a ~a\n"
|
||||
(car a)
|
||||
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))
|
||||
(sort content (lambda (a b) (> (cdr a) (cdr b)))))))
|
||||
(for ([a (sort content > #:key cdr)])
|
||||
(printf "~a ~a\n"
|
||||
(car a)
|
||||
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))))
|
||||
|
||||
(define (write-one-freq table key)
|
||||
(let ([cnt (hash-ref table key 0)])
|
||||
|
|
@ -33,9 +31,8 @@
|
|||
(regexp-match #rx#"(?m:^>THREE.*$)" in)
|
||||
(let ([s (open-output-string)])
|
||||
;; Copy everything but newlines to s:
|
||||
(let loop ()
|
||||
(when (regexp-match #rx#"\n" in 0 #f s)
|
||||
(loop)))
|
||||
(for ([l (in-bytes-lines in)])
|
||||
(write-bytes l s))
|
||||
;; Extract the string from s:
|
||||
(string-upcase (get-output-string s)))))
|
||||
|
||||
|
|
@ -48,8 +45,6 @@
|
|||
(newline)
|
||||
|
||||
;; Specific sequences:
|
||||
(for-each (lambda (seq)
|
||||
(write-one-freq (all-counts (string-length seq) dna)
|
||||
(string->symbol seq)))
|
||||
'("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))
|
||||
|
||||
(for ([seq '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT")])
|
||||
(write-one-freq (all-counts (string-length seq) dna)
|
||||
(string->symbol seq)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
#lang racket/base
|
||||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -16,8 +17,7 @@
|
|||
;; [(> (magnitude z) 2.0) 0]
|
||||
;; [else (loop (add1 i) (+ (* z z) c))]))))
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require racket/cmdline)
|
||||
|
||||
(define +limit-sqr+ 4.0)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
#lang racket/base
|
||||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -7,12 +8,11 @@
|
|||
;;
|
||||
;; This version uses unsafe operations
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
scheme/require (for-syntax scheme/base)
|
||||
(require racket/cmdline
|
||||
racket/require (for-syntax racket/base)
|
||||
(filtered-in
|
||||
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||
scheme/unsafe/ops))
|
||||
racket/unsafe/ops))
|
||||
|
||||
(define +limit-sqr+ 4.0)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
#lang racket/base
|
||||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
scheme/flonum)
|
||||
(require racket/cmdline
|
||||
racket/flonum)
|
||||
|
||||
(define +limit-sqr+ 4.0)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -7,8 +9,7 @@
|
|||
;; contributed by Matthew Flatt
|
||||
;; optimized by Eli Barzilay
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline scheme/list)
|
||||
(require racket/cmdline)
|
||||
|
||||
(define width 5)
|
||||
(define height 10)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/usr/bin/mzscheme -qu
|
||||
#lang racket/base
|
||||
|
||||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -6,7 +7,7 @@
|
|||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; 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
|
||||
|
||||
#|
|
||||
|
|
@ -16,8 +17,7 @@ Correct output N = 1000 is
|
|||
-0.169087605
|
||||
|#
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require racket/cmdline)
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/usr/bin/mzscheme -qu
|
||||
#lang racket/base
|
||||
|
||||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -6,7 +7,7 @@
|
|||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; 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
|
||||
|
||||
#|
|
||||
|
|
@ -16,8 +17,7 @@ Correct output N = 1000 is
|
|||
-0.169087605
|
||||
|#
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require racket/cmdline)
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/usr/bin/mzscheme -qu
|
||||
#lang racket/base
|
||||
|
||||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -6,7 +7,7 @@
|
|||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; 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
|
||||
;; Made unsafe and optimized by Sam TH
|
||||
#|
|
||||
|
|
@ -16,15 +17,14 @@ Correct output N = 1000 is
|
|||
-0.169087605
|
||||
|#
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline scheme/require
|
||||
(only-in scheme/flonum flvector)
|
||||
(for-syntax scheme/base)
|
||||
(require racket/cmdline racket/require
|
||||
(only-in racket/flonum flvector)
|
||||
(for-syntax racket/base)
|
||||
(filtered-in
|
||||
(lambda (name)
|
||||
(regexp-replace
|
||||
#rx"unsafe-fl" name "fl"))
|
||||
scheme/unsafe/ops))
|
||||
racket/unsafe/ops))
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/usr/bin/mzscheme -qu
|
||||
#lang racket/base
|
||||
|
||||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -6,7 +7,7 @@
|
|||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; 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
|
||||
|
||||
#|
|
||||
|
|
@ -16,9 +17,8 @@ Correct output N = 1000 is
|
|||
-0.169087605
|
||||
|#
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
scheme/flonum)
|
||||
(require racket/cmdline
|
||||
racket/flonum)
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/usr/bin/mzscheme -qu
|
||||
#lang racket/base
|
||||
|
||||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
|
|
@ -6,7 +7,7 @@
|
|||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; 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
|
||||
|
||||
#|
|
||||
|
|
@ -16,9 +17,8 @@ Correct output N = 1000 is
|
|||
-0.169087605
|
||||
|#
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
scheme/flonum)
|
||||
(require racket/cmdline
|
||||
racket/flonum)
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;; Based on the Perl version of the benchmark
|
||||
;; adapted with a GMP interface by Eli Barzilay
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require (for-syntax scheme/base))
|
||||
(require scheme/foreign) (unsafe!)
|
||||
(require racket/cmdline
|
||||
(for-syntax racket/base)
|
||||
ffi/unsafe)
|
||||
|
||||
;; quick libgmp interface, limited to what we need below
|
||||
(define libgmp (ffi-lib "libgmp"))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;; Based on the MLton version of the benchmark
|
||||
;; contributed by Scott Cruzen
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require racket/cmdline)
|
||||
|
||||
(define (floor_ev q r s t x)
|
||||
(quotient (+ (* q x) r) (+ (* s x) t)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/usr/bin/mzscheme -r
|
||||
#lang racket/base
|
||||
|
||||
; The Computer Language Shootout
|
||||
; http://shootout.alioth.debian.org/
|
||||
; Sven Hartrumpf 2005-04-12
|
||||
|
|
@ -6,52 +7,50 @@
|
|||
; This program is based on an implementation for SCM by Aubrey Jaffer and
|
||||
; 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)
|
||||
(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 (print-digits out s start end digits n)
|
||||
(let* ([len (- end start)]
|
||||
[cnt (min len (- n digits) (- 10 (modulo digits 10)) len)])
|
||||
(if (zero? cnt)
|
||||
digits
|
||||
(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 (print-digits out s start end digits n)
|
||||
(let* ([len (- end start)]
|
||||
[cnt (min len (- n digits) (- 10 (modulo digits 10)) len)])
|
||||
(if (zero? cnt)
|
||||
digits
|
||||
(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)
|
||||
(let ((n (if (= (vector-length args) 0)
|
||||
1
|
||||
(string->number (vector-ref args 0)))))
|
||||
(pi n 10)))
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(define (main args)
|
||||
(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
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Tested with PCRE [compiler must be built with PCRE already installed
|
||||
;; 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
|
||||
;; ---------------------------------------------------------------------
|
||||
;; Based on a version by by Anthony Borla
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/port)
|
||||
(require racket/port)
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
|
|
@ -40,49 +34,22 @@
|
|||
(match-count str rx (cdar m) (add1 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
|
||||
(let* ([orig (input->bytes)]
|
||||
[filtered (replace-all #rx#"(>.*?\n)|\n" orig #"")])
|
||||
(let* ([orig (port->bytes)]
|
||||
[filtered (regexp-replace* #rx#"(?:>.*?\n)|\n" orig #"")])
|
||||
|
||||
;; Perform regexp counts
|
||||
(for-each
|
||||
(lambda (i)
|
||||
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
|
||||
VARIANTS)
|
||||
(for ([i (in-list VARIANTS)])
|
||||
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
|
||||
|
||||
;; Perform regexp replacements, and record sequence length
|
||||
(let ([replaced
|
||||
(let loop ([sequence filtered]
|
||||
[IUBS IUBS])
|
||||
(if (null? IUBS)
|
||||
sequence
|
||||
(loop (replace-all (byte-regexp (caar IUBS)) sequence (cadar IUBS))
|
||||
(cdr IUBS))))])
|
||||
(for/fold ([sequence filtered]) ([IUB IUBS])
|
||||
(regexp-replace* (byte-regexp (car IUB)) sequence (cadr IUB)))])
|
||||
;; Print statistics
|
||||
(printf "~%~A~%~A~%~A~%"
|
||||
(printf "\n~a\n~a\n~a\n"
|
||||
(bytes-length orig)
|
||||
(bytes-length filtered)
|
||||
(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)
|
||||
|
||||
(define translation (make-vector 128))
|
||||
|
||||
(for-each (lambda (from-to)
|
||||
(let ([char (lambda (sym)
|
||||
(string-ref (symbol->string sym) 0))])
|
||||
(let ([from (char (car from-to))]
|
||||
[to (char->integer (char-upcase (char (cadr from-to))))])
|
||||
(vector-set! translation (char->integer from) to)
|
||||
(vector-set! translation (char->integer (char-upcase from)) to))))
|
||||
'([a t]
|
||||
[c g]
|
||||
[g c]
|
||||
[t a]
|
||||
[u a]
|
||||
[m k]
|
||||
[r y]
|
||||
[w w]
|
||||
[s s]
|
||||
[y R]
|
||||
[k M]
|
||||
[v b]
|
||||
[h d]
|
||||
[d h]
|
||||
[b v]
|
||||
[n n]))
|
||||
(for ([from-to '([a t]
|
||||
[c g]
|
||||
[g c]
|
||||
[t a]
|
||||
[u a]
|
||||
[m k]
|
||||
[r y]
|
||||
[w w]
|
||||
[s s]
|
||||
[y R]
|
||||
[k M]
|
||||
[v b]
|
||||
[h d]
|
||||
[d h]
|
||||
[b v]
|
||||
[n n])])
|
||||
(let ([char (lambda (sym)
|
||||
(string-ref (symbol->string sym) 0))])
|
||||
(let ([from (char (car from-to))]
|
||||
[to (char->integer (char-upcase (char (cadr from-to))))])
|
||||
(vector-set! translation (char->integer from) to)
|
||||
(vector-set! translation (char->integer (char-upcase from)) to))))
|
||||
|
||||
(define (output lines)
|
||||
(let* ([str (apply bytes-append lines)]
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
;; Translated directly from the C# version, which was:
|
||||
;; contributed by Isaac Gouy
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
(require racket/cmdline)
|
||||
|
||||
(define (Approximate n)
|
||||
(let ([u (make-vector n 1.0)]
|
||||
|
|
|
|||
|
|
@ -1,18 +1,19 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
;; Translated directly from the C# version, which was:
|
||||
;; contributed by Isaac Gouy
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
scheme/require (for-syntax scheme/base)
|
||||
(require racket/cmdline
|
||||
racket/require (for-syntax racket/base)
|
||||
(rename-in
|
||||
(filtered-in
|
||||
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||
scheme/unsafe/ops)
|
||||
racket/unsafe/ops)
|
||||
[fx->fl ->fl])
|
||||
(only-in scheme/flonum make-flvector))
|
||||
(only-in racket/flonum make-flvector))
|
||||
|
||||
|
||||
(define (Approximate n)
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
#lang racket/base
|
||||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
;; Translated directly from the C# version, which was:
|
||||
;; contributed by Isaac Gouy
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
scheme/flonum)
|
||||
(require racket/cmdline
|
||||
racket/flonum)
|
||||
|
||||
(define (Approximate n)
|
||||
(let ([u (make-flvector n 1.0)]
|
||||
|
|
|
|||
|
|
@ -1,7 +1,11 @@
|
|||
;; Uses PLT Scheme threads
|
||||
#lang racket/base
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Uses Racket threads
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
;; Each thread runs this loop:
|
||||
(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