67 lines
2.0 KiB
Scheme
67 lines
2.0 KiB
Scheme
#!/usr/bin/mzscheme -qu
|
|
;;; The Great Computer Language Shootout
|
|
;;; http://shootout.alioth.debian.org/
|
|
;;
|
|
;; Adapted from CMUCL code by Dima Dorfman; bit-vector stuff by Alex Shinn;
|
|
;; cobbled together by felix, converted to MzScheme by Brent Fulgham
|
|
;; Note: Requires MzScheme 299+
|
|
|
|
(module nsievebits mzscheme
|
|
|
|
(define (make-bit-vector size)
|
|
(let* ((len (quotient (+ size 7) 8))
|
|
(res (make-bytes len #b11111111)))
|
|
(let ((off (remainder size 8)))
|
|
(unless (zero? off)
|
|
(bytes-set! res (- len 1) (- (arithmetic-shift 1 off) 1))))
|
|
res))
|
|
|
|
(define (bit-vector-ref vec i)
|
|
(let ((byte (arithmetic-shift i -3))
|
|
(off (bitwise-and i #x7)))
|
|
(and (< byte (bytes-length vec))
|
|
(not (zero? (bitwise-and (bytes-ref vec byte)
|
|
(arithmetic-shift 1 off)))))))
|
|
|
|
(define (bit-vector-set! vec i x)
|
|
(let ((byte (arithmetic-shift i -3))
|
|
(off (bitwise-and i #x7)))
|
|
(let ((val (bytes-ref vec byte))
|
|
(mask (arithmetic-shift 1 off)))
|
|
(bytes-set! vec
|
|
byte
|
|
(if x
|
|
(bitwise-ior val mask)
|
|
(bitwise-and val (bitwise-not mask)))))))
|
|
|
|
(define (nsievebits m)
|
|
(let ((a (make-bit-vector m)))
|
|
(define (clear i)
|
|
(do ([j (+ i i) (+ j i)])
|
|
((>= j m))
|
|
(bit-vector-set! a j #f) ) )
|
|
(let ([c 0])
|
|
(do ([i 2 (add1 i)])
|
|
((>= i m) c)
|
|
(when (bit-vector-ref a i)
|
|
(clear i)
|
|
(set! c (add1 c)) ) ) ) ) )
|
|
|
|
(define (string-pad s n)
|
|
(string-append (make-string (- n (string-length s)) #\space)
|
|
s))
|
|
|
|
(define (test n)
|
|
(let ((m (* 10000 (arithmetic-shift 1 n))))
|
|
(printf "Primes up to ~a ~a~%"
|
|
(string-pad (number->string m) 8)
|
|
(string-pad (number->string (nsievebits m)) 8))))
|
|
|
|
(define (main args)
|
|
(let ([n (string->number (vector-ref args 0))])
|
|
(when (>= n 0) (test n))
|
|
(when (>= n 1) (test (- n 1)))
|
|
(when (>= n 2) (test (- n 2)))))
|
|
|
|
(main (current-command-line-arguments)))
|