Skip to content

Commit ac6ffc4

Browse files
hanabi1224hanabi1224
committed
racket
1 parent 5b43982 commit ac6ffc4

File tree

9 files changed

+615
-0
lines changed

9 files changed

+615
-0
lines changed

‎.github/workflows/bench.yml‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ jobs:
3535
nim,
3636
ocaml,
3737
python,
38+
racket,
3839
ruby,
3940
rust,
4041
swift,
@@ -69,6 +70,12 @@ jobs:
6970
if: matrix.lang == 'c'
7071
run: |
7172
sudo apt-get install -y libapr1 libapr1-dev
73+
- name: Install racket
74+
if: matrix.lang == 'racket'
75+
run: |
76+
sudo add-apt-repository ppa:plt/racket
77+
sudo apt-get install -y racket
78+
racket --version
7279
- name: Install fortran
7380
if: matrix.lang == 'fortran'
7481
run: |

‎bench/algorithm/binarytrees/4.rkt‎

Lines changed: 105 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,105 @@
1+
#lang racket/base
2+
3+
;;; The Computer Language Benchmarks Game
4+
;;; https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
5+
6+
;;; Derived from the Chicken variant by Sven Hartrumpf
7+
;;; contributed by Matthew Flatt
8+
;;; *reset*
9+
;;; improved by Phil Nguyen:
10+
;;; - use `cons` instead of struct `node`
11+
;;; - remove the confirmed unneccessary field `val`
12+
;;; - accumulate part of `check`
13+
;;; - use unsafe accessors and fixnum arithmetics
14+
;;; - clean up with `define` instead of nested `let`
15+
;;; - clean up with `for/sum` instead of `for/fold`
16+
;;; Parallelized by Gustavo Massaccesi, 2019
17+
18+
(require racket/cmdline)
19+
20+
#;(struct node (left right))
21+
(define node cons)
22+
(require racket/place
23+
(rename-in racket/unsafe/ops
24+
[unsafe-car node-left]
25+
[unsafe-cdr node-right]
26+
[unsafe-fx+ +]
27+
[unsafe-fx- -]
28+
[unsafe-fx= =]))
29+
30+
(define (make d)
31+
(if (= d 0)
32+
(node #f #f)
33+
(let ([d2 (- d 1)])
34+
(node (make d2) (make d2)))))
35+
36+
(define (check t)
37+
(let sum ([t t] [acc 0])
38+
(cond [(node-left t) (sum (node-right t) (sum (node-left t) (+ 1 acc)))]
39+
[else (+ 1 acc)])))
40+
41+
(define (make-checking-place)
42+
(place ch
43+
(let loop ()
44+
(define iterations (place-channel-get ch))
45+
(define d (place-channel-get ch))
46+
(define out (for/sum ([_ (in-range iterations)])
47+
(check (make d))))
48+
(place-channel-put ch out)
49+
(loop))))
50+
51+
(module+ main
52+
(define (main n)
53+
(define min-depth 4)
54+
(define max-depth (max (+ min-depth 2) n))
55+
(define stretch-depth (+ max-depth 1))
56+
57+
;Select how to split the task
58+
;when n=21, we get:
59+
;steps = '(2 2 2 2 1)
60+
;interval = '((4 6) (8 10) (12 14) (16 18) (20))
61+
; the first is calculated in the main program, and the rest in places
62+
(define total (+ (quotient (- max-depth min-depth) 2) 1))
63+
(define cpu 4)
64+
(define steps (append (for/list ([_ (in-range cpu)])
65+
(quotient total cpu))
66+
(list (remainder total cpu))))
67+
(define intervals (let-values ([(rev-out total)
68+
(for/fold ([rev-out '()] [total min-depth]) ([v (in-list steps)])
69+
(define next (+ total (* v 2)))
70+
(values (cons (for/list ([ i (in-range total next 2)]) i)
71+
rev-out)
72+
next))])
73+
(reverse rev-out)))
74+
75+
; main part of the program
76+
(printf "stretch tree of depth ~a\t check: ~a\n" stretch-depth (check (make stretch-depth)))
77+
(define long-lived-tree (make max-depth))
78+
(define chanells (for/list ([c (in-list (cdr intervals))])
79+
(define ch (make-checking-place))
80+
(for/list ([d (in-list c)])
81+
(define iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth)))
82+
(place-channel-put ch iterations)
83+
(place-channel-put ch d)
84+
(list iterations d ch))))
85+
(define chanellsx (cons (let ([c (car intervals)])
86+
(for/list ([d (in-list c)])
87+
(define iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth)))
88+
(define r (for/sum ([_ (in-range iterations)])
89+
(check (make d))))
90+
(list iterations d r)))
91+
chanells))
92+
(for ([vs (in-list chanellsx)])
93+
(for ([v (in-list vs)])
94+
(printf "~a\t trees of depth ~a\t check: ~a\n"
95+
(car v)
96+
(cadr v)
97+
(let ([r (caddr v)])
98+
(if (number? r)
99+
r
100+
(place-channel-get r))))))
101+
(printf "long lived tree of depth ~a\t check: ~a\n" max-depth (check long-lived-tree)))
102+
103+
(command-line #:args (n)
104+
(main (string->number n)))
105+
)

‎bench/algorithm/fasta/3.rkt‎

Lines changed: 121 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,121 @@
1+
#lang racket/base
2+
3+
;;; The Computer Language Benchmarks Game
4+
;;; https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
5+
6+
;;; Derived from C version by Joern Inge Vestgaarden
7+
;;; and Jorge Peixoto de Morais Neto
8+
;;; Contributed by Sam Tobin-Hochstadt
9+
10+
(require racket/cmdline racket/require (for-syntax racket/base) (only-in racket/flonum for/flvector)
11+
(filtered-in (λ (name) (regexp-replace #rx"unsafe-" name ""))
12+
racket/unsafe/ops))
13+
14+
(define +alu+
15+
(bytes-append #"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
16+
#"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
17+
#"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
18+
#"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
19+
#"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
20+
#"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
21+
#"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
22+
23+
(define (build-table t)
24+
(cons (apply bytes (map (compose char->integer car) t))
25+
(for/flvector ([i t]) (cdr i))))
26+
27+
(define IUB
28+
(build-table
29+
'([#\a . 0.27] [#\c . 0.12] [#\g . 0.12] [#\t . 0.27] [#\B . 0.02]
30+
[#\D . 0.02] [#\H . 0.02] [#\K . 0.02] [#\M . 0.02] [#\N . 0.02]
31+
[#\R . 0.02] [#\S . 0.02] [#\V . 0.02] [#\W . 0.02] [#\Y . 0.02])))
32+
33+
(define HOMOSAPIEN
34+
(build-table '([#\a . 0.3029549426680] [#\c . 0.1979883004921]
35+
[#\g . 0.1975473066391] [#\t . 0.3015094502008])))
36+
37+
;; -------------
38+
39+
(define line-length 60)
40+
41+
(define IA 3877)
42+
(define IC 29573)
43+
(define IM 139968)
44+
45+
;; -------------------------------
46+
47+
(define LAST 42)
48+
49+
;; -------------------------------
50+
51+
(define (make-cumulative-table frequency-table)
52+
(define bs (car frequency-table))
53+
(define ps (cdr frequency-table))
54+
(define len (bytes-length bs))
55+
(let loop ([i 0] [cum 0.0])
56+
(when (fx< i len)
57+
(define this (flvector-ref ps i))
58+
(define new (fl+ this cum))
59+
(flvector-set! ps i new)
60+
(loop (fx+ 1 i) new))))
61+
62+
;; -------------
63+
64+
(define (random-next max)
65+
(set! LAST (fxmodulo (fx+ IC (fx* LAST IA)) IM))
66+
(fl/ (fl* max (fx->fl LAST)) (fx->fl IM)))
67+
68+
;; -------------
69+
70+
(define (repeat-fasta s count)
71+
(define out (current-output-port))
72+
(define len (bytes-length s))
73+
(define s2 (make-bytes (fx+ len line-length)))
74+
(bytes-copy! s2 0 s 0 len)
75+
(bytes-copy! s2 len s 0 line-length)
76+
(let loop ([count count] [pos 0])
77+
(define line (fxmin line-length count))
78+
(write-bytes s2 out pos (fx+ pos line))
79+
(newline out)
80+
(define count* (fx- count line))
81+
(when (fx> count* 0)
82+
(define pos* (fx+ pos line))
83+
(loop count* (if (fx>= pos* len) (fx- pos* len) pos*)))))
84+
85+
86+
;; -------------
87+
88+
(define-syntax-rule (random-fasta genelist cnt)
89+
(let ()
90+
(define out (current-output-port))
91+
(define ps (cdr genelist))
92+
(define cs (car genelist))
93+
(let loop ([count cnt])
94+
(define line (fxmin line-length count))
95+
(define buf (make-bytes (fx+ 1 line-length)))
96+
(let inner ([pos 0])
97+
(define r (random-next 1.0))
98+
(define i (let wh ([i 0]) (if (fl< (flvector-ref ps i) r) (wh (fx+ i 1)) i)))
99+
(bytes-set! buf pos (bytes-ref cs i))
100+
(define pos+ (fx+ pos 1))
101+
(when (fx< pos+ line)
102+
(inner pos+)))
103+
(bytes-set! buf line (char->integer #\newline))
104+
(write-bytes buf out 0 (fx+ line 1))
105+
(define count- (fx- count line))
106+
(when (fx> count- 0)
107+
(loop count-)))))
108+
109+
;; -------------------------------
110+
111+
(define n (command-line #:args (n) (string->number n)))
112+
113+
(make-cumulative-table IUB)
114+
(make-cumulative-table HOMOSAPIEN)
115+
116+
(display ">ONE Homo sapiens alu\n")
117+
(repeat-fasta +alu+ (* n 2))
118+
(display ">TWO IUB ambiguity codes\n")
119+
(random-fasta IUB (* n 3))
120+
(display ">THREE Homo sapiens frequency\n")
121+
(random-fasta HOMOSAPIEN (* n 5))

‎bench/algorithm/helloworld/1.rkt‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
#lang racket/base
2+
3+
(require racket/cmdline)
4+
5+
(define (hello n)
6+
(printf (string-append "Hello world " n "!"))
7+
)
8+
9+
(hello (command-line #:args (n) n))

‎bench/algorithm/mandelbrot/4.rkt‎

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,60 @@
1+
#lang racket/base
2+
3+
;; The Computer Language Benchmarks Game
4+
;; https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
5+
;; contributed by Eli Barzilay
6+
;; parallelized by Sam Tobin-Hochstadt
7+
8+
(require racket/require (for-syntax racket/base) racket/future
9+
(filtered-in (lambda (n) (regexp-replace #rx"unsafe-" n ""))
10+
racket/unsafe/ops)
11+
(only-in racket/flonum make-flvector)
12+
racket/cmdline)
13+
14+
(define LIMIT-SQR 4.0)
15+
(define ITERATIONS 50)
16+
(define N (command-line #:args (n) (string->number n)))
17+
(define N.0 (fx->fl N))
18+
(define 2/N (fl/ 2.0 N.0))
19+
(define Crs
20+
(let ([v (make-flvector N)])
21+
(for ([x (in-range N)])
22+
(flvector-set! v x (fl- (fl/ (fx->fl (fx* 2 x)) N.0) 1.5)))
23+
v))
24+
25+
(define bpr (ceiling (/ N 8)))
26+
(define bitmap (make-bytes (* N bpr)))
27+
28+
(define-syntax (let-n s)
29+
(syntax-case s ()
30+
[(_ N bs E)
31+
(for/fold ([E #'E]) ([_ (syntax-e #'N)]) #`(let bs #,E))]))
32+
33+
(define-syntax-rule (M Cr Ci)
34+
(let loop ([i 0] [Zr 0.0] [Zi 0.0])
35+
(cond [(fl> (fl+ (fl* Zr Zr) (fl* Zi Zi)) LIMIT-SQR) 0]
36+
[(fx= i ITERATIONS) 1]
37+
[else (let-n 5 ([Zr (fl+ (fl- (fl* Zr Zr) (fl* Zi Zi)) Cr)]
38+
[Zi (fl+ (fl* 2.0 (fl* Zr Zi)) Ci)])
39+
(loop (fx+ i 5) Zr Zi))])))
40+
41+
(printf "P4\n~a ~a\n" N N)
42+
(for-each
43+
touch
44+
(for/list ([y (in-range N 0 -1)])
45+
(future
46+
(λ ()
47+
(define Ci (fl- (fl* 2/N (fx->fl y)) 1.0))
48+
(let loop-x ([x 0] [bitnum 0] [byteacc 0] [aindex (fx* bpr (fx- N y))])
49+
(cond [(fx< x N)
50+
(define Cr (flvector-ref Crs x))
51+
(define byteacc* (fx+ (fxlshift byteacc 1) (M Cr Ci)))
52+
(cond [(fx= bitnum 7)
53+
(bytes-set! bitmap aindex byteacc*)
54+
(loop-x (fx+ x 1) 0 0 (fx+ aindex 1))]
55+
[else (loop-x (fx+ x 1) (fx+ bitnum 1) byteacc* aindex)])]
56+
[else
57+
(when (fx> bitnum 0)
58+
(bytes-set! bitmap aindex
59+
(fxlshift byteacc (fx- 8 (fxand N #x7)))))]))))))
60+
(void (write-bytes bitmap))

0 commit comments

Comments
 (0)