108 lines
3.2 KiB
Scheme
108 lines
3.2 KiB
Scheme
;; The Great Computer Language Shootout
|
|
;; http://shootout.alioth.debian.org/
|
|
;;
|
|
;; fasta - benchmark
|
|
;;
|
|
;; Derived from the Chicken variant, which was
|
|
;; Contributed by Anthony Borla
|
|
|
|
#lang scheme/base
|
|
(require scheme/cmdline)
|
|
|
|
(define +alu+
|
|
(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 +homosapien+
|
|
(list
|
|
'(#\a . 0.3029549426680) '(#\c . 0.1979883004921)
|
|
'(#\g . 0.1975473066391) '(#\t . 0.3015094502008)))
|
|
|
|
;; -------------
|
|
|
|
(define +line-size+ 60)
|
|
|
|
;; -------------------------------
|
|
|
|
(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 (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 random-next (make-random 42))
|
|
(define +segmarker+ ">")
|
|
|
|
;; -------------
|
|
|
|
(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 (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 (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+))
|