suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Propagated Eli's changes to the binarytrees benchmark to the typed

Browse Source 
version.
This commit is contained in:
Vincent St-Amour 2010-06-22 18:36:24 -04:00
parent 3c9e7e34db
commit d3c5ca7537
1 changed files with 34 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/tests/racket/benchmarks/shootout/typed/binarytrees.rktl
View File

@ -2,57 +2,58 @@
;;; http://shootout.alioth.debian.org/
;;; Derived from the Chicken variant by Sven Hartrumpf
(require racket/cmdline)
(require racket/cmdline racket/require (for-syntax racket/base)
(filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
racket/unsafe/ops))
(define-struct: node ((left : (Option node)) (val : Integer) (right : (Option node))))
(struct: (X) *leaf ((val : X)))
(struct: (X) *node *leaf ((left : (*leaf X)) (right : (*leaf X))))
;; Instead of (define-struct leaf (val)):
(: leaf (Integer -> node))
(define (leaf val) (node #f val #f))
(: leaf? (node -> Boolean))
(define (leaf? l) (not (node-left l)))
(: leaf-val (node -> Integer))
(define (leaf-val l) (node-val l))
(define-syntax leaf (make-rename-transformer #'*leaf))
(define-syntax leaf? (make-rename-transformer #'*leaf?))
(define-syntax node (make-rename-transformer #'*node))
(define-syntax node? (make-rename-transformer #'*node?))
(define-syntax-rule (leaf-val l) (struct-ref l 0))
(define-syntax-rule (node-left n) (struct-ref n 1))
(define-syntax-rule (node-right n) (struct-ref n 2))
(: make (Integer Integer -> node))
(: make (Integer Integer -> (*leaf Integer)))
(define (make item d)
(if (= d 0)
(leaf item)
(let ((item2 (* item 2))
(d2 (- d 1)))
(node (make (- item2 1) d2)
item
(make item2 d2)))))
(if (fx= d 0)
(leaf item)
(let ([item2 (fx* item 2)] [d2 (fx- d 1)])
(node item (make (fx- item2 1) d2) (make item2 d2)))))
(: check (node -> Integer))
(: check ((*leaf Integer) -> Integer))
(define (check t)
(if (leaf? t)
(leaf-val t)
(+ (node-val t) (- (check (assert (node-left t)))
(check (assert (node-right t)))))))
(let loop ([t t] [acc 0])
(let ([acc (fx+ (leaf-val t) acc)])
(if (leaf? t)
acc
(loop (node-right t)
(fx+ acc (loop (node-left t) 0)))))))
(define min-depth 4)
(: main (Integer -> Void))
(define (main n)
(let* ((min-depth 4)
(max-depth (max (+ min-depth 2) n)))
(let ((stretch-depth (+ max-depth 1)))
(let ([max-depth (max (+ min-depth 2) n)])
(let ([stretch-depth (+ max-depth 1)])
(printf "stretch tree of depth ~a\t check: ~a\n"
stretch-depth
(check (make 0 stretch-depth))))
(let ((long-lived-tree (make 0 max-depth)))
(for ((d (in-range 4 (add1 max-depth) 2)))
(let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))))
(let ([long-lived-tree (make 0 max-depth)])
(for ([d (in-range 4 (+ max-depth 1) 2)])
(let ([iterations (expt 2 (+ (- max-depth d) min-depth))])
(printf "~a\t trees of depth ~a\t check: ~a\n"
(* 2 iterations)
d
(for/fold: : Integer ([c : Integer 0])
([i : Integer (in-range iterations)])
(+ c
(check (make i d))
(check (make (- i) d)))))))
(fx+ c (fx+ (check (make i d))
(check (make (fx- 0 i) d))))))))
(printf "long lived tree of depth ~a\t check: ~a\n"
max-depth
(check long-lived-tree)))))
(command-line #:args (n)
(main (assert (string->number (assert n string?)) exact-integer?)))
(command-line #:args (n) (time (main (assert (string->number (assert n string?)) exact-integer?))))