94 lines
3.6 KiB
Scheme
94 lines
3.6 KiB
Scheme
;; The Computer Language Shootout
|
|
;; http://shootout.alioth.debian.org/
|
|
;; Based on the Perl version of the benchmark
|
|
;; adapted with a GMP interface by Eli Barzilay
|
|
|
|
#lang scheme/base
|
|
(require scheme/cmdline)
|
|
(require (for-syntax scheme/base))
|
|
(require scheme/foreign) (unsafe!)
|
|
|
|
;; quick libgmp interface, limited to what we need below
|
|
(define libgmp (ffi-lib "libgmp"))
|
|
(define-syntax-rule (defgmp op type ...)
|
|
(define op (get-ffi-obj (format "__gmpz_~a" 'op) libgmp (_fun type ...))))
|
|
(define-cstruct _mpz ([alloc _int] [size _int] [limbs _pointer]))
|
|
(defgmp init_set_ui _mpz-pointer _ulong -> _void)
|
|
(defgmp set_ui _mpz-pointer _ulong -> _void)
|
|
(defgmp get_ui _mpz-pointer -> _ulong)
|
|
(defgmp add _mpz-pointer _mpz-pointer _mpz-pointer -> _void)
|
|
(defgmp mul _mpz-pointer _mpz-pointer _mpz-pointer -> _void)
|
|
(defgmp mul_ui _mpz-pointer _mpz-pointer _long -> _void)
|
|
(defgmp addmul _mpz-pointer _mpz-pointer _mpz-pointer -> _void)
|
|
(defgmp addmul_ui _mpz-pointer _mpz-pointer _ulong -> _void)
|
|
(defgmp submul_ui _mpz-pointer _mpz-pointer _ulong -> _void)
|
|
(defgmp tdiv_q _mpz-pointer _mpz-pointer _mpz-pointer -> _void)
|
|
(defgmp cmp _mpz-pointer _mpz-pointer -> _int)
|
|
(define (make-ui n) (let ([i (make-mpz 0 0 #f)]) (init_set_ui i n) i))
|
|
;; "fancy" parser, for fun (only for the limited subset we use)
|
|
(define-syntax (gmp stx)
|
|
(define (sym=? x y)
|
|
(eq? (if (syntax? x) (syntax-e x) x) (if (syntax? y) (syntax-e y) y)))
|
|
(define (_? stx)
|
|
(and (identifier? stx)
|
|
(regexp-match? #rx"^_" (symbol->string (syntax-e stx)))))
|
|
(define (split xs)
|
|
(let loop ([xs xs] [cur '()] [r '()])
|
|
(define (add) (cons (reverse cur) r))
|
|
(cond [(null? xs) (reverse (add))]
|
|
[(syntax-case (car xs) (unquote) [,x #'x] [else #f])
|
|
=> (lambda (x) (loop (cdr xs) (list x) (add)))]
|
|
[else (loop (cdr xs) (cons (car xs) cur) r)])))
|
|
(define (translate expr)
|
|
(syntax-case* expr (= += -= + * / < >) sym=?
|
|
[(x = y + z) #'(add x y z)]
|
|
[(x = y * z) #`(#,(if (_? #'z) #'mul #'mul_ui) x y z)]
|
|
[(x += y * z) #`(#,(if (_? #'z) #'addmul #'addmul_ui) x y z)]
|
|
[(x -= y * z) #`(#,(if (_? #'z) #'submul #'submul_ui) x y z)]
|
|
[(x = y / z) #'(tdiv_q x y z)]
|
|
[(x < y) #'(< (cmp x y) 0)]
|
|
[(x > y) #'(> (cmp x y) 0)]
|
|
[(get x) #'(get_ui x)]))
|
|
(syntax-case stx ()
|
|
[(_ x ...) #`(begin #,@(map translate (split (syntax->list #'(x ...)))))]))
|
|
|
|
;; the actual code
|
|
|
|
(define (digits n)
|
|
(define i 0)
|
|
(define _x0 (make-ui 1))
|
|
(define _x1 (make-ui 0))
|
|
(define _x2 (make-ui 1))
|
|
(define _r (make-ui 0))
|
|
|
|
(define (extract-digit n)
|
|
(gmp _r = _x0 * n, _r = _r + _x1, _r = _r / _x2, get _r))
|
|
|
|
(let loop ([k 0])
|
|
|
|
(define-syntax-rule (compose1!+loop)
|
|
(let* ([k (add1 k)] [y2 (add1 (* k 2))])
|
|
(gmp _x1 = _x1 * y2, _x1 += _x0 * (* y2 2), _x0 = _x0 * k,_x2 = _x2 * y2)
|
|
(loop k)))
|
|
(define-syntax-rule (compose2! d)
|
|
(begin (gmp _x1 -= _x2 * d, _x1 = _x1 * 10, _x0 = _x0 * 10)
|
|
(loop k)))
|
|
|
|
(if (gmp _x0 > _x1)
|
|
(compose1!+loop)
|
|
(let ([d (extract-digit 3)])
|
|
(if (not (= d (extract-digit 4)))
|
|
(compose1!+loop)
|
|
(begin (display d)
|
|
(set! i (add1 i))
|
|
(let ([m (modulo i 10)])
|
|
(when (zero? m) (printf "\t:~a\n" i))
|
|
(if (< i n)
|
|
(compose2! d)
|
|
(unless (zero? m)
|
|
(printf "~a\t:~a\n"
|
|
(make-string (- 10 m) #\space)
|
|
n))))))))))
|
|
|
|
(digits (command-line #:args (n) (string->number n)))
|