Switched from using the module form to using #lang in the typed benchmarks.
This commit is contained in:
Vincent St-Amour
parent
fb09e9da23
commit
1e15826159
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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* '()))))))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
(module nothing-typed typed/scheme
|
||||
(time 1))
|
||||
#lang typed/scheme/base
|
||||
|
||||
(time 1)
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user