Some improved shootout benchmarks.
* An improved version of the `fasta' benchmark: ~2.5 times faster, and if an inlined `unsafe-fl->fx' is added it is probably going to be about ~3.5 times faster. * `reversecomplement' -- revised code that is ~2.5 times faster, further tweaks and unsafe ops gets it to ~4.5 times. * Doing the structs differently in `binarytrees' and a few minor tweaks get it to be ~1.5 times faster. This is probably because a leaf has now only one field. * `mandelbrot' improved a little (~1.2x), but the code is pretty much a rewrite. (Given some more flonum inlining it can probably do much better.) * Added a comment to `pidigits-gmp' saying that it was used without attribution. These versions use unsafe operations, but I'm not putting them in separate files since it's easy to turn them off. I've also removed "mandelbrot-unsafe.rkt", since it was identical to the safe version.
This commit is contained in:
Eli Barzilay
parent
412fd4ff79
commit
96006264ad
|
|
@ -4,51 +4,54 @@
|
|||
;;; 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))
|
||||
|
||||
(struct node (left val right))
|
||||
(struct *leaf (val))
|
||||
(struct *node *leaf (left right))
|
||||
|
||||
;; Instead of (define-struct leaf (val)):
|
||||
(define (leaf val) (node #f val #f))
|
||||
(define (leaf? l) (not (node-left l)))
|
||||
(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))
|
||||
|
||||
(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)))))
|
||||
|
||||
(define (check t)
|
||||
(if (leaf? t)
|
||||
(leaf-val t)
|
||||
(+ (node-val t) (- (check (node-left t))
|
||||
(check (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)
|
||||
|
||||
(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 ([c 0])
|
||||
([i (in-range iterations)])
|
||||
(+ c
|
||||
(check (make i d))
|
||||
(check (make (- i) d)))))))
|
||||
(for/fold ([c 0]) ([i (in-range iterations)])
|
||||
(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 (string->number n)))
|
||||
(command-line #:args (n) (time (main (string->number n))))
|
||||
|
|
|
|||
|
|
@ -5,104 +5,113 @@
|
|||
;;
|
||||
;; fasta - benchmark
|
||||
;;
|
||||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
|
||||
(require racket/cmdline)
|
||||
;; Very loosely based on the Chicken variant by Anthony Borla,
|
||||
;; some optimizations taken from the GCC version by Petr Prokhorenkov.
|
||||
|
||||
(define +alu+
|
||||
(bytes-append
|
||||
#"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
|
||||
#"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
|
||||
#"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
|
||||
#"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
|
||||
#"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
|
||||
#"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
|
||||
#"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
|
||||
(bytes-append #"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
|
||||
#"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
|
||||
#"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
|
||||
#"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
|
||||
#"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
|
||||
#"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
|
||||
#"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
|
||||
|
||||
(define +iub+
|
||||
(list
|
||||
'(#\a . 0.27) '(#\c . 0.12) '(#\g . 0.12) '(#\t . 0.27) '(#\B . 0.02)
|
||||
'(#\D . 0.02) '(#\H . 0.02) '(#\K . 0.02) '(#\M . 0.02) '(#\N . 0.02)
|
||||
'(#\R . 0.02) '(#\S . 0.02) '(#\V . 0.02) '(#\W . 0.02) '(#\Y . 0.02)))
|
||||
(define IUB
|
||||
'([#\a 0.27] [#\c 0.12] [#\g 0.12] [#\t 0.27] [#\B 0.02]
|
||||
[#\D 0.02] [#\H 0.02] [#\K 0.02] [#\M 0.02] [#\N 0.02]
|
||||
[#\R 0.02] [#\S 0.02] [#\V 0.02] [#\W 0.02] [#\Y 0.02]))
|
||||
|
||||
(define +homosapien+
|
||||
(list
|
||||
'(#\a . 0.3029549426680) '(#\c . 0.1979883004921)
|
||||
'(#\g . 0.1975473066391) '(#\t . 0.3015094502008)))
|
||||
(define HOMOSAPIEN
|
||||
'([#\a 0.3029549426680] [#\c 0.1979883004921]
|
||||
[#\g 0.1975473066391] [#\t 0.3015094502008]))
|
||||
|
||||
;; -------------
|
||||
(define line-length 60)
|
||||
|
||||
(define +line-size+ 60)
|
||||
;; ----------------------------------------
|
||||
|
||||
;; -------------------------------
|
||||
(require racket/require racket/require-syntax (for-syntax racket/base))
|
||||
(define-require-syntax overriding-in
|
||||
(syntax-rules () [(_ R1 R2) (combine-in R2 (subtract-in R1 R2))]))
|
||||
(require (overriding-in
|
||||
racket/flonum
|
||||
(filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||
racket/unsafe/ops))
|
||||
racket/cmdline)
|
||||
|
||||
(define (make-random seed)
|
||||
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
|
||||
(lambda (max)
|
||||
(set! last (modulo (+ ic (* last ia)) im))
|
||||
(/ (* max last) im))))
|
||||
;; ----------------------------------------
|
||||
|
||||
;; -------------------------------
|
||||
(define (repeat-fasta header N sequence)
|
||||
(define out (current-output-port))
|
||||
(define len (bytes-length sequence))
|
||||
(define buf (make-bytes (+ len line-length)))
|
||||
(bytes-copy! buf 0 sequence)
|
||||
(bytes-copy! buf len sequence 0 line-length)
|
||||
(display header out)
|
||||
(let loop ([n N] [start 0])
|
||||
(when (fx> n 0)
|
||||
(let ([end (fx+ start (fxmin n line-length))])
|
||||
(write-bytes buf out start end)
|
||||
(newline)
|
||||
(loop (fx- n line-length) (if (fx> end len) (fx- end len) end))))))
|
||||
|
||||
(define (make-cumulative-table frequency-table)
|
||||
(let ([cumulative 0.0])
|
||||
(for/list ([x frequency-table])
|
||||
(set! cumulative (+ cumulative (cdr x)))
|
||||
(cons (char->integer (car x)) cumulative))))
|
||||
;; ----------------------------------------
|
||||
|
||||
;; -------------
|
||||
(define lookup-size 4096)
|
||||
|
||||
(define random-next (make-random 42))
|
||||
(define +segmarker+ ">")
|
||||
(define lookup-size.0 (fx->fl lookup-size))
|
||||
|
||||
;; -------------
|
||||
(define (fl->fx f) (inexact->exact (flfloor f)))
|
||||
|
||||
(define (select-random cumulative-table)
|
||||
(let ((rvalue (random-next 1.0)))
|
||||
(let select-over-threshold ([table cumulative-table])
|
||||
(if (<= rvalue (cdar table))
|
||||
(caar table)
|
||||
(select-over-threshold (cdr table))))))
|
||||
(define IA 3877)
|
||||
(define IC 29573)
|
||||
(define IM 139968)
|
||||
(define IM.0 (fx->fl IM))
|
||||
(define random-state 42)
|
||||
|
||||
;; -------------
|
||||
(define (random-next)
|
||||
(set! random-state (fxmodulo (fx+ IC (fx* random-state IA)) IM))
|
||||
(fl/ (fl* lookup-size.0 (fx->fl random-state)) IM.0))
|
||||
|
||||
(define (repeat-fasta id desc n_ sequence line-length)
|
||||
(let ((seqlen (bytes-length sequence))
|
||||
(out (current-output-port)))
|
||||
(display (string-append +segmarker+ id " " desc "\n") out)
|
||||
(let loop-o ((n n_) (k 0))
|
||||
(unless (<= n 0)
|
||||
(let ((m (min n line-length)))
|
||||
(let loop-i ((i 0) (k k))
|
||||
(if (>= i m)
|
||||
(begin
|
||||
(newline out)
|
||||
(loop-o (- n line-length) k))
|
||||
(let ([k (if (= k seqlen) 0 k)])
|
||||
(write-byte (bytes-ref sequence k) out)
|
||||
(loop-i (add1 i) (add1 k))))))))))
|
||||
(define (make-lookup-vectors frequency-table)
|
||||
(define byte-vec (make-bytes lookup-size))
|
||||
(define cumu-vec (make-flvector lookup-size))
|
||||
(define (set-range from to b)
|
||||
(for ([i (in-range (fl->fx from) (fl->fx (flround to)))])
|
||||
(bytes-set! byte-vec i b)
|
||||
(flvector-set! cumu-vec i from)))
|
||||
(let loop ([t frequency-table] [c 0.0])
|
||||
(unless (null? t)
|
||||
(let ([c1 (fl+ c (fl* lookup-size.0 (cadar t)))])
|
||||
(set-range c c1 (char->integer (caar t)))
|
||||
(loop (cdr t) c1))))
|
||||
(values byte-vec cumu-vec))
|
||||
|
||||
;; -------------
|
||||
(define (random-fasta header N table)
|
||||
(define out (current-output-port))
|
||||
(define-values (lookup-byte lookup-cumu) (make-lookup-vectors table))
|
||||
(define (n-randoms to)
|
||||
(let loop ([n 0])
|
||||
(when (fx< n to)
|
||||
(let* ([rnd (random-next)]
|
||||
[i (fl->fx rnd)]
|
||||
[i (if (fl< rnd (flvector-ref lookup-cumu i)) (fx- i 1) i)]
|
||||
[b (bytes-ref lookup-byte i)])
|
||||
(bytes-set! buf n b)
|
||||
(loop (fx+ n 1)))))
|
||||
(write-bytes buf out 0 (fx+ to 1)))
|
||||
(define buf (make-bytes (add1 line-length)))
|
||||
(define LF (char->integer #\newline))
|
||||
(bytes-set! buf line-length LF)
|
||||
(display header out)
|
||||
(for ([n (in-range (quotient N line-length))]) (n-randoms line-length))
|
||||
(let ([n (remainder N line-length)])
|
||||
(unless (zero? n) (bytes-set! buf n LF) (n-randoms n)))
|
||||
(void))
|
||||
|
||||
(define (random-fasta id desc n_ cumulative-table line-length)
|
||||
(let ((out (current-output-port)))
|
||||
(display (string-append +segmarker+ id " " desc "\n") out)
|
||||
(let loop-o ((n n_))
|
||||
(unless (<= n 0)
|
||||
(for ([i (in-range (min n line-length))])
|
||||
(write-byte (select-random cumulative-table) out))
|
||||
(newline out)
|
||||
(loop-o (- n line-length))))))
|
||||
;; ----------------------------------------
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(let ((n (command-line #:args (n) (string->number n))))
|
||||
|
||||
(repeat-fasta "ONE" "Homo sapiens alu" (* n 2) +alu+ +line-size+)
|
||||
|
||||
(random-fasta "TWO" "IUB ambiguity codes" (* n 3)
|
||||
(make-cumulative-table +iub+) +line-size+)
|
||||
|
||||
(random-fasta "THREE" "Homo sapiens frequency" (* n 5)
|
||||
(make-cumulative-table +homosapien+) +line-size+))
|
||||
(let ([n (command-line #:args (n) (string->number n))])
|
||||
(repeat-fasta ">ONE Homo sapiens alu\n" (* n 2) +alu+)
|
||||
(random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB)
|
||||
(random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN))
|
||||
|
|
|
|||
|
|
@ -1,72 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; 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)
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(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))))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(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 ((x 0) (bitnum 0) (byteacc 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 (string->number n)))
|
||||
|
|
@ -2,66 +2,55 @@
|
|||
|
||||
;; The Great Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
;;
|
||||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
|
||||
(require racket/cmdline
|
||||
racket/flonum)
|
||||
|
||||
(define +limit-sqr+ 4.0)
|
||||
(require racket/require racket/require-syntax (for-syntax racket/base))
|
||||
(define-require-syntax overriding-in
|
||||
(syntax-rules () [(_ R1 R2) (combine-in R2 (subtract-in R1 R2))]))
|
||||
(require (overriding-in
|
||||
racket/flonum
|
||||
(filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||
racket/unsafe/ops))
|
||||
racket/cmdline)
|
||||
|
||||
(define +iterations+ 50)
|
||||
(define O (current-output-port))
|
||||
|
||||
;; -------------------------------
|
||||
(define LIMIT-SQR 4.0)
|
||||
(define ITERATIONS 50)
|
||||
(define N (command-line #:args (n) (string->number n)))
|
||||
(define N.0 (fx->fl N))
|
||||
(define 2/N (fl/ 2.0 N.0))
|
||||
(define Crs
|
||||
(let ([v (make-flvector N)])
|
||||
(for ([x (in-range N)])
|
||||
(flvector-set! v x (fl- (fl/ (fx->fl (fx* 2 x)) N.0) 1.5)))
|
||||
v))
|
||||
|
||||
(define (mandelbrot x y n ci)
|
||||
(let ((cr (fl- (fl/ (fl* 2.0 (->fl x)) (->fl n)) 1.5)))
|
||||
(let loop ((i 0) (zr 0.0) (zi 0.0))
|
||||
(if (> i +iterations+)
|
||||
1
|
||||
(cond
|
||||
((fl> (fl+ (fl* zr zr) (fl* zi zi)) +limit-sqr+) 0)
|
||||
(else (loop (+ 1 i)
|
||||
(fl+ (fl- (fl* zr zr) (fl* zi zi)) cr)
|
||||
(fl+ (fl* 2.0 (fl* zr zi)) ci))))))))
|
||||
(define-syntax (let-n stx)
|
||||
(syntax-case stx ()
|
||||
[(_ N bindings E)
|
||||
(let loop ([N (syntax-e #'N)] [E #'E])
|
||||
(if (zero? N) E (loop (sub1 N) #`(let bindings #,E))))]))
|
||||
|
||||
;; -------------------------------
|
||||
(define-syntax-rule (mandelbrot Cr Ci)
|
||||
(let loop ([i 0] [Zr 0.0] [Zi 0.0])
|
||||
(cond [(fl> (fl+ (fl* Zr Zr) (fl* Zi Zi)) LIMIT-SQR) 0]
|
||||
[(fx= i ITERATIONS) 1]
|
||||
[else (let-n 5 ([Zr (fl+ (fl- (fl* Zr Zr) (fl* Zi Zi)) Cr)]
|
||||
[Zi (fl+ (fl* 2.0 (fl* Zr Zi)) Ci)])
|
||||
(loop (fx+ i 5) Zr Zi))])))
|
||||
|
||||
(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 (fl- (fl/ (fl* 2.0 (->fl y)) (->fl n)) 1.0)])
|
||||
|
||||
(let loop-x ((x 0) (bitnum 0) (byteacc 0))
|
||||
|
||||
(if (< x n)
|
||||
(let ([bitnum (+ 1 bitnum)]
|
||||
[byteacc (+ (arithmetic-shift byteacc 1)
|
||||
(mandelbrot x y n ci))])
|
||||
|
||||
(cond
|
||||
((= bitnum 8)
|
||||
(write-byte byteacc out)
|
||||
(loop-x (+ 1 x) 0 0))
|
||||
|
||||
[else (loop-x (+ 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 (string->number n)))
|
||||
(fprintf O "P4\n~a ~a\n" N N)
|
||||
(let loop-y ([y N])
|
||||
(let ([Ci (fl- (fl* 2/N (fx->fl y)) 1.0)])
|
||||
(let loop-x ([x 0] [bitnum 0] [byteacc 0])
|
||||
(if (fx< x N)
|
||||
(let* ([Cr (flvector-ref Crs x)]
|
||||
[bitnum (fx+ bitnum 1)]
|
||||
[byteacc (fx+ (fxlshift byteacc 1) (mandelbrot Cr Ci))])
|
||||
(cond [(fx= bitnum 8)
|
||||
(write-byte byteacc O)
|
||||
(loop-x (fx+ x 1) 0 0)]
|
||||
[else (loop-x (fx+ x 1) bitnum byteacc)]))
|
||||
(begin (when (fx> bitnum 0)
|
||||
(write-byte (fxlshift byteacc (fx- 8 (fxand N #x7))) O))
|
||||
(when (fx> y 1) (loop-y (fx- y 1))))))))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,9 @@
|
|||
;; http://shootout.alioth.debian.org/
|
||||
;; Based on the Perl version of the benchmark
|
||||
;; adapted with a GMP interface by Eli Barzilay
|
||||
;;
|
||||
;; Note that this was later used by several other shootout submissions
|
||||
;; without attribution.
|
||||
|
||||
(require racket/cmdline
|
||||
(for-syntax racket/base)
|
||||
|
|
|
|||
|
|
@ -3,56 +3,80 @@
|
|||
;; The Computer Language Benchmarks Game
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
(require racket/cmdline)
|
||||
|
||||
(define translation (make-vector 128))
|
||||
|
||||
(for ([from-to '([a t]
|
||||
[c g]
|
||||
[g c]
|
||||
[t a]
|
||||
[u a]
|
||||
[m k]
|
||||
[r y]
|
||||
[w w]
|
||||
[s s]
|
||||
[y R]
|
||||
[k M]
|
||||
[v b]
|
||||
[h d]
|
||||
[d h]
|
||||
[b v]
|
||||
[n n])])
|
||||
(let ([char (lambda (sym)
|
||||
(string-ref (symbol->string sym) 0))])
|
||||
(let ([from (char (car from-to))]
|
||||
[to (char->integer (char-upcase (char (cadr from-to))))])
|
||||
(vector-set! translation (char->integer from) to)
|
||||
(vector-set! translation (char->integer (char-upcase from)) to))))
|
||||
(for ([from (in-string "ACGTUMRWSYKVHDBN")]
|
||||
[to (in-string "TGCAAKYWSRMBDHVN")])
|
||||
(let ([to (char->integer to)])
|
||||
(vector-set! translation (char->integer from) to)
|
||||
(vector-set! translation (char->integer (char-downcase from)) to)))
|
||||
|
||||
(define (output lines)
|
||||
(let* ([str (apply bytes-append lines)]
|
||||
[o (current-output-port)]
|
||||
[len (bytes-length str)])
|
||||
(for ([offset (in-range 0 len 60)])
|
||||
(write-bytes str o offset (min len (+ offset 60)))
|
||||
(newline o))))
|
||||
(define I (current-input-port))
|
||||
(define O (current-output-port))
|
||||
|
||||
(let ([in (current-input-port)])
|
||||
(let loop ([accum null])
|
||||
(let ([l (read-bytes-line in)])
|
||||
(if (eof-object? l)
|
||||
(output accum)
|
||||
(cond
|
||||
[(regexp-match? #rx#"^>" l)
|
||||
(output accum)
|
||||
(printf "~a\n" l)
|
||||
(loop null)]
|
||||
[else
|
||||
(let* ([len (bytes-length l)]
|
||||
[dest (make-bytes len)])
|
||||
(for ([i (in-range len)])
|
||||
(bytes-set! dest
|
||||
(- (- len i) 1)
|
||||
(vector-ref translation (bytes-ref l i))))
|
||||
(loop (cons dest accum)))])))))
|
||||
(define marker (char->integer #\>))
|
||||
|
||||
(require racket/require (for-syntax racket/base)
|
||||
(filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
|
||||
racket/unsafe/ops))
|
||||
|
||||
(define line-length 60)
|
||||
(define buf-size (* 64 1024))
|
||||
(define out-buf ; so there's always enough room for newlines
|
||||
(make-bytes (+ buf-size 1 (quotient buf-size line-length))))
|
||||
(define LF (char->integer #\newline))
|
||||
|
||||
#|
|
||||
The basic idea is to read the input in chunks, and keep pointers to
|
||||
them, then on output process each chunk to translate and reverse it
|
||||
before dumping it out.
|
||||
|#
|
||||
|
||||
(define (output chunks)
|
||||
(let loop ([chunks chunks] [col line-length])
|
||||
(when (pair? chunks)
|
||||
(let ([chunk (car chunks)])
|
||||
(let ([start (vector-ref chunk 0)]
|
||||
[end (vector-ref chunk 1)]
|
||||
[in-buf (vector-ref chunk 2)])
|
||||
(let chunk-loop ([i end] [j 0] [col col])
|
||||
(if (fx> i start)
|
||||
(let* ([i (fx- i 1)] [b (bytes-ref in-buf i)])
|
||||
(if (fx= b LF)
|
||||
(chunk-loop i j col)
|
||||
(let ([b (vector-ref translation b)])
|
||||
(if (fx= 0 col)
|
||||
(begin (bytes-set! out-buf j LF)
|
||||
(bytes-set! out-buf (fx+ j 1) b)
|
||||
(chunk-loop i (fx+ j 2) (fx- line-length 1)))
|
||||
(begin (bytes-set! out-buf j b)
|
||||
(chunk-loop i (fx+ j 1) (fx- col 1)))))))
|
||||
(begin (write-bytes out-buf O 0 j)
|
||||
(loop (cdr chunks) col))))))))
|
||||
(newline O))
|
||||
|
||||
(define-syntax case-regexp-posns
|
||||
(syntax-rules (=> else)
|
||||
[(_ rx buf start [id B1 ...] [else B2 ...])
|
||||
(let ([m (regexp-match-positions rx buf start)])
|
||||
(if m (let ([id (car m)]) B1 ...) (begin B2 ...)))]))
|
||||
|
||||
(let ([m (regexp-match #rx"^([^\n]+)\n" I)]) (display (car m)))
|
||||
|
||||
(let loop ([buf (read-bytes buf-size I)] [start 0] [chunks '()])
|
||||
(if (eof-object? buf)
|
||||
(begin (output chunks) (void))
|
||||
(case-regexp-posns #rx">" buf start
|
||||
[p1 (output (cons (vector start (car p1) buf) chunks))
|
||||
(case-regexp-posns #rx"\n" buf (cdr p1)
|
||||
[p2 (write-bytes buf O (car p1) (cdr p2))
|
||||
(loop buf (cdr p2) '())]
|
||||
[else (write-bytes buf O (car p1))
|
||||
(let header-loop ()
|
||||
(let ([buf (read-bytes buf-size I)])
|
||||
(case-regexp-posns #rx"\n" buf 0
|
||||
[p2 (write-bytes buf O 0 (cdr p2))
|
||||
(loop buf (cdr p2) '())]
|
||||
[else (write-bytes buf O) (header-loop)])))])]
|
||||
[else (loop (read-bytes buf-size I) 0
|
||||
(cons (vector start (bytes-length buf) buf) chunks))])))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user