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/ ;;; http://shootout.alioth.debian.org/
;;; Derived from the Chicken variant by Sven Hartrumpf ;;; 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)): (define-syntax leaf (make-rename-transformer #'*leaf))
(: leaf (Integer -> node)) (define-syntax leaf? (make-rename-transformer #'*leaf?))
(define (leaf val) (node #f val #f)) (define-syntax node (make-rename-transformer #'*node))
(: leaf? (node -> Boolean)) (define-syntax node? (make-rename-transformer #'*node?))
(define (leaf? l) (not (node-left l))) (define-syntax-rule (leaf-val l) (struct-ref l 0))
(: leaf-val (node -> Integer)) (define-syntax-rule (node-left n) (struct-ref n 1))
(define (leaf-val l) (node-val l)) (define-syntax-rule (node-right n) (struct-ref n 2))
(: make (Integer Integer -> node)) (: make (Integer Integer -> (*leaf Integer)))
(define (make item d) (define (make item d)
(if (= d 0) (if (fx= d 0)
(leaf item) (leaf item)
(let ((item2 (* item 2)) (let ([item2 (fx* item 2)] [d2 (fx- d 1)])
(d2 (- d 1))) (node item (make (fx- item2 1) d2) (make item2 d2)))))
(node (make (- item2 1) d2)
item
(make item2 d2)))))
(: check (node -> Integer)) (: check ((*leaf Integer) -> Integer))
(define (check t) (define (check t)
(if (leaf? t) (let loop ([t t] [acc 0])
(leaf-val t) (let ([acc (fx+ (leaf-val t) acc)])
(+ (node-val t) (- (check (assert (node-left t))) (if (leaf? t)
(check (assert (node-right t))))))) acc
(loop (node-right t)
(fx+ acc (loop (node-left t) 0)))))))
(define min-depth 4)
(: main (Integer -> Void)) (: main (Integer -> Void))
(define (main n) (define (main n)
(let* ((min-depth 4) (let ([max-depth (max (+ min-depth 2) n)])
(max-depth (max (+ min-depth 2) n))) (let ([stretch-depth (+ max-depth 1)])
(let ((stretch-depth (+ max-depth 1)))
(printf "stretch tree of depth ~a\t check: ~a\n" (printf "stretch tree of depth ~a\t check: ~a\n"
stretch-depth stretch-depth
(check (make 0 stretch-depth)))) (check (make 0 stretch-depth))))
(let ((long-lived-tree (make 0 max-depth))) (let ([long-lived-tree (make 0 max-depth)])
(for ((d (in-range 4 (add1 max-depth) 2))) (for ([d (in-range 4 (+ max-depth 1) 2)])
(let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth)))) (let ([iterations (expt 2 (+ (- max-depth d) min-depth))])
(printf "~a\t trees of depth ~a\t check: ~a\n" (printf "~a\t trees of depth ~a\t check: ~a\n"
(* 2 iterations) (* 2 iterations)
d d
(for/fold: : Integer ([c : Integer 0]) (for/fold: : Integer ([c : Integer 0])
([i : Integer (in-range iterations)]) ([i : Integer (in-range iterations)])
(+ c (fx+ c (fx+ (check (make i d))
(check (make i d)) (check (make (fx- 0 i) d))))))))
(check (make (- i) d)))))))
(printf "long lived tree of depth ~a\t check: ~a\n" (printf "long lived tree of depth ~a\t check: ~a\n"
max-depth max-depth
(check long-lived-tree))))) (check long-lived-tree)))))
(command-line #:args (n) (command-line #:args (n) (time (main (assert (string->number (assert n string?)) exact-integer?))))
(main (assert (string->number (assert n string?)) exact-integer?)))