From 1e15826159f4b88314dbce26ba312beca4615096 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 11 May 2010 18:45:06 -0400 Subject: [PATCH] Switched from using the module form to using #lang in the typed benchmarks. --- .../benchmarks/common/cpstack-typed.rkt | 48 +- .../racket/benchmarks/common/ctak-typed.rkt | 80 ++-- .../racket/benchmarks/common/dderiv-typed.rkt | 142 +++--- .../racket/benchmarks/common/deriv-typed.rkt | 93 ++-- .../racket/benchmarks/common/div-typed.rkt | 92 ++-- .../racket/benchmarks/common/fft-typed.rkt | 212 +++++---- .../benchmarks/common/lattice2-typed.rkt | 438 +++++++++--------- .../benchmarks/common/mazefun-typed.rkt | 416 +++++++++-------- .../benchmarks/common/nestedloop-typed.rkt | 128 +++-- .../racket/benchmarks/common/nfa-typed.rkt | 95 ++-- .../benchmarks/common/nothing-typed.rkt | 5 +- .../benchmarks/common/nqueens-typed.rkt | 70 ++- 12 files changed, 900 insertions(+), 919 deletions(-) diff --git a/collects/tests/racket/benchmarks/common/cpstack-typed.rkt b/collects/tests/racket/benchmarks/common/cpstack-typed.rkt index 25e692a3e4..9f2a03b6e8 100644 --- a/collects/tests/racket/benchmarks/common/cpstack-typed.rkt +++ b/collects/tests/racket/benchmarks/common/cpstack-typed.rkt @@ -11,31 +11,29 @@ ;;; CPSTAK -- A continuation-passing version of the TAK benchmark. ;;; A good test of first class procedures and tail recursion. -(module cpstack-typed typed/scheme - - (: 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))) +#lang typed/scheme/base + +(: 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)) - - ) +(time (cpstak 18 12 2)) diff --git a/collects/tests/racket/benchmarks/common/ctak-typed.rkt b/collects/tests/racket/benchmarks/common/ctak-typed.rkt index b5dece95ed..f035a40ca3 100644 --- a/collects/tests/racket/benchmarks/common/ctak-typed.rkt +++ b/collects/tests/racket/benchmarks/common/ctak-typed.rkt @@ -21,49 +21,47 @@ ;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility. -(module ctak-typed typed/scheme +#lang typed/scheme/base - (: 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 (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))))))))) +(: 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))))))) - - ) +(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))))))) diff --git a/collects/tests/racket/benchmarks/common/dderiv-typed.rkt b/collects/tests/racket/benchmarks/common/dderiv-typed.rkt index 22248952fe..f57f8a61dc 100644 --- a/collects/tests/racket/benchmarks/common/dderiv-typed.rkt +++ b/collects/tests/racket/benchmarks/common/dderiv-typed.rkt @@ -35,85 +35,83 @@ ; Returns the wrong answer for quotients. ; Fortunately these aren't used in the benchmark. -(module dderiv-typed typed/scheme +#lang typed/scheme/base - (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 Plist (Listof (Pair Symbol ((Listof Deriv) -> Deriv)))) - (define-type Deriv (Rec Deriv (U Number - Symbol - (Pair (U '+ '- '* '/) - (Listof Deriv))))) - - (: dderiv-aux (Deriv -> Deriv)) - (define (dderiv-aux a) - (list '/ (dderiv a) a)) +(: 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))) - (: f+dderiv ((Listof Deriv) -> Deriv)) - (define (f+dderiv a) - (cons '+ (map dderiv a))) +(define-type Deriv (Rec Deriv (U Number + Symbol + (Pair (U '+ '- '* '/) + (Listof Deriv))))) - (: f-dderiv ((Listof Deriv) -> Deriv)) - (define (f-dderiv a) - (cons '- (map dderiv a))) +(: dderiv-aux (Deriv -> Deriv)) +(define (dderiv-aux a) + (list '/ (dderiv a) a)) - (: *dderiv ((Listof Deriv) -> Deriv)) - (define (*dderiv a) - (list '* - (ann (cons '* a) Deriv) - (ann (cons '+ (map dderiv-aux a)) Deriv))) +(: f+dderiv ((Listof Deriv) -> Deriv)) +(define (f+dderiv a) + (cons '+ (map dderiv a))) - (: /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)))))) +(: f-dderiv ((Listof Deriv) -> Deriv)) +(define (f-dderiv a) + (cons '- (map dderiv 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)))))) +(: *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 - (: 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)) - ) +(time (run)) diff --git a/collects/tests/racket/benchmarks/common/deriv-typed.rkt b/collects/tests/racket/benchmarks/common/deriv-typed.rkt index 674e8bb8d1..5a59f15a94 100644 --- a/collects/tests/racket/benchmarks/common/deriv-typed.rkt +++ b/collects/tests/racket/benchmarks/common/deriv-typed.rkt @@ -1,3 +1,4 @@ + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; File: deriv.sch ; Description: The DERIV benchmark from the Gabriel tests. @@ -17,55 +18,53 @@ ; Returns the wrong answer for quotients. ; Fortunately these aren't used in the benchmark. -(module deriv-typed typed/scheme +#lang typed/scheme/base - (define-type Deriv (Rec Deriv (U Number - Symbol - (Pair (U '+ '- '* '/) - (Listof Deriv))))) - - (: deriv-aux (Deriv -> Deriv)) - (define (deriv-aux a) (list '/ (deriv a) a)) +(define-type Deriv (Rec Deriv (U Number + Symbol + (Pair (U '+ '- '* '/) + (Listof Deriv))))) - (: 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))) +(: 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)))) - (: 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)) - ) +(time (run)) diff --git a/collects/tests/racket/benchmarks/common/div-typed.rkt b/collects/tests/racket/benchmarks/common/div-typed.rkt index 10443816a8..bcc5a05b3e 100644 --- a/collects/tests/racket/benchmarks/common/div-typed.rkt +++ b/collects/tests/racket/benchmarks/common/div-typed.rkt @@ -13,59 +13,57 @@ ;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. ;;; This file contains a recursive as well as an iterative test. -(module div-typed typed/scheme +#lang typed/scheme/base - (: create-n (Integer -> (Listof Any))) - (define (create-n n) - (do ((n n (- n 1)) - (a '() (cons '() a))) - ((= n 0) a))) +(: 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)) +(: *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))) +(: 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)))))) +(: 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-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))) - (: 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* '())))))))) - ) +(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* '())))))))) diff --git a/collects/tests/racket/benchmarks/common/fft-typed.rkt b/collects/tests/racket/benchmarks/common/fft-typed.rkt index 81334be49c..d29c308cc3 100644 --- a/collects/tests/racket/benchmarks/common/fft-typed.rkt +++ b/collects/tests/racket/benchmarks/common/fft-typed.rkt @@ -10,122 +10,120 @@ ; Status: Public Domain ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(module fft-typed typed/scheme +#lang typed/scheme/base - (: pi Complex) - (define pi (atan 0 -1)) +(: 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)) +(: *re* (Vectorof Complex)) +(define *re* (make-vector 1025 0.0)) - (: *im* (Vectorof Complex)) - (define *im* (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 +(: 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 - ((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)) - + ((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)) +(: fft-bench ( -> Null)) +(define (fft-bench) + (do: : Null + ((ntimes : Integer 0 (+ ntimes 1))) + ((= ntimes 1000) '()) + (fft *re* *im*))) - ) +;;; call: (fft-bench) + +(time (fft-bench)) diff --git a/collects/tests/racket/benchmarks/common/lattice2-typed.rkt b/collects/tests/racket/benchmarks/common/lattice2-typed.rkt index 27d8d87ae3..5dffdc6a5c 100644 --- a/collects/tests/racket/benchmarks/common/lattice2-typed.rkt +++ b/collects/tests/racket/benchmarks/common/lattice2-typed.rkt @@ -3,236 +3,234 @@ ;;; LATTICE -- Obtained from Andrew Wright. -(module lattice2-typed typed/scheme +#lang typed/scheme/base - (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 Verdict (U 'less 'more 'equal 'uncomparable)) - (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)) +;; 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)) - (: lattice->elements (All (X) ((Lattice X) -> (Listof X)))) - (define (lattice->elements l) (car l)) +(define-type (Lattice X) (Pair (Listof X) (X X -> Verdict))) - (: lattice->cmp (All (X) ((Lattice X) -> (X X -> Verdict)))) - (define (lattice->cmp l) (cdr l)) +(: make-lattice (All (X) ((Listof X) (X X -> Verdict) -> (Lattice X)))) +(define (make-lattice elem-list cmp-func) + (cons elem-list cmp-func)) - ;; 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))) +(: lattice->elements (All (X) ((Lattice X) -> (Listof X)))) +(define (lattice->elements l) (car l)) - ;; 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))) +(: 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) +;; 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) - 0 - (+ (car lst) (sum (cdr 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))))) - (: 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))) +(: 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))))) - (time (run)) +(: 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)) diff --git a/collects/tests/racket/benchmarks/common/mazefun-typed.rkt b/collects/tests/racket/benchmarks/common/mazefun-typed.rkt index 76dbdcf880..f98b64bf00 100644 --- a/collects/tests/racket/benchmarks/common/mazefun-typed.rkt +++ b/collects/tests/racket/benchmarks/common/mazefun-typed.rkt @@ -1,248 +1,246 @@ ;;; MAZEFUN -- Constructs a maze in a purely functional way, ;;; written by Marc Feeley. -(module mazefun-typed typed/scheme +#lang typed/scheme/base - (: iota (Integer -> (Listof Integer))) - (define iota - (lambda (n) - (iota-iter n '()))) +(: 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))))) +(: 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 (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 ((Listof X) -> Y)) + (define foldr-aux + (lambda (lst) + (if (null? lst) + base + (f (car lst) (foldr-aux (cdr lst)))))) - (foldr-aux lst))) + (foldr-aux lst))) - (: foldl (All (X Y) ((Y X -> Y) Y (Listof X) -> Y))) - (define foldl - (lambda (f base 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 (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))) + (foldl-aux base lst))) - (: for (All (X) (Integer Integer (Integer -> X) -> (Listof X)))) - (define for - (lambda (lo hi f) +(: 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 (Integer -> (Listof X))) + (define for-aux + (lambda (lo) + (if (< lo hi) + (cons (f lo) (for-aux (+ lo 1))) + '()))) - (for-aux lo))) + (for-aux lo))) - (: concat (All (X) ((Listof (Listof X)) -> (Listof X)))) - (define concat - (lambda (lists) - ((inst foldr (Listof X) (Listof X)) append '() lists))) +(: 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-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-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)))))) +(: 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)))))) +(: 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. +;; 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))))))) +(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-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)))) +(: 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))))) +(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))) +(: 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) +(define initial-random 0) - (: next-random (Integer -> Integer)) - (define next-random - (lambda (current-random) - (remainder (+ (* current-random 3581) 12751) 131072))) +(: 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 (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))))))) +(: 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)))))) +(: 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))) +(: 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 (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)))))) +(: 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))))))) +(: 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 ((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))))) +(: 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))) - '()))))))) +(: 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))))))) - - ) +(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))))))) diff --git a/collects/tests/racket/benchmarks/common/nestedloop-typed.rkt b/collects/tests/racket/benchmarks/common/nestedloop-typed.rkt index 575641023b..9d30b46fdc 100644 --- a/collects/tests/racket/benchmarks/common/nestedloop-typed.rkt +++ b/collects/tests/racket/benchmarks/common/nestedloop-typed.rkt @@ -1,68 +1,66 @@ -(module nestedloop-typed typed/scheme +#lang typed/scheme/base - ;; 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)) +;; 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))))))))))))))) +;; 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)))) - - ) +(let ((cnt (if (with-input-from-file "input.txt" read) 18 1))) + (time (list + (loops cnt) + (func-loops cnt)))) diff --git a/collects/tests/racket/benchmarks/common/nfa-typed.rkt b/collects/tests/racket/benchmarks/common/nfa-typed.rkt index 945376f04e..bbf5b8ba74 100644 --- a/collects/tests/racket/benchmarks/common/nfa-typed.rkt +++ b/collects/tests/racket/benchmarks/common/nfa-typed.rkt @@ -1,61 +1,60 @@ ;; 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 -(module nfa-typed typed/scheme +#lang typed/scheme/base - (define-type Result (U 'state2 'state4 #f)) - - (: recursive-nfa ((Listof Char) -> (U 'state2 'state4 'fail))) - (define (recursive-nfa input) +(define-type Result (U 'state2 'state4 #f)) - (: state0 ((Listof Char) -> Result)) - (define (state0 input) - (or (state1 input) (state3 input) #f)) +(: recursive-nfa ((Listof Char) -> (U 'state2 'state4 'fail))) +(define (recursive-nfa input) - (: 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)))) + (: state0 ((Listof Char) -> Result)) + (define (state0 input) + (or (state1 input) (state3 input) #f)) - (: 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)) + (: 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)))) - (: state3 ((Listof Char) -> Result)) - (define (state3 input) - (and (not (null? input)) - (or (and (char=? (car input) #\a) - (state3 (cdr input))) - (state4 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)) - (: state4 ((Listof Char) -> Result)) - (define (state4 input) - (and (not (null? input)) - (char=? (car input) #\b) - (not (null? (cdr input))) - (char=? (cadr input) #\c) - 'state4)) + (: state3 ((Listof Char) -> Result)) + (define (state3 input) + (and (not (null? input)) + (or (and (char=? (car input) #\a) + (state3 (cdr input))) + (state4 input)))) - (or (state0 input) - 'fail)) + (: state4 ((Listof Char) -> Result)) + (define (state4 input) + (and (not (null? input)) + (char=? (car input) #\b) + (not (null? (cdr input))) + (char=? (cadr input) #\c) + 'state4)) - (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))))))) + (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))))))) diff --git a/collects/tests/racket/benchmarks/common/nothing-typed.rkt b/collects/tests/racket/benchmarks/common/nothing-typed.rkt index cd5f7901ac..acada135b8 100644 --- a/collects/tests/racket/benchmarks/common/nothing-typed.rkt +++ b/collects/tests/racket/benchmarks/common/nothing-typed.rkt @@ -1,2 +1,3 @@ -(module nothing-typed typed/scheme - (time 1)) +#lang typed/scheme/base + +(time 1) diff --git a/collects/tests/racket/benchmarks/common/nqueens-typed.rkt b/collects/tests/racket/benchmarks/common/nqueens-typed.rkt index b803a330bc..5cb71d2cc9 100644 --- a/collects/tests/racket/benchmarks/common/nqueens-typed.rkt +++ b/collects/tests/racket/benchmarks/common/nqueens-typed.rkt @@ -1,46 +1,44 @@ ;;; 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) -(module nqueens-typed typed/scheme +#lang typed/scheme/base +(define trace? #f) - (define trace? #f) +(: nqueens (Integer -> Integer)) +(define (nqueens n) - (: 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))))) - (: 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)))) - (: 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))))) - (: 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) '() '())) - (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))))))) - - ) +(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)))))))