Ported some new benchmarks and variants to Typed Scheme.
This commit is contained in:
Vincent St-Amour
parent
ffad1edd7a
commit
343e9d23b4
|
|
@ -1543,19 +1543,31 @@ path/s is either such a string or a list of them.
|
|||
"collects/tests/racket/benchmarks/shootout/typed" responsible (stamourv)
|
||||
"collects/tests/racket/benchmarks/shootout/typed/ackermann.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/ary.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/binarytrees.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/chameneos.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/cheapconcurrency.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/echo.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/except.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/fannkuch.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/fasta.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/fibo.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/hash.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/hash2.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/heapsort.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/hello.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/k-nucleotide.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/lists.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/mandelbrot.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/matrix.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/meteor.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/moments.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/nbody-generic.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/nbody-vec.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/nbody.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/nestedloop.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/nsieve.rktl" drdr:command-line #f
|
||||
|
|
@ -1565,14 +1577,18 @@ path/s is either such a string or a list of them.
|
|||
"collects/tests/racket/benchmarks/shootout/typed/pidigits1.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/random.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/recursive.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/regexmatch.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/regexpdna.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/reversecomplement.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/reversefile.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/sieve.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/spectralnorm.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/spellcheck.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/strcat.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/sumcol.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/thread-ring.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/wc.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/benchmarks/shootout/typed/wordfreq.rktl" drdr:command-line #f
|
||||
"collects/tests/racket/binc.rktl" drdr:command-line #f
|
||||
|
|
|
|||
|
|
@ -74,12 +74,6 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
|
||||
(define-struct impl (name setup make run extract-result clean-up skips))
|
||||
|
||||
(define untypeable-benchmarks
|
||||
'(binarytrees
|
||||
lists
|
||||
regexmatch
|
||||
k-nucleotide))
|
||||
|
||||
(define impls
|
||||
(list
|
||||
(make-impl 'racket
|
||||
|
|
@ -97,7 +91,7 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
(system (format "racket run.rkt ~a typed-scheme" bm)))
|
||||
extract-racket-times
|
||||
clean-up-typed
|
||||
untypeable-benchmarks)
|
||||
'())
|
||||
(make-impl 'typed-scheme-optimizing
|
||||
void
|
||||
mk-typed-scheme-optimizing
|
||||
|
|
@ -105,7 +99,7 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
(system (format "racket run.rkt ~a typed-scheme-optimizing" bm)))
|
||||
extract-racket-times
|
||||
clean-up-typed
|
||||
untypeable-benchmarks)
|
||||
'())
|
||||
))
|
||||
|
||||
(define benchmarks
|
||||
|
|
@ -123,12 +117,20 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
hash
|
||||
hash2
|
||||
heapsort
|
||||
hello
|
||||
k-nucleotide
|
||||
lists
|
||||
mandelbrot
|
||||
mandelbrot-generic
|
||||
mandelbrot-unsafe
|
||||
matrix
|
||||
meteor
|
||||
moments
|
||||
nbody
|
||||
nbody-generic
|
||||
nbody-vec
|
||||
nbody-vec-generic
|
||||
nbody-vec-unsafe
|
||||
nestedloop
|
||||
nothing
|
||||
nsieve
|
||||
|
|
@ -143,8 +145,11 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
reversefile
|
||||
sieve
|
||||
spectralnorm
|
||||
spectralnorm-generic
|
||||
spectralnorm-unsafe
|
||||
strcat
|
||||
sumcol
|
||||
thread-ring
|
||||
wc
|
||||
wordfreq))
|
||||
|
||||
|
|
|
|||
|
|
@ -176,13 +176,14 @@
|
|||
|
||||
(define (add-solutions!)
|
||||
(define (add! solution)
|
||||
(cond [(not (mcar solutions))
|
||||
(set-mcar! solutions solution)
|
||||
(set-mcdr! solutions solution)]
|
||||
[(bytes<? solution (mcar solutions))
|
||||
(set-mcar! solutions solution)]
|
||||
[(bytes>? solution (mcdr solutions))
|
||||
(set-mcdr! solutions solution)]))
|
||||
(let ((head (mcar solutions)))
|
||||
(cond [(not head)
|
||||
(set-mcar! solutions solution)
|
||||
(set-mcdr! solutions solution)]
|
||||
[(bytes<? solution head)
|
||||
(set-mcar! solutions solution)]
|
||||
[(bytes>? solution (mcdr solutions))
|
||||
(set-mcdr! solutions solution)])))
|
||||
(let* ([s (list->bytes
|
||||
(for/list ([pos (in-range size)])
|
||||
(for/or ([color (in-range 10)])
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ Correct output N = 1000 is
|
|||
(define +pi+ 3.141592653589793)
|
||||
(define +days-per-year+ 365.24)
|
||||
|
||||
(define +solar-mass+ (* 4 +pi+ +pi+))
|
||||
(define +solar-mass+ (* 4.0 +pi+ +pi+))
|
||||
|
||||
(define +dt+ 0.01)
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ Correct output N = 1000 is
|
|||
(define +pi+ 3.141592653589793)
|
||||
(define +days-per-year+ 365.24)
|
||||
|
||||
(define +solar-mass+ (* 4 +pi+ +pi+))
|
||||
(define +solar-mass+ (* 4.0 +pi+ +pi+))
|
||||
|
||||
(define +dt+ 0.01)
|
||||
|
||||
|
|
|
|||
|
|
@ -17,11 +17,19 @@
|
|||
("hash" "2000000")
|
||||
("hash2" "750")
|
||||
("heapsort" "1500000")
|
||||
("hello" "")
|
||||
("lists" "18")
|
||||
("mandelbrot" "3000")
|
||||
("mandelbrot-generic" "3000")
|
||||
("mandelbrot-unsafe" "3000")
|
||||
("matrix" "10000")
|
||||
("meteor" "10000")
|
||||
("moments" #f ,(lambda () (mk-moments-input)))
|
||||
("nbody" "2000000")
|
||||
("nbody-generic" "2000000")
|
||||
("nbody-vec" "2000000")
|
||||
("nbody-vec-generic" "2000000")
|
||||
("nbody-vec-unsafe" "2000000")
|
||||
("nestedloop" "30")
|
||||
("nothing" "")
|
||||
("nsieve" "12")
|
||||
|
|
@ -39,8 +47,11 @@
|
|||
("sieve" "25000")
|
||||
("spellcheck")
|
||||
("spectralnorm" "5500")
|
||||
("spectralnorm-generic" "5500")
|
||||
("spectralnorm-unsafe" "5500")
|
||||
("strcat" "50000000")
|
||||
("sumcol" #f ,(lambda () (mk-sumcol-input)))
|
||||
("thread-ring" "1000000")
|
||||
("wc" #f ,(lambda () (mk-wc-input)))
|
||||
("wordfreq" #f ,(lambda () (mk-wordfreq-input)))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module binarytrees-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module binarytrees-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
;;; The Great Computer Language Shootout
|
||||
;;; http://shootout.alioth.debian.org/
|
||||
;;; Derived from the Chicken variant by Sven Hartrumpf
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
(define-struct: node ((left : (Option node)) (val : Integer) (right : (Option node))))
|
||||
|
||||
;; 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))
|
||||
|
||||
(: make (Integer Integer -> node))
|
||||
(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)))))
|
||||
|
||||
(: check (node -> Integer))
|
||||
(define (check t)
|
||||
(if (leaf? t)
|
||||
(leaf-val t)
|
||||
(+ (node-val t) (- (check (assert (node-left t)))
|
||||
(check (assert (node-right t)))))))
|
||||
|
||||
(: main (Integer -> Void))
|
||||
(define (main n)
|
||||
(let* ((min-depth 4)
|
||||
(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))))
|
||||
(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)))))))
|
||||
(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?)))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module hello-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module hello-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1 @@
|
|||
(display "hello world\n")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module k-nucleotide-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module k-nucleotide-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
;; The Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
(: all-counts (Integer String -> (HashTable Symbol Integer)))
|
||||
(define (all-counts len dna)
|
||||
(let: ([table : (HashTable Symbol Integer) (make-hasheq)]
|
||||
[seq : String (make-string len)])
|
||||
(for: ([s : Integer (in-range (- (string-length dna) len) -1 -1)])
|
||||
(string-copy! seq 0 dna s (+ s len))
|
||||
(let ([key (string->symbol seq)])
|
||||
(let ([cnt (hash-ref table key (lambda () 0))])
|
||||
(hash-set! table key (add1 cnt)))))
|
||||
table))
|
||||
|
||||
(: write-freqs ((HashTable Symbol Integer) -> Void))
|
||||
(define (write-freqs table)
|
||||
(let*: ([content : (Listof (Pair Symbol Integer)) (hash-map table (inst cons Symbol Integer))]
|
||||
[total : Float (exact->inexact (apply + (map (inst cdr Symbol Integer) content)))])
|
||||
(for: ([a : (Pair Symbol Integer) ((inst sort (Pair Symbol Integer) Integer) content > #:key cdr)])
|
||||
(printf "~a ~a\n"
|
||||
(car a)
|
||||
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))))
|
||||
|
||||
(: write-one-freq ((HashTable Symbol Integer) Symbol -> Void))
|
||||
(define (write-one-freq table key)
|
||||
(let ([cnt (hash-ref table key (lambda () 0))])
|
||||
(printf "~a\t~a\n" cnt key)))
|
||||
|
||||
(define dna
|
||||
(let ([in (current-input-port)])
|
||||
;; Skip to ">THREE ..."
|
||||
(regexp-match #rx#"(?m:^>THREE.*$)" in)
|
||||
(let ([s (open-output-string)])
|
||||
;; Copy everything but newlines to s:
|
||||
(for ([l (in-bytes-lines in)])
|
||||
(write-bytes l s))
|
||||
;; Extract the string from s:
|
||||
(string-upcase (get-output-string s)))))
|
||||
|
||||
;; 1-nucleotide counts:
|
||||
(write-freqs (all-counts 1 dna))
|
||||
(newline)
|
||||
|
||||
;; 2-nucleotide counts:
|
||||
(write-freqs (all-counts 2 dna))
|
||||
(newline)
|
||||
|
||||
;; Specific sequences:
|
||||
(for: : Void
|
||||
([seq : String '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT")])
|
||||
(write-one-freq (all-counts (string-length seq) dna)
|
||||
(string->symbol seq)))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module lists-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module lists-optimizing "wrap-typed-optimizing.ss")
|
||||
49
collects/tests/racket/benchmarks/shootout/typed/lists.rktl
Normal file
49
collects/tests/racket/benchmarks/shootout/typed/lists.rktl
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
(require racket/mpair)
|
||||
(define SIZE 10000)
|
||||
|
||||
(: sequence (Integer Integer -> (MListof Integer)))
|
||||
(define (sequence start stop)
|
||||
(if (> start stop)
|
||||
'()
|
||||
(mcons start (sequence (+ start 1) stop))))
|
||||
|
||||
(: head-to-tail! ((MListof Integer) (MListof Integer)
|
||||
-> (values (MListof Integer) (MListof Integer))))
|
||||
(define (head-to-tail! headlist taillist)
|
||||
(when (null? taillist) (begin
|
||||
(set! taillist (ann (mlist (mcar headlist)) (MListof Integer)))
|
||||
(set! headlist (mcdr headlist))))
|
||||
(letrec: ((htt-helper : ((MListof Integer) -> Void)
|
||||
(lambda (dest)
|
||||
(when (not (null? headlist))
|
||||
(let ((headlink headlist))
|
||||
(set-mcdr! dest headlink)
|
||||
(set! headlist (mcdr headlist))
|
||||
(htt-helper headlink))))))
|
||||
(htt-helper taillist)
|
||||
(values headlist taillist)))
|
||||
|
||||
(: test-lists ( -> Integer))
|
||||
(define (test-lists)
|
||||
(let*: ([L1 : (MListof Integer) (sequence 1 SIZE)]
|
||||
[L2 : (MListof Integer) (mappend L1 '())]
|
||||
[L3 : (MListof Integer) '()])
|
||||
(set!-values (L2 L3) (head-to-tail! L2 L3))
|
||||
(set!-values (L3 L2) (head-to-tail! (mreverse! L3) L2))
|
||||
(set! L1 (mreverse! L1))
|
||||
(cond ((not (= SIZE (mcar L1))) 0)
|
||||
((not (equal? L1 L2)) 0)
|
||||
(else (mlength L1)))))
|
||||
|
||||
(: main ((Vectorof String) -> Void))
|
||||
(define (main args)
|
||||
(let: ((result : Integer 0))
|
||||
(let loop ((counter (if (= (vector-length args) 0)
|
||||
1
|
||||
(assert (string->number (vector-ref args 0)) exact-integer?))))
|
||||
(when (> counter 0)
|
||||
(set! result (test-lists))
|
||||
(loop (- counter 1))))
|
||||
(printf "~s~n" result)))
|
||||
|
||||
(main (current-command-line-arguments))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module mandelbrot-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module mandelbrot-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
|
||||
;; The version that uses complex number is a little
|
||||
;; more elegant, but much slower:
|
||||
;; (define (mandelbrot iterations x y n ci)
|
||||
;; (let ((c (+ (- (/ (* 2.0 x) n) 1.5)
|
||||
;; (* ci 0.0+1.0i))))
|
||||
;; (let loop ((i 0) (z 0.0+0.0i))
|
||||
;; (cond
|
||||
;; [(> i iterations) 1]
|
||||
;; [(> (magnitude z) 2.0) 0]
|
||||
;; [else (loop (add1 i) (+ (* z z) c))]))))
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
(define +limit-sqr+ 4.0)
|
||||
|
||||
(define +iterations+ 50)
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(: mandelbrot (Integer Integer Integer Integer Float -> (U 0 1)))
|
||||
(define (mandelbrot iterations x y n ci)
|
||||
(let ((cr (- (/ (* 2.0 x) n) 1.5)))
|
||||
(let loop ((i 0) (zr 0.0) (zi 0.0))
|
||||
(if (> i iterations)
|
||||
1
|
||||
(let ((zrq (* zr zr))
|
||||
(ziq (* zi zi)))
|
||||
(cond
|
||||
((> (+ zrq ziq) +limit-sqr+) 0)
|
||||
(else (loop (add1 i)
|
||||
(+ (- zrq ziq) cr)
|
||||
(+ (* 2.0 zr zi) ci)))))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(: main (Integer -> Void))
|
||||
(define (main n)
|
||||
(let ((out (current-output-port)))
|
||||
|
||||
(fprintf out "P4\n~a ~a\n" n n)
|
||||
|
||||
(let loop-y ((y 0))
|
||||
|
||||
(when (< y n)
|
||||
|
||||
(let ([ci (- (/ (* 2.0 y) n) 1.0)])
|
||||
|
||||
(let: loop-x : Void
|
||||
((x : Integer 0) (bitnum : Integer 0) (byteacc : Integer 0))
|
||||
|
||||
(if (< x n)
|
||||
(let ([bitnum (add1 bitnum)]
|
||||
[byteacc (+ (arithmetic-shift byteacc 1)
|
||||
(mandelbrot +iterations+ x y n ci))])
|
||||
|
||||
(cond
|
||||
((= bitnum 8)
|
||||
(write-byte byteacc out)
|
||||
(loop-x (add1 x) 0 0))
|
||||
|
||||
[else (loop-x (add1 x) bitnum byteacc)]))
|
||||
|
||||
(begin
|
||||
(when (positive? bitnum)
|
||||
(write-byte (arithmetic-shift byteacc
|
||||
(- 8 (bitwise-and n #x7)))
|
||||
out))
|
||||
|
||||
(loop-y (add1 y))))))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(command-line #:args (n)
|
||||
(main (assert (string->number (assert n string?)) exact-integer?)))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module mandelbrot-unsafe-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module mandelbrot-unsafe-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
;;
|
||||
;; This version uses unsafe operations
|
||||
|
||||
(require racket/cmdline
|
||||
racket/require (for-syntax racket/base)
|
||||
(filtered-in
|
||||
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||
racket/unsafe/ops))
|
||||
|
||||
(define +limit-sqr+ 4.0)
|
||||
|
||||
(define +iterations+ 50)
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(: mandelbrot (Integer Integer Integer Float -> (U 0 1)))
|
||||
(define (mandelbrot x y n ci)
|
||||
(let ((cr (fl- (fl/ (fl* 2.0 (fx->fl x)) (fx->fl n)) 1.5)))
|
||||
(let loop ((i 0) (zr 0.0) (zi 0.0))
|
||||
(if (fx> i +iterations+)
|
||||
1
|
||||
(cond
|
||||
((fl> (fl+ (fl* zr zr) (fl* zi zi)) +limit-sqr+) 0)
|
||||
(else (loop (fx+ 1 i)
|
||||
(fl+ (fl- (fl* zr zr) (fl* zi zi)) cr)
|
||||
(fl+ (fl* 2.0 (fl* zr zi)) ci))))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(: main (Integer -> Void))
|
||||
(define (main n)
|
||||
(let ((out (current-output-port)))
|
||||
|
||||
(fprintf out "P4\n~a ~a\n" n n)
|
||||
|
||||
(let loop-y ((y 0))
|
||||
|
||||
(when (fx< y n)
|
||||
|
||||
(let ([ci (fl- (fl/ (fl* 2.0 (fx->fl y)) (fx->fl n)) 1.0)])
|
||||
|
||||
(let: loop-x : Void ((x : Integer 0) (bitnum : Integer 0) (byteacc : Integer 0))
|
||||
|
||||
(if (fx< x n)
|
||||
(let ([bitnum (fx+ 1 bitnum)]
|
||||
[byteacc (fx+ (fxlshift byteacc 1)
|
||||
(mandelbrot x y n ci))])
|
||||
|
||||
(cond
|
||||
((fx= bitnum 8)
|
||||
(write-byte byteacc out)
|
||||
(loop-x (fx+ 1 x) 0 0))
|
||||
|
||||
[else (loop-x (fx+ 1 x) bitnum byteacc)]))
|
||||
|
||||
(begin
|
||||
(when (positive? bitnum)
|
||||
(write-byte (arithmetic-shift byteacc
|
||||
(- 8 (bitwise-and n #x7)))
|
||||
out))
|
||||
|
||||
(loop-y (add1 y))))))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(command-line #:args (n)
|
||||
(main (assert (string->number (assert n string?)) exact-integer?)))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module meteor-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module meteor-optimizing "wrap-typed-optimizing.ss")
|
||||
256
collects/tests/racket/benchmarks/shootout/typed/meteor.rktl
Normal file
256
collects/tests/racket/benchmarks/shootout/typed/meteor.rktl
Normal file
|
|
@ -0,0 +1,256 @@
|
|||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Based on a Python version:
|
||||
;; contributed by Olof Kraigher
|
||||
;; modified by Tupteq
|
||||
;; contributed by Matthew Flatt
|
||||
;; optimized by Eli Barzilay
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
(define-type Board Integer)
|
||||
(define-type Piece (Listof (Vectorof Integer)))
|
||||
|
||||
(define width 5)
|
||||
(define height 10)
|
||||
(define size (* width height))
|
||||
|
||||
(: valid-xy? (Integer Integer -> Boolean))
|
||||
(define (valid-xy? x y)
|
||||
(and (0 . <= . x)
|
||||
(x . < . width)
|
||||
(0 . <= . y)
|
||||
(y . < . height)))
|
||||
|
||||
(: mover ((Integer Integer -> (values Integer Integer)) -> (Vectorof Integer)))
|
||||
(define (mover fun)
|
||||
(let ([t (make-vector size)])
|
||||
(for ([p (in-range size)])
|
||||
(vector-set! t p (let*-values ([(y x) (quotient/remainder p width)]
|
||||
[(x y) (fun x y)])
|
||||
(if (valid-xy? x y) (+ x (* y width)) -1))))
|
||||
t))
|
||||
|
||||
(define E
|
||||
(mover (lambda: ((x : Integer) (y : Integer)) (values (add1 x) y))))
|
||||
(define W
|
||||
(mover (lambda: ((x : Integer) (y : Integer)) (values (sub1 x) y))))
|
||||
(define NE
|
||||
(mover (lambda: ((x : Integer) (y : Integer)) (values (+ x (bitwise-and y 1)) (sub1 y)))))
|
||||
(define NW
|
||||
(mover (lambda: ((x : Integer) (y : Integer)) (values (sub1 (+ x (bitwise-and y 1))) (sub1 y)))))
|
||||
(define SE
|
||||
(mover (lambda: ((x : Integer) (y : Integer)) (values (+ x (bitwise-and y 1)) (add1 y)))))
|
||||
(define SW
|
||||
(mover (lambda: ((x : Integer) (y : Integer)) (values (sub1 (+ x (bitwise-and y 1))) (add1 y)))))
|
||||
|
||||
(define-type Direction (Vectorof Integer))
|
||||
(define rotate-list (list E NE NW W SW SE E))
|
||||
(: rotate (Direction -> Direction))
|
||||
(define (rotate dir)
|
||||
(cadr (assert (memq dir rotate-list))))
|
||||
|
||||
(define flip-alist (list (cons E W) (cons NE NW) (cons NW NE)
|
||||
(cons W E) (cons SW SE) (cons SE SW)))
|
||||
(: flip (Direction -> Direction))
|
||||
(define (flip dir) (cdr (assert (assq dir flip-alist))))
|
||||
|
||||
(define movers (list E W NE NW SE SW))
|
||||
|
||||
(: valid? (Integer -> Boolean))
|
||||
(define (valid? p)
|
||||
(p . >= . 0))
|
||||
|
||||
(: clear? (Board Integer -> Boolean))
|
||||
(define (clear? board pos)
|
||||
(not (bitwise-bit-set? board pos)))
|
||||
(: set (Board Integer -> Integer))
|
||||
(define (set board pos)
|
||||
(bitwise-ior board (arithmetic-shift 1 pos)))
|
||||
|
||||
(: zero-count (Board -> Integer))
|
||||
(define (zero-count board)
|
||||
(for/fold ([count 0]) ([i (in-range size)])
|
||||
(if (clear? board i) (add1 count) count)))
|
||||
|
||||
(: find-free-cell (Board -> (Option Integer)))
|
||||
(define (find-free-cell board)
|
||||
(for/or ([p (in-range 0 size)])
|
||||
(and (clear? board p) p)))
|
||||
|
||||
(: flood-fill (Board Integer -> Board))
|
||||
(define (flood-fill board p)
|
||||
(for/fold ([board (set board p)]) ([mover (in-list movers)])
|
||||
(let ([p (vector-ref mover p)])
|
||||
(if (and (valid? p) (clear? board p))
|
||||
(flood-fill board p)
|
||||
board))))
|
||||
|
||||
(: no-islands? (Board -> Boolean))
|
||||
(define (no-islands? mask)
|
||||
(let ([zeros (zero-count mask)])
|
||||
(and (zeros . >= . 5)
|
||||
(let loop ([mask mask] [zeros zeros])
|
||||
(if (= mask #x3FFFFFFFFFFFF)
|
||||
#t
|
||||
(let* ([p (assert (find-free-cell mask))]
|
||||
[mask (flood-fill mask p)]
|
||||
[new-zeros (zero-count mask)])
|
||||
(and ((- zeros new-zeros) . >= . 5)
|
||||
(loop mask new-zeros))))))))
|
||||
|
||||
(: get-bitmask (Integer Piece -> (Option Integer)))
|
||||
(define (get-bitmask p piece)
|
||||
(let ([mask (arithmetic-shift 1 p)])
|
||||
(let loop ([p p] [cells piece] [mask mask])
|
||||
(if (null? cells)
|
||||
mask
|
||||
(let ([p (vector-ref (car cells) p)])
|
||||
(and (valid? p) (loop p (cdr cells) (set mask p))))))))
|
||||
|
||||
(: all-bitmasks (Piece Integer -> (Listof Integer)))
|
||||
(define (all-bitmasks piece color)
|
||||
(let: ([pieces : (Listof Piece)
|
||||
(let-values ([(accum piece)
|
||||
(for/fold: : (values (Listof Piece) Piece)
|
||||
([accum : (Listof Piece) null]
|
||||
[piece : Piece piece])
|
||||
([orientations : Integer (in-range 2)])
|
||||
(let-values ([(accum piece)
|
||||
(for/fold: : (values (Listof Piece) Piece)
|
||||
([accum : (Listof Piece) accum]
|
||||
[piece : Piece piece])
|
||||
([orientations : Integer (in-range (- 6 (* 3 (if (= color 4) 1 0))))])
|
||||
(values (cons piece accum)
|
||||
(map rotate piece)))])
|
||||
(values accum (map flip piece))))])
|
||||
accum)])
|
||||
(reverse
|
||||
(for*/fold: : (Listof Integer)
|
||||
([accum : (Listof Integer) null])
|
||||
([piece : Piece (in-list pieces)]
|
||||
[p : Integer (in-range 0 size)])
|
||||
(let ([mask (get-bitmask p piece)])
|
||||
(if (and mask (no-islands? mask)) (cons mask accum) accum))))))
|
||||
|
||||
(: generate-bitmasks-pieces (Listof (Listof Direction)))
|
||||
(define generate-bitmasks-pieces
|
||||
(list (list E E E SE)
|
||||
(list SE SW W SW)
|
||||
(list W W SW SE)
|
||||
(list E E SW SE)
|
||||
(list NW W NW SE SW)
|
||||
(list E E NE W)
|
||||
(list NW NE NE W)
|
||||
(list NE SE E NE)
|
||||
(list SE SE E SE)
|
||||
(list E NW NW NW)))
|
||||
(: generate-bitmasks ( -> (Vectorof (Vectorof (Listof Board)))))
|
||||
(define (generate-bitmasks)
|
||||
(let ([masks-at-cell
|
||||
(list->vector
|
||||
(for/list: : (Listof (Vectorof (Listof Board)))
|
||||
([i : Integer (in-range size)])
|
||||
(list->vector (for/list: : (Listof (Listof Board))
|
||||
([j : Integer (in-range 10)]) null))))])
|
||||
(for ([piece (in-list generate-bitmasks-pieces)]
|
||||
[color (in-naturals)])
|
||||
(let: loop : (Vectorof (Vectorof (Listof Board)))
|
||||
([masks : (Listof Integer) ((inst sort Integer Integer) (all-bitmasks piece color) >)]
|
||||
[cell-bit : Integer (sub1 size)]
|
||||
[cell-counter : Integer (sub1 size)])
|
||||
(if (null? masks)
|
||||
masks-at-cell
|
||||
(if (bitwise-bit-set? (car masks) cell-bit)
|
||||
(let ([vec (vector-ref masks-at-cell cell-counter)])
|
||||
(vector-set! vec color (cons (car masks) (vector-ref vec color)))
|
||||
(loop (cdr masks) cell-bit cell-counter))
|
||||
(loop masks (sub1 cell-bit) (sub1 cell-counter))))))
|
||||
(for ([v (in-vector masks-at-cell)])
|
||||
(for ([j (in-naturals)]
|
||||
[val (in-vector v)])
|
||||
(vector-set! v j (reverse val))))
|
||||
masks-at-cell))
|
||||
|
||||
(define masks-at-cell (generate-bitmasks))
|
||||
|
||||
(: masks (Vectorof Integer))
|
||||
(define masks (make-vector 10 0))
|
||||
(: to-go Integer)
|
||||
(define to-go 0)
|
||||
(define-type Solution Bytes)
|
||||
(: solutions (MPairof (Option Solution) (Option Solution)))
|
||||
(define solutions (mcons #f #f)) ; keeps (min max) solutions
|
||||
|
||||
(: solve-cell! (Integer Board -> Void))
|
||||
(define (solve-cell! cell board)
|
||||
(when (and (positive? to-go) (not (negative? cell)))
|
||||
;; Need solutions and not off board
|
||||
(cond [(= board #x3FFFFFFFFFFFF)
|
||||
;; Solved
|
||||
(add-solutions!)]
|
||||
[(not (clear? board cell))
|
||||
;; Cell full, so try next
|
||||
(solve-cell! (sub1 cell) board)]
|
||||
[else
|
||||
;; Recur
|
||||
(for*: ([color : Integer (in-range 10)]
|
||||
#:when (zero? (vector-ref masks color))
|
||||
[mask : Integer (in-list (vector-ref (vector-ref masks-at-cell cell)
|
||||
color))]
|
||||
#:when (zero? (bitwise-and mask board)))
|
||||
(vector-set! masks color mask)
|
||||
(solve-cell! (sub1 cell) (bitwise-ior board mask))
|
||||
(vector-set! masks color 0))])))
|
||||
|
||||
(: add-solutions! ( -> Void))
|
||||
(define (add-solutions!)
|
||||
(: add! (Solution -> Void))
|
||||
(define (add! solution)
|
||||
(let ((head (mcar solutions)))
|
||||
(cond [(not head)
|
||||
(set-mcar! solutions solution)
|
||||
(set-mcdr! solutions solution)]
|
||||
[(bytes<? solution head)
|
||||
(set-mcar! solutions solution)]
|
||||
[(bytes>? solution (assert (mcdr solutions)))
|
||||
(set-mcdr! solutions solution)])))
|
||||
(let* ([s (list->bytes
|
||||
(for/list: : (Listof Integer) ([pos : Integer (in-range size)])
|
||||
(assert (for/or: : (Option Integer) ([color : Integer (in-range 10)])
|
||||
(and (not (clear? (vector-ref masks color) pos))
|
||||
(+ color (char->integer #\0)))))))]
|
||||
[ns (make-bytes size)])
|
||||
;; Inverse
|
||||
(for*: ([y : Integer (in-range height)]
|
||||
[x : Integer (in-range width)])
|
||||
(bytes-set! ns (+ x (* y width))
|
||||
(bytes-ref s (+ (- width (+ x 1))
|
||||
(* width (- height (+ y 1)))))))
|
||||
;; Keep first and last only
|
||||
(add! s)
|
||||
(add! ns)
|
||||
(set! to-go (- to-go 2))))
|
||||
|
||||
(: print-solution (Solution -> Void))
|
||||
(define (print-solution solution)
|
||||
(let ([solution (bytes->string/utf-8 solution)])
|
||||
(for ([y (in-range height)])
|
||||
(when (odd? y) (display " "))
|
||||
(for ([x (in-range width)])
|
||||
(printf "~a " (string-ref solution (+ x (* y width)))))
|
||||
(printf "\n"))
|
||||
(newline)))
|
||||
|
||||
(: solve! (Integer -> Void))
|
||||
(define (solve! n)
|
||||
(set! to-go n)
|
||||
(solve-cell! (sub1 size) 0))
|
||||
|
||||
(command-line #:args (n)
|
||||
(let ([n (assert (string->number (assert n string?)) exact-integer?)])
|
||||
(solve! n)
|
||||
(printf "~a solutions found\n\n" (- n to-go))
|
||||
(print-solution (assert (mcar solutions)))
|
||||
(print-solution (assert (mcdr solutions)))))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-generic-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-generic-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Imperative-style implementation based on the SBCL implementation by
|
||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; idioms like 'named let' and 'do' special form.
|
||||
;;
|
||||
;; Contributed by Anthony Borla, then converted for Racket
|
||||
;; by Matthew Flatt and Brent Fulgham
|
||||
|
||||
#|
|
||||
Correct output N = 1000 is
|
||||
|
||||
-0.169075164
|
||||
-0.169087605
|
||||
|#
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
||||
(define +pi+ 3.141592653589793)
|
||||
(define +days-per-year+ 365.24)
|
||||
|
||||
(define +solar-mass+ (* 4.0 +pi+ +pi+))
|
||||
|
||||
(define +dt+ 0.01)
|
||||
|
||||
(define-struct: body ((x : Float) (y : Float) (z : Float)
|
||||
(vx : Float) (vy : Float) (vz : Float)
|
||||
(mass : Float))
|
||||
#:mutable)
|
||||
|
||||
(define *sun*
|
||||
(make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
|
||||
|
||||
(define *jupiter*
|
||||
(make-body 4.84143144246472090
|
||||
-1.16032004402742839
|
||||
-1.03622044471123109e-1
|
||||
(* 1.66007664274403694e-3 +days-per-year+)
|
||||
(* 7.69901118419740425e-3 +days-per-year+)
|
||||
(* -6.90460016972063023e-5 +days-per-year+)
|
||||
(* 9.54791938424326609e-4 +solar-mass+)))
|
||||
|
||||
(define *saturn*
|
||||
(make-body 8.34336671824457987
|
||||
4.12479856412430479
|
||||
-4.03523417114321381e-1
|
||||
(* -2.76742510726862411e-3 +days-per-year+)
|
||||
(* 4.99852801234917238e-3 +days-per-year+)
|
||||
(* 2.30417297573763929e-5 +days-per-year+)
|
||||
(* 2.85885980666130812e-4 +solar-mass+)))
|
||||
|
||||
(define *uranus*
|
||||
(make-body 1.28943695621391310e1
|
||||
-1.51111514016986312e1
|
||||
-2.23307578892655734e-1
|
||||
(* 2.96460137564761618e-03 +days-per-year+)
|
||||
(* 2.37847173959480950e-03 +days-per-year+)
|
||||
(* -2.96589568540237556e-05 +days-per-year+)
|
||||
(* 4.36624404335156298e-05 +solar-mass+)))
|
||||
|
||||
(define *neptune*
|
||||
(make-body 1.53796971148509165e+01
|
||||
-2.59193146099879641e+01
|
||||
1.79258772950371181e-01
|
||||
(* 2.68067772490389322e-03 +days-per-year+)
|
||||
(* 1.62824170038242295e-03 +days-per-year+)
|
||||
(* -9.51592254519715870e-05 +days-per-year+)
|
||||
(* 5.15138902046611451e-05 +solar-mass+)))
|
||||
|
||||
(define *system* (list *sun* *jupiter* *saturn* *uranus* *neptune*))
|
||||
|
||||
;; -------------------------------
|
||||
(: offset-momentum ( -> Void))
|
||||
(define (offset-momentum)
|
||||
(let loop-i ([i *system*] [px 0.0] [py 0.0] [pz 0.0])
|
||||
(if (null? i)
|
||||
(begin
|
||||
(set-body-vx! (car *system*) (/ (- px) +solar-mass+))
|
||||
(set-body-vy! (car *system*) (/ (- py) +solar-mass+))
|
||||
(set-body-vz! (car *system*) (/ (- pz) +solar-mass+)))
|
||||
(let ([i1 (car i)])
|
||||
(loop-i (cdr i)
|
||||
(+ px (* (body-vx i1) (body-mass i1)))
|
||||
(+ py (* (body-vy i1) (body-mass i1)))
|
||||
(+ pz (* (body-vz i1) (body-mass i1))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: energy ( -> Float))
|
||||
(define (energy)
|
||||
(let loop-o ([o *system*] [e 0.0])
|
||||
(if (null? o)
|
||||
e
|
||||
(let* ([o1 (car o)]
|
||||
[e (+ e (* 0.5
|
||||
(body-mass o1)
|
||||
(+ (* (body-vx o1) (body-vx o1))
|
||||
(* (body-vy o1) (body-vy o1))
|
||||
(* (body-vz o1) (body-vz o1)))))])
|
||||
(let loop-i ([i (cdr o)] [e e])
|
||||
(if (null? i)
|
||||
(loop-o (cdr o) e)
|
||||
(let* ([i1 (car i)]
|
||||
[dx (- (body-x o1) (body-x i1))]
|
||||
[dy (- (body-y o1) (body-y i1))]
|
||||
[dz (- (body-z o1) (body-z i1))]
|
||||
[dist (assert (sqrt (+ (* dx dx) (* dy dy) (* dz dz))) inexact-real?)]
|
||||
[e (- e (/ (* (body-mass o1) (body-mass i1)) dist))])
|
||||
(loop-i (cdr i) e))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: advance ( -> Void))
|
||||
(define (advance)
|
||||
(let loop-o ([o *system*])
|
||||
(when (pair? o)
|
||||
(let* ([o1 (car o)]
|
||||
[o1x (body-x o1)]
|
||||
[o1y (body-y o1)]
|
||||
[o1z (body-z o1)]
|
||||
[om (body-mass o1)])
|
||||
(let loop-i ([i (cdr o)]
|
||||
[vx (body-vx o1)]
|
||||
[vy (body-vy o1)]
|
||||
[vz (body-vz o1)])
|
||||
(if (pair? i)
|
||||
(let* ([i1 (car i)]
|
||||
[dx (- o1x (body-x i1))]
|
||||
[dy (- o1y (body-y i1))]
|
||||
[dz (- o1z (body-z i1))]
|
||||
[dist2 (+ (* dx dx) (* dy dy) (* dz dz))]
|
||||
[mag (assert (/ +dt+ (* dist2 (sqrt dist2))) inexact-real?)]
|
||||
[dxmag (* dx mag)]
|
||||
[dymag (* dy mag)]
|
||||
[dzmag (* dz mag)]
|
||||
[im (body-mass i1)])
|
||||
(set-body-vx! i1 (+ (body-vx i1) (* dxmag om)))
|
||||
(set-body-vy! i1 (+ (body-vy i1) (* dymag om)))
|
||||
(set-body-vz! i1 (+ (body-vz i1) (* dzmag om)))
|
||||
(loop-i (cdr i)
|
||||
(- vx (* dxmag im))
|
||||
(- vy (* dymag im))
|
||||
(- vz (* dzmag im))))
|
||||
(begin (set-body-vx! o1 vx)
|
||||
(set-body-vy! o1 vy)
|
||||
(set-body-vz! o1 vz)
|
||||
(set-body-x! o1 (+ o1x (* +dt+ vx)))
|
||||
(set-body-y! o1 (+ o1y (* +dt+ vy)))
|
||||
(set-body-z! o1 (+ o1z (* +dt+ vz)))))))
|
||||
(loop-o (cdr o)))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
|
||||
(offset-momentum)
|
||||
(printf "~a\n" (real->decimal-string (energy) 9))
|
||||
(for ([i (in-range n)]) (advance))
|
||||
(printf "~a\n" (real->decimal-string (energy) 9)))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-vec-generic-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-vec-generic-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,167 @@
|
|||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Imperative-style implementation based on the SBCL implementation by
|
||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; idioms like 'named let' and 'do' special form.
|
||||
;;
|
||||
;; Contributed by Anthony Borla, then converted for Racket
|
||||
;; by Matthew Flatt and Brent Fulgham
|
||||
|
||||
#|
|
||||
Correct output N = 1000 is
|
||||
|
||||
-0.169075164
|
||||
-0.169087605
|
||||
|#
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
||||
(define +pi+ 3.141592653589793)
|
||||
(define +days-per-year+ 365.24)
|
||||
|
||||
(define +solar-mass+ (* 4.0 +pi+ +pi+))
|
||||
|
||||
(define +dt+ 0.01)
|
||||
|
||||
(define make-body vector)
|
||||
(define-syntax-rule (deffield n getter setter)
|
||||
(begin (define: (getter (b : (Vectorof Float))) : Float (vector-ref b n))
|
||||
(define: (setter (b : (Vectorof Float)) (x : Float)) : Void (vector-set! b n x))))
|
||||
(deffield 0 body-x set-body-x!)
|
||||
(deffield 1 body-y set-body-y!)
|
||||
(deffield 2 body-z set-body-z!)
|
||||
(deffield 3 body-vx set-body-vx!)
|
||||
(deffield 4 body-vy set-body-vy!)
|
||||
(deffield 5 body-vz set-body-vz!)
|
||||
(deffield 6 body-mass set-body-mass!)
|
||||
|
||||
(define *sun*
|
||||
(make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
|
||||
|
||||
(define *jupiter*
|
||||
(make-body 4.84143144246472090
|
||||
-1.16032004402742839
|
||||
-1.03622044471123109e-1
|
||||
(* 1.66007664274403694e-3 +days-per-year+)
|
||||
(* 7.69901118419740425e-3 +days-per-year+)
|
||||
(* -6.90460016972063023e-5 +days-per-year+)
|
||||
(* 9.54791938424326609e-4 +solar-mass+)))
|
||||
|
||||
(define *saturn*
|
||||
(make-body 8.34336671824457987
|
||||
4.12479856412430479
|
||||
-4.03523417114321381e-1
|
||||
(* -2.76742510726862411e-3 +days-per-year+)
|
||||
(* 4.99852801234917238e-3 +days-per-year+)
|
||||
(* 2.30417297573763929e-5 +days-per-year+)
|
||||
(* 2.85885980666130812e-4 +solar-mass+)))
|
||||
|
||||
(define *uranus*
|
||||
(make-body 1.28943695621391310e1
|
||||
-1.51111514016986312e1
|
||||
-2.23307578892655734e-1
|
||||
(* 2.96460137564761618e-03 +days-per-year+)
|
||||
(* 2.37847173959480950e-03 +days-per-year+)
|
||||
(* -2.96589568540237556e-05 +days-per-year+)
|
||||
(* 4.36624404335156298e-05 +solar-mass+)))
|
||||
|
||||
(define *neptune*
|
||||
(make-body 1.53796971148509165e+01
|
||||
-2.59193146099879641e+01
|
||||
1.79258772950371181e-01
|
||||
(* 2.68067772490389322e-03 +days-per-year+)
|
||||
(* 1.62824170038242295e-03 +days-per-year+)
|
||||
(* -9.51592254519715870e-05 +days-per-year+)
|
||||
(* 5.15138902046611451e-05 +solar-mass+)))
|
||||
|
||||
(define *system* (list *sun* *jupiter* *saturn* *uranus* *neptune*))
|
||||
|
||||
;; -------------------------------
|
||||
(: offset-momentum ( -> Void))
|
||||
(define (offset-momentum)
|
||||
(let loop-i ([i *system*] [px 0.0] [py 0.0] [pz 0.0])
|
||||
(if (null? i)
|
||||
(begin
|
||||
(set-body-vx! (car *system*) (/ (- px) +solar-mass+))
|
||||
(set-body-vy! (car *system*) (/ (- py) +solar-mass+))
|
||||
(set-body-vz! (car *system*) (/ (- pz) +solar-mass+)))
|
||||
(let ([i1 (car i)])
|
||||
(loop-i (cdr i)
|
||||
(+ px (* (body-vx i1) (body-mass i1)))
|
||||
(+ py (* (body-vy i1) (body-mass i1)))
|
||||
(+ pz (* (body-vz i1) (body-mass i1))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: energy ( -> Float))
|
||||
(define (energy)
|
||||
(let loop-o ([o *system*] [e 0.0])
|
||||
(if (null? o)
|
||||
e
|
||||
(let* ([o1 (car o)]
|
||||
[e (+ e (* 0.5
|
||||
(body-mass o1)
|
||||
(+ (* (body-vx o1) (body-vx o1))
|
||||
(* (body-vy o1) (body-vy o1))
|
||||
(* (body-vz o1) (body-vz o1)))))])
|
||||
(let loop-i ([i (cdr o)] [e e])
|
||||
(if (null? i)
|
||||
(loop-o (cdr o) e)
|
||||
(let* ([i1 (car i)]
|
||||
[dx (- (body-x o1) (body-x i1))]
|
||||
[dy (- (body-y o1) (body-y i1))]
|
||||
[dz (- (body-z o1) (body-z i1))]
|
||||
[dist (assert (sqrt (+ (* dx dx) (* dy dy) (* dz dz))) inexact-real?)]
|
||||
[e (- e (/ (* (body-mass o1) (body-mass i1)) dist))])
|
||||
(loop-i (cdr i) e))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: advance ( -> Void))
|
||||
(define (advance)
|
||||
(let loop-o ([o *system*])
|
||||
(when (pair? o)
|
||||
(let* ([o1 (car o)]
|
||||
[o1x (body-x o1)]
|
||||
[o1y (body-y o1)]
|
||||
[o1z (body-z o1)]
|
||||
[om (body-mass o1)])
|
||||
(let loop-i ([i (cdr o)]
|
||||
[vx (body-vx o1)]
|
||||
[vy (body-vy o1)]
|
||||
[vz (body-vz o1)])
|
||||
(if (pair? i)
|
||||
(let* ([i1 (car i)]
|
||||
[dx (- o1x (body-x i1))]
|
||||
[dy (- o1y (body-y i1))]
|
||||
[dz (- o1z (body-z i1))]
|
||||
[dist2 (+ (* dx dx) (* dy dy) (* dz dz))]
|
||||
[mag (assert (/ +dt+ (* dist2 (sqrt dist2))) inexact-real?)]
|
||||
[dxmag (* dx mag)]
|
||||
[dymag (* dy mag)]
|
||||
[dzmag (* dz mag)]
|
||||
[im (body-mass i1)])
|
||||
(set-body-vx! i1 (+ (body-vx i1) (* dxmag om)))
|
||||
(set-body-vy! i1 (+ (body-vy i1) (* dymag om)))
|
||||
(set-body-vz! i1 (+ (body-vz i1) (* dzmag om)))
|
||||
(loop-i (cdr i)
|
||||
(- vx (* dxmag im))
|
||||
(- vy (* dymag im))
|
||||
(- vz (* dzmag im))))
|
||||
(begin (set-body-vx! o1 vx)
|
||||
(set-body-vy! o1 vy)
|
||||
(set-body-vz! o1 vz)
|
||||
(set-body-x! o1 (+ o1x (* +dt+ vx)))
|
||||
(set-body-y! o1 (+ o1y (* +dt+ vy)))
|
||||
(set-body-z! o1 (+ o1z (* +dt+ vz)))))))
|
||||
(loop-o (cdr o)))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
|
||||
(offset-momentum)
|
||||
(printf "~a\n" (real->decimal-string (energy) 9))
|
||||
(for ([i (in-range n)]) (advance))
|
||||
(printf "~a\n" (real->decimal-string (energy) 9)))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-vec-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-vec-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-vec-unsafe-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nbody-vec-unsafe-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,170 @@
|
|||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Imperative-style implementation based on the SBCL implementation by
|
||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; idioms like 'named let' and 'do' special form.
|
||||
;;
|
||||
;; Contributed by Anthony Borla, then converted for Racket
|
||||
;; by Matthew Flatt and Brent Fulgham
|
||||
;; Made unsafe and optimized by Sam TH
|
||||
#|
|
||||
Correct output N = 1000 is
|
||||
|
||||
-0.169075164
|
||||
-0.169087605
|
||||
|#
|
||||
|
||||
(require racket/cmdline racket/require
|
||||
(only-in racket/flonum flvector)
|
||||
(for-syntax racket/base)
|
||||
(filtered-in
|
||||
(lambda (name)
|
||||
(regexp-replace
|
||||
#rx"unsafe-fl" name "fl"))
|
||||
racket/unsafe/ops))
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
||||
(define +pi+ 3.141592653589793) ;; define locally to enable inlining
|
||||
(define +days-per-year+ 365.24)
|
||||
|
||||
(define +solar-mass+ (* 4.0 +pi+ +pi+))
|
||||
|
||||
(define +dt+ 0.01)
|
||||
|
||||
(define make-body flvector)
|
||||
(define-syntax-rule (deffield n getter setter)
|
||||
(begin (define-syntax-rule (getter b) (flvector-ref b n))
|
||||
(define-syntax-rule (setter b x) (flvector-set! b n x))))
|
||||
(deffield 0 body-x set-body-x!)
|
||||
(deffield 1 body-y set-body-y!)
|
||||
(deffield 2 body-z set-body-z!)
|
||||
(deffield 3 body-vx set-body-vx!)
|
||||
(deffield 4 body-vy set-body-vy!)
|
||||
(deffield 5 body-vz set-body-vz!)
|
||||
(deffield 6 body-mass set-body-mass!)
|
||||
|
||||
(define *sun*
|
||||
(make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
|
||||
|
||||
(define *jupiter*
|
||||
(make-body 4.84143144246472090
|
||||
-1.16032004402742839
|
||||
-1.03622044471123109e-1
|
||||
(fl* 1.66007664274403694e-3 +days-per-year+)
|
||||
(fl* 7.69901118419740425e-3 +days-per-year+)
|
||||
(fl* -6.90460016972063023e-5 +days-per-year+)
|
||||
(fl* 9.54791938424326609e-4 +solar-mass+)))
|
||||
|
||||
(define *saturn*
|
||||
(make-body 8.34336671824457987
|
||||
4.12479856412430479
|
||||
-4.03523417114321381e-1
|
||||
(fl* -2.76742510726862411e-3 +days-per-year+)
|
||||
(fl* 4.99852801234917238e-3 +days-per-year+)
|
||||
(fl* 2.30417297573763929e-5 +days-per-year+)
|
||||
(fl* 2.85885980666130812e-4 +solar-mass+)))
|
||||
|
||||
(define *uranus*
|
||||
(make-body 1.28943695621391310e1
|
||||
-1.51111514016986312e1
|
||||
-2.23307578892655734e-1
|
||||
(fl* 2.96460137564761618e-03 +days-per-year+)
|
||||
(fl* 2.37847173959480950e-03 +days-per-year+)
|
||||
(fl* -2.96589568540237556e-05 +days-per-year+)
|
||||
(fl* 4.36624404335156298e-05 +solar-mass+)))
|
||||
|
||||
(define *neptune*
|
||||
(make-body 1.53796971148509165e+01
|
||||
-2.59193146099879641e+01
|
||||
1.79258772950371181e-01
|
||||
(fl* 2.68067772490389322e-03 +days-per-year+)
|
||||
(fl* 1.62824170038242295e-03 +days-per-year+)
|
||||
(fl* -9.51592254519715870e-05 +days-per-year+)
|
||||
(fl* 5.15138902046611451e-05 +solar-mass+)))
|
||||
|
||||
(define *system* (vector *sun* *jupiter* *saturn* *uranus* *neptune*))
|
||||
(define *system-size* 5)
|
||||
;; -------------------------------
|
||||
(: offset-momentum ( -> Void))
|
||||
(define (offset-momentum)
|
||||
(let loop-i ([i 0] [px 0.0] [py 0.0] [pz 0.0])
|
||||
(if (unsafe-fx= i *system-size*)
|
||||
(begin
|
||||
(set-body-vx! (unsafe-vector-ref *system* 0) (fl/ (fl- 0.0 px) +solar-mass+))
|
||||
(set-body-vy! (unsafe-vector-ref *system* 0) (fl/ (fl- 0.0 py) +solar-mass+))
|
||||
(set-body-vz! (unsafe-vector-ref *system* 0) (fl/ (fl- 0.0 pz) +solar-mass+)))
|
||||
(let ([i1 (unsafe-vector-ref *system* i)])
|
||||
(loop-i (unsafe-fx+ i 1)
|
||||
(fl+ px (fl* (body-vx i1) (body-mass i1)))
|
||||
(fl+ py (fl* (body-vy i1) (body-mass i1)))
|
||||
(fl+ pz (fl* (body-vz i1) (body-mass i1))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: energy ( -> Float))
|
||||
(define (energy)
|
||||
(let loop-o ([o 0] [e 0.0])
|
||||
(if (unsafe-fx= o *system-size*)
|
||||
e
|
||||
(let* ([o1 (unsafe-vector-ref *system* o)]
|
||||
[e (fl+ e (fl* (fl* 0.5 (body-mass o1))
|
||||
(fl+ (fl+ (fl* (body-vx o1) (body-vx o1))
|
||||
(fl* (body-vy o1) (body-vy o1)))
|
||||
(fl* (body-vz o1) (body-vz o1)))))])
|
||||
(let loop-i ([i (unsafe-fx+ o 1)] [e e])
|
||||
(if (unsafe-fx= i *system-size*)
|
||||
(loop-o (unsafe-fx+ o 1) e)
|
||||
(let* ([i1 (unsafe-vector-ref *system* i)]
|
||||
[dx (fl- (body-x o1) (body-x i1))]
|
||||
[dy (fl- (body-y o1) (body-y i1))]
|
||||
[dz (fl- (body-z o1) (body-z i1))]
|
||||
[dist (flsqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz)))]
|
||||
[e (fl- e (fl/ (fl* (body-mass o1) (body-mass i1)) dist))])
|
||||
(loop-i (unsafe-fx+ i 1) e))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: advance ( -> Void))
|
||||
(define (advance)
|
||||
(let loop-o ([o 0])
|
||||
(unless (unsafe-fx= o *system-size*)
|
||||
(let* ([o1 (unsafe-vector-ref *system* o)])
|
||||
(let loop-i ([i (unsafe-fx+ o 1)]
|
||||
[vx (body-vx o1)]
|
||||
[vy (body-vy o1)]
|
||||
[vz (body-vz o1)])
|
||||
(if (unsafe-fx< i *system-size*)
|
||||
(let* ([i1 (unsafe-vector-ref *system* i)]
|
||||
[dx (fl- (body-x o1) (body-x i1))]
|
||||
[dy (fl- (body-y o1) (body-y i1))]
|
||||
[dz (fl- (body-z o1) (body-z i1))]
|
||||
[dist2 (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz))]
|
||||
[mag (fl/ +dt+ (fl* dist2 (flsqrt dist2)))]
|
||||
[dxmag (fl* dx mag)]
|
||||
[dymag (fl* dy mag)]
|
||||
[dzmag (fl* dz mag)]
|
||||
[om (body-mass o1)]
|
||||
[im (body-mass i1)])
|
||||
(set-body-vx! i1 (fl+ (body-vx i1) (fl* dxmag om)))
|
||||
(set-body-vy! i1 (fl+ (body-vy i1) (fl* dymag om)))
|
||||
(set-body-vz! i1 (fl+ (body-vz i1) (fl* dzmag om)))
|
||||
(loop-i (unsafe-fx+ i 1)
|
||||
(fl- vx (fl* dxmag im))
|
||||
(fl- vy (fl* dymag im))
|
||||
(fl- vz (fl* dzmag im))))
|
||||
(begin (set-body-vx! o1 vx)
|
||||
(set-body-vy! o1 vy)
|
||||
(set-body-vz! o1 vz)
|
||||
(set-body-x! o1 (fl+ (body-x o1) (fl* +dt+ vx)))
|
||||
(set-body-y! o1 (fl+ (body-y o1) (fl* +dt+ vy)))
|
||||
(set-body-z! o1 (fl+ (body-z o1) (fl* +dt+ vz)))))))
|
||||
(loop-o (unsafe-fx+ o 1)))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
|
||||
(offset-momentum)
|
||||
(printf "~a\n" (real->decimal-string (energy) 9))
|
||||
(for ([i (in-range n)]) (advance))
|
||||
(printf "~a\n" (real->decimal-string (energy) 9)))
|
||||
168
collects/tests/racket/benchmarks/shootout/typed/nbody-vec.rktl
Normal file
168
collects/tests/racket/benchmarks/shootout/typed/nbody-vec.rktl
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Imperative-style implementation based on the SBCL implementation by
|
||||
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
|
||||
;; idioms like 'named let' and 'do' special form.
|
||||
;;
|
||||
;; Contributed by Anthony Borla, then converted for Racket
|
||||
;; by Matthew Flatt and Brent Fulgham
|
||||
|
||||
#|
|
||||
Correct output N = 1000 is
|
||||
|
||||
-0.169075164
|
||||
-0.169087605
|
||||
|#
|
||||
|
||||
(require racket/cmdline
|
||||
racket/flonum)
|
||||
|
||||
;; ------------------------------
|
||||
;; define planetary masses, initial positions & velocity
|
||||
|
||||
(define +pi+ 3.141592653589793)
|
||||
(define +days-per-year+ 365.24)
|
||||
|
||||
(define +solar-mass+ (* 4.0 +pi+ +pi+))
|
||||
|
||||
(define +dt+ 0.01)
|
||||
|
||||
(define make-body flvector)
|
||||
(define-syntax-rule (deffield n getter setter)
|
||||
(begin (define: (getter (b : FlVector)) : Float (flvector-ref b n))
|
||||
(define: (setter (b : FlVector) (x : Float)) : Void (flvector-set! b n x))))
|
||||
(deffield 0 body-x set-body-x!)
|
||||
(deffield 1 body-y set-body-y!)
|
||||
(deffield 2 body-z set-body-z!)
|
||||
(deffield 3 body-vx set-body-vx!)
|
||||
(deffield 4 body-vy set-body-vy!)
|
||||
(deffield 5 body-vz set-body-vz!)
|
||||
(deffield 6 body-mass set-body-mass!)
|
||||
|
||||
(define *sun*
|
||||
(make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
|
||||
|
||||
(define *jupiter*
|
||||
(make-body 4.84143144246472090
|
||||
-1.16032004402742839
|
||||
-1.03622044471123109e-1
|
||||
(* 1.66007664274403694e-3 +days-per-year+)
|
||||
(* 7.69901118419740425e-3 +days-per-year+)
|
||||
(* -6.90460016972063023e-5 +days-per-year+)
|
||||
(* 9.54791938424326609e-4 +solar-mass+)))
|
||||
|
||||
(define *saturn*
|
||||
(make-body 8.34336671824457987
|
||||
4.12479856412430479
|
||||
-4.03523417114321381e-1
|
||||
(* -2.76742510726862411e-3 +days-per-year+)
|
||||
(* 4.99852801234917238e-3 +days-per-year+)
|
||||
(* 2.30417297573763929e-5 +days-per-year+)
|
||||
(* 2.85885980666130812e-4 +solar-mass+)))
|
||||
|
||||
(define *uranus*
|
||||
(make-body 1.28943695621391310e1
|
||||
-1.51111514016986312e1
|
||||
-2.23307578892655734e-1
|
||||
(* 2.96460137564761618e-03 +days-per-year+)
|
||||
(* 2.37847173959480950e-03 +days-per-year+)
|
||||
(* -2.96589568540237556e-05 +days-per-year+)
|
||||
(* 4.36624404335156298e-05 +solar-mass+)))
|
||||
|
||||
(define *neptune*
|
||||
(make-body 1.53796971148509165e+01
|
||||
-2.59193146099879641e+01
|
||||
1.79258772950371181e-01
|
||||
(* 2.68067772490389322e-03 +days-per-year+)
|
||||
(* 1.62824170038242295e-03 +days-per-year+)
|
||||
(* -9.51592254519715870e-05 +days-per-year+)
|
||||
(* 5.15138902046611451e-05 +solar-mass+)))
|
||||
|
||||
(define *system* (list *sun* *jupiter* *saturn* *uranus* *neptune*))
|
||||
|
||||
;; -------------------------------
|
||||
(: offset-momentum ( -> Void))
|
||||
(define (offset-momentum)
|
||||
(let loop-i ([i *system*] [px 0.0] [py 0.0] [pz 0.0])
|
||||
(if (null? i)
|
||||
(begin
|
||||
(set-body-vx! (car *system*) (fl/ (fl- 0.0 px) +solar-mass+))
|
||||
(set-body-vy! (car *system*) (fl/ (fl- 0.0 py) +solar-mass+))
|
||||
(set-body-vz! (car *system*) (fl/ (fl- 0.0 pz) +solar-mass+)))
|
||||
(let ([i1 (car i)])
|
||||
(loop-i (cdr i)
|
||||
(fl+ px (fl* (body-vx i1) (body-mass i1)))
|
||||
(fl+ py (fl* (body-vy i1) (body-mass i1)))
|
||||
(fl+ pz (fl* (body-vz i1) (body-mass i1))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: energy ( -> Float))
|
||||
(define (energy)
|
||||
(let loop-o ([o *system*] [e 0.0])
|
||||
(if (null? o)
|
||||
e
|
||||
(let* ([o1 (car o)]
|
||||
[e (+ e (fl* 0.5
|
||||
(fl* (body-mass o1)
|
||||
(fl+ (fl+ (fl* (body-vx o1) (body-vx o1))
|
||||
(fl* (body-vy o1) (body-vy o1)))
|
||||
(fl* (body-vz o1) (body-vz o1))))))])
|
||||
(let loop-i ([i (cdr o)] [e e])
|
||||
(if (null? i)
|
||||
(loop-o (cdr o) e)
|
||||
(let* ([i1 (car i)]
|
||||
[dx (fl- (body-x o1) (body-x i1))]
|
||||
[dy (fl- (body-y o1) (body-y i1))]
|
||||
[dz (fl- (body-z o1) (body-z i1))]
|
||||
[dist (flsqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz)))]
|
||||
[e (fl- e (fl/ (fl* (body-mass o1) (body-mass i1)) dist))])
|
||||
(loop-i (cdr i) e))))))))
|
||||
|
||||
;; -------------------------------
|
||||
(: advance ( -> Void))
|
||||
(define (advance)
|
||||
(let loop-o ([o *system*])
|
||||
(when (pair? o)
|
||||
(let* ([o1 (car o)]
|
||||
[o1x (body-x o1)]
|
||||
[o1y (body-y o1)]
|
||||
[o1z (body-z o1)]
|
||||
[om (body-mass o1)])
|
||||
(let loop-i ([i (cdr o)]
|
||||
[vx (body-vx o1)]
|
||||
[vy (body-vy o1)]
|
||||
[vz (body-vz o1)])
|
||||
(if (pair? i)
|
||||
(let* ([i1 (car i)]
|
||||
[dx (fl- o1x (body-x i1))]
|
||||
[dy (fl- o1y (body-y i1))]
|
||||
[dz (fl- o1z (body-z i1))]
|
||||
[dist2 (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz))]
|
||||
[mag (fl/ +dt+ (fl* dist2 (flsqrt dist2)))]
|
||||
[dxmag (fl* dx mag)]
|
||||
[dymag (fl* dy mag)]
|
||||
[dzmag (fl* dz mag)]
|
||||
[im (body-mass i1)])
|
||||
(set-body-vx! i1 (fl+ (body-vx i1) (fl* dxmag om)))
|
||||
(set-body-vy! i1 (fl+ (body-vy i1) (fl* dymag om)))
|
||||
(set-body-vz! i1 (fl+ (body-vz i1) (fl* dzmag om)))
|
||||
(loop-i (cdr i)
|
||||
(fl- vx (fl* dxmag im))
|
||||
(fl- vy (fl* dymag im))
|
||||
(fl- vz (fl* dzmag im))))
|
||||
(begin (set-body-vx! o1 vx)
|
||||
(set-body-vy! o1 vy)
|
||||
(set-body-vz! o1 vz)
|
||||
(set-body-x! o1 (fl+ o1x (fl* +dt+ vx)))
|
||||
(set-body-y! o1 (fl+ o1y (fl* +dt+ vy)))
|
||||
(set-body-z! o1 (fl+ o1z (fl* +dt+ vz)))))))
|
||||
(loop-o (cdr o)))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
|
||||
(offset-momentum)
|
||||
(printf "~a\n" (real->decimal-string (energy) 9))
|
||||
(for ([i (in-range n)]) (advance))
|
||||
(printf "~a\n" (real->decimal-string (energy) 9)))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module regexmatch-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module regexmatch-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
;; $Id: regexmatch-mzscheme.code,v 1.9 2006/06/21 15:05:29 bfulgham Exp $
|
||||
;;; http://shootout.alioth.debian.org/
|
||||
;;;
|
||||
;;; Based on the Chicken implementation
|
||||
;;; Contributed by Brent Fulgham
|
||||
|
||||
;; Uses byte regexps instead of string regexps for a fairer comparison
|
||||
|
||||
;; NOTE: the running time of this benchmark is dominated by
|
||||
;; construction of the `num' string.
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(define rx
|
||||
(string-append
|
||||
"(?:^|[^0-9\\(])" ; (1) preceding non-digit or bol
|
||||
"(" ; (2) area code
|
||||
"\\(([0-9][0-9][0-9])\\)" ; (3) is either 3 digits in parens
|
||||
"|" ; or
|
||||
"([0-9][0-9][0-9])" ; (4) just 3 digits
|
||||
")" ; end of area code
|
||||
" " ; area code is followed by one space
|
||||
"([0-9][0-9][0-9])" ; (5) exchange is 3 digits
|
||||
"[ -]" ; separator is either space or dash
|
||||
"([0-9][0-9][0-9][0-9])" ; (6) last 4 digits
|
||||
"(?:[^0-9]|$)" ; must be followed by a non-digit
|
||||
))
|
||||
|
||||
|
||||
(: main ((Vectorof String) -> Void))
|
||||
(define (main args)
|
||||
(let: ((n : String
|
||||
(if (= (vector-length args) 0)
|
||||
"1"
|
||||
(vector-ref args 0)))
|
||||
(phonelines : (Listof Bytes) '())
|
||||
(rx : Byte-Regexp (byte-regexp (string->bytes/utf-8 rx)))
|
||||
(count : Integer 0))
|
||||
(let: loop : False
|
||||
((line : (U Bytes EOF) (read-bytes-line)))
|
||||
(cond ((eof-object? line) #f)
|
||||
(else
|
||||
(set! phonelines (cons line phonelines))
|
||||
(loop (read-bytes-line)))))
|
||||
(set! phonelines (reverse phonelines))
|
||||
(do ([n (assert (string->number n) exact-integer?)
|
||||
(sub1 n)])
|
||||
((negative? n))
|
||||
(let loop ((phones phonelines)
|
||||
(count 0))
|
||||
(if (null? phones)
|
||||
count
|
||||
(let: ([m : (Option (Listof (Option Bytes)))
|
||||
(regexp-match rx (car phones))])
|
||||
(if m
|
||||
(match-let ([(list a1 a2 a3 exch numb) (cdr m)])
|
||||
(let* ([area (and a1 (or a2 a3))]
|
||||
[num (bytes-append #"(" (assert area) #") "
|
||||
(assert exch) #"-"
|
||||
(assert numb))]
|
||||
[count (add1 count)])
|
||||
(when (zero? n)
|
||||
(printf "~a: ~a~n" count num))
|
||||
(loop (cdr phones) count)))
|
||||
(loop (cdr phones) count))))))))
|
||||
|
||||
(main (current-command-line-arguments))
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module spectralnorm-generic-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module spectralnorm-generic-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
;; Translated directly from the C# version, which was:
|
||||
;; contributed by Isaac Gouy
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
(: Approximate (Natural -> Float))
|
||||
(define (Approximate n)
|
||||
(let ([u (make-vector n 1.0)]
|
||||
[v (make-vector n 0.0)])
|
||||
;; 20 steps of the power method
|
||||
(for: : Void ([i : Natural (in-range 10)])
|
||||
(MultiplyAtAv n u v)
|
||||
(MultiplyAtAv n v u))
|
||||
|
||||
;; B=AtA A multiplied by A transposed
|
||||
;; v.Bv /(v.v) eigenvalue of v
|
||||
(let: loop : Float ([i : Natural 0][vBv : Float 0.0][vv : Float 0.0])
|
||||
(if (= i n)
|
||||
(assert (sqrt (/ vBv vv)) inexact-real?)
|
||||
(let ([vi (vector-ref v i)])
|
||||
(loop (add1 i)
|
||||
(+ vBv (* (vector-ref u i) vi))
|
||||
(+ vv (* vi vi))))))))
|
||||
|
||||
;; return element i,j of infinite matrix A
|
||||
(: A (Natural Natural -> Float))
|
||||
(define (A i j)
|
||||
(exact->inexact (/ 1.0 (+ (* (+ i j) (/ (+ i (+ j 1)) 2.0)) (+ i 1)))))
|
||||
|
||||
;; multiply vector v by matrix A
|
||||
(: MultiplyAv (Natural (Vectorof Float) (Vectorof Float) -> Void))
|
||||
(define (MultiplyAv n v Av)
|
||||
(for: : Void ([i : Natural (in-range n)])
|
||||
(vector-set! Av i
|
||||
(for/fold: : Float ([r : Float 0.0])
|
||||
([j : Natural (in-range n)])
|
||||
(+ r (* (A i j) (vector-ref v j)))))))
|
||||
|
||||
;; multiply vector v by matrix A transposed
|
||||
(: MultiplyAtv (Natural (Vectorof Float) (Vectorof Float) -> Void))
|
||||
(define (MultiplyAtv n v Atv)
|
||||
(for: : Void ([i : Natural (in-range n)])
|
||||
(vector-set! Atv i
|
||||
(for/fold: : Float ([r : Float 0.0])
|
||||
([j : Natural (in-range n)])
|
||||
(+ r (* (A j i) (vector-ref v j)))))))
|
||||
|
||||
;; multiply vector v by matrix A and then by matrix A transposed
|
||||
(: MultiplyAtAv (Natural (Vectorof Float) (Vectorof Float) -> Void))
|
||||
(define (MultiplyAtAv n v AtAv)
|
||||
(let ([u (make-vector n 0.0)])
|
||||
(MultiplyAv n v u)
|
||||
(MultiplyAtv n u AtAv)))
|
||||
|
||||
(printf "~a\n"
|
||||
(real->decimal-string
|
||||
(Approximate (command-line #:args (n) (assert (string->number (assert n string?)) exact-nonnegative-integer?)))
|
||||
9))
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module spectralnorm-unsafe-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module spectralnorm-unsafe-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
;; Translated directly from the C# version, which was:
|
||||
;; contributed by Isaac Gouy
|
||||
|
||||
(require racket/cmdline
|
||||
racket/require (for-syntax racket/base)
|
||||
(rename-in
|
||||
(filtered-in
|
||||
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||
racket/unsafe/ops)
|
||||
[fx->fl ->fl])
|
||||
(only-in racket/flonum make-flvector))
|
||||
|
||||
|
||||
(: Approximate (Natural -> Float))
|
||||
(define (Approximate n)
|
||||
(let ([u (make-flvector n 1.0)]
|
||||
[v (make-flvector n 0.0)])
|
||||
;; 20 steps of the power method
|
||||
(for ([i (in-range 10)])
|
||||
(MultiplyAtAv n u v)
|
||||
(MultiplyAtAv n v u))
|
||||
|
||||
;; B=AtA A multiplied by A transposed
|
||||
;; v.Bv /(v.v) eigenvalue of v
|
||||
(let: loop : Float ([i : Natural 0][vBv : Float 0.0][vv : Float 0.0])
|
||||
(if (= i n)
|
||||
(flsqrt (fl/ vBv vv))
|
||||
(let ([vi (flvector-ref v i)])
|
||||
(loop (add1 i)
|
||||
(fl+ vBv (fl* (flvector-ref u i) vi))
|
||||
(fl+ vv (fl* vi vi))))))))
|
||||
|
||||
;; return element i,j of infinite matrix A
|
||||
(: A (Natural Natural -> Float))
|
||||
(define (A i j)
|
||||
(fl/ 1.0 (fl+ (fl* (->fl (+ i j))
|
||||
(fl/ (->fl (+ i (+ j 1))) 2.0))
|
||||
(->fl (+ i 1)))))
|
||||
|
||||
;; multiply vector v by matrix A
|
||||
(: MultiplyAv (Natural FlVector FlVector -> Void))
|
||||
(define (MultiplyAv n v Av)
|
||||
(for ([i (in-range n)])
|
||||
(flvector-set! Av i
|
||||
(for/fold ([r 0.0])
|
||||
([j (in-range n)])
|
||||
(fl+ r (fl* (A i j) (flvector-ref v j)))))))
|
||||
|
||||
;; multiply vector v by matrix A transposed
|
||||
(: MultiplyAtv (Natural FlVector FlVector -> Void))
|
||||
(define (MultiplyAtv n v Atv)
|
||||
(for ([i (in-range n)])
|
||||
(flvector-set! Atv i
|
||||
(for/fold ([r 0.0])
|
||||
([j (in-range n)])
|
||||
(fl+ r (fl* (A j i) (flvector-ref v j)))))))
|
||||
|
||||
;; multiply vector v by matrix A and then by matrix A transposed
|
||||
(: MultiplyAtAv (Natural FlVector FlVector -> Void))
|
||||
(define (MultiplyAtAv n v AtAv)
|
||||
(let ([u (make-flvector n 0.0)])
|
||||
(MultiplyAv n v u)
|
||||
(MultiplyAtv n u AtAv)))
|
||||
|
||||
(printf "~a\n"
|
||||
(real->decimal-string
|
||||
(Approximate (command-line #:args (n) (assert (string->number (assert n string?)) exact-nonnegative-integer?)))
|
||||
9))
|
||||
|
|
@ -12,7 +12,7 @@
|
|||
(let ([u (make-flvector n 1.0)]
|
||||
[v (make-flvector n 0.0)])
|
||||
;; 20 steps of the power method
|
||||
(for: : Void ([i : Integer (in-range 10)])
|
||||
(for: : Void ([i : Natural (in-range 10)])
|
||||
(MultiplyAtAv n u v)
|
||||
(MultiplyAtAv n v u))
|
||||
|
||||
|
|
@ -27,7 +27,7 @@
|
|||
(fl+ vv (fl* vi vi))))))))
|
||||
|
||||
;; return element i,j of infinite matrix A
|
||||
(: A (Integer Integer -> Float))
|
||||
(: A (Natural Natural -> Float))
|
||||
(define (A i j)
|
||||
(fl/ 1.0 (fl+ (fl* (->fl (+ i j))
|
||||
(fl/ (->fl (+ i (+ j 1))) 2.0))
|
||||
|
|
@ -60,6 +60,6 @@
|
|||
|
||||
(printf "~a\n"
|
||||
(real->decimal-string
|
||||
(Approximate (command-line #:args (n) (assert (string->number (assert n string?)) exact-positive-integer?)))
|
||||
(Approximate (command-line #:args (n) (assert (string->number (assert n string?)) exact-nonnegative-integer?)))
|
||||
9))
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module thread-ring-non-optimizing "wrap-typed-non-optimizing.ss")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module thread-ring-optimizing "wrap-typed-optimizing.ss")
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Uses Racket threads
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
;; Each thread runs this loop:
|
||||
(: run (Integer Thread -> Void))
|
||||
(define (run id next)
|
||||
(let ([v (assert (thread-receive) exact-integer?)])
|
||||
(cond
|
||||
[(zero? v) ;; Done
|
||||
(printf "~a\n" id)
|
||||
(exit)]
|
||||
[else ;; Keep going
|
||||
(thread-send next (sub1 v))
|
||||
(run id next)])))
|
||||
|
||||
|
||||
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
|
||||
;; The original thread is #503. Create the rest:
|
||||
(let ([t1 (for/fold: : Thread
|
||||
([next : Thread (current-thread)])
|
||||
([id : Integer (in-range 502 0 -1)])
|
||||
(thread (lambda () (run id next))))])
|
||||
;; Start:
|
||||
(thread-send t1 n)
|
||||
(run 503 t1)))
|
||||
Loading…
Reference in New Issue
Block a user