Programming language shootout: spectral norm

From Gambit wiki

(Difference between revisions)
Jump to: navigation, search
(Spectral norm benchmark from alioth)
(Fix totally screwed up earlier entry)
 
(One intermediate revision not shown)
Line 1: Line 1:
-
This is a Gambit implementation of the [http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all spectral-norm] benchmark of the [[Programming language shootout|Computer Language Benchmarks Game]].
+
This is a Gambit implementation of the [http://shootout.alioth.debian.org/gp4sandbox/benchmark.php?test=spectralnorm&lang=all spectral-norm] benchmark of the [[Programming language shootout|Computer Language Benchmarks Game]].
==The program==
==The program==
Line 11: Line 11:
;; derived by Michael D. Adams from the MzScheme variant
;; derived by Michael D. Adams from the MzScheme variant
 +
(declare (standard-bindings)(extended-bindings)(block)(not safe))
-
(declare (standard-bindings)(extended-bindings)(block)(fixnum)(not safe))
+
;;; Stupid boiler-plate for formatting floating point value
 +
(define (roundto digits n)
 +
  (let* ([e (expt 10 digits)]
 +
        [num (round (abs (* e (inexact->exact n))))]
 +
        [str (number->string (remainder num e))])
 +
    (string-append
 +
    (if (negative? n) "-" "")
 +
    (number->string (quotient num e))
 +
    "."
 +
    (make-string (- digits (string-length str)) #\0)
 +
    str)))
-
(define-macro (unless test . body)
+
;; -------------------------------
-
  `(if (not ,test)
+
-
      (begin
+
-
,@body)))
+
-
(define translation (make-vector 128))
+
(define (approximate n)
 +
  (let ((u (make-f64vector n 1.0))
 +
        (v (make-f64vector n 0.0)))
 +
    (do ((i 0 (fx+ i 1)))
 +
        ((fx= 10 i))
 +
      (mulAtAv n u v)
 +
      (mulAtAv n v u))
 +
    (let loop ([i 0] [vBv 0.0] [vV 0.0])
 +
      (if (fx< i n)
 +
          (loop (fx+ i 1)
 +
                (fl+ vBv (fl* (f64vector-ref u i) (f64vector-ref v i)))
 +
                (fl+ vV (fl* (f64vector-ref v i) (f64vector-ref v i))))
 +
          (flsqrt (fl/ vBv vV))))))
-
(for-each
+
;; --------------
-
(lambda (from-to)
+
-
  (let* ([char (lambda (sym) (string-ref (symbol->string sym) 0))]
+
-
          [from (char (car from-to))]
+
-
          [to (char-upcase (char (cadr from-to)))])
+
-
    (vector-set! translation (char->integer from) to)
+
-
    (vector-set! translation (char->integer (char-upcase 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]))
+
-
(define (put-whole-string s) (write-substring s 0 (string-length s)))
+
(define (A i j)
 +
  (fl/ 1.0 (fixnum->flonum (fx+ (fx+ (fxquotient (fx* (fx+ i j) (fx+ (fx+ i j) 1)) 2) i) 1))))
-
(define (output lines)
+
;; --------------
-
   (if (> (length lines) 2)
+
 
-
       (let* ([pos (- (string-length (cadr lines)) (string-length (car lines)))]
+
(define (mulAv n v av)
-
            [put-first-half
+
   (do ((i 0 (fx+ i 1)))
-
              (lambda (s i) (write-substring s 0 i))]
+
       ((fx= n i))
-
            [put-second-half
+
    (f64vector-set! av i 0.0)
-
              (lambda (s i) (write-substring s i (string-length s)))])
+
    (do ((j 0 (fx+ j 1)))
-
        (put-whole-string (car lines))
+
        ((fx= n j))
-
        (put-first-half (cadr lines) pos)
+
      (let ()
-
        (newline)
+
        (declare (inlining-limit 10000))
-
        (let loop ([l (cdr lines)])
+
        (f64vector-set! av i (fl+ (f64vector-ref av i) (fl* (A i j) (f64vector-ref v j))))))))
-
          (cond
+
 
-
          [(null? (cdr l))
+
;; --------------
-
            (put-second-half (car l) pos)
+
 
-
            (newline)]
+
(define (mulAtV n v atv)
-
          [else
+
  (do ((i 0 (fx+ i 1)))
-
            (put-second-half (car l) pos)
+
      ((= n i))
-
            (put-first-half (cadr l) pos)
+
    (f64vector-set! atv i 0.0)
-
            (newline)
+
    (do ((j 0 (fx+ j 1)))
-
            (loop (cdr l))])))))
+
        ((fx= n j))
 +
      (let ()
 +
        (declare (inlining-limit 10000))
 +
        (f64vector-set! atv i (fl+ (f64vector-ref atv i) (fl* (A j i) (f64vector-ref v j))))))))
 +
 
 +
;; --------------
 +
 
 +
(define (mulAtAv n v atav)  
 +
  (let ((u (make-f64vector n 0.0)))
 +
    (mulAv n v u)
 +
    (mulAtV n u atav)))
 +
 
 +
;; -------------------------------
(define (main . args)
(define (main . args)
-
   (let loop ([accum '()])
+
   (let ((n (if (< (length args) 1)
-
    (let ([l (read-line)])
+
              100
-
      (if (eof-object? l)
+
              (string->number (car args)))))
-
  (output accum)
+
    (display (roundto 9 (approximate n))) (newline)))
-
  (cond
+
-
  [(and (not (zero? (string-length l)))
+
-
(eqv? #\> (string-ref l 0)))
+
-
    (output accum)
+
-
    (put-whole-string l)
+
-
    (newline)
+
-
    (loop '())]
+
-
  [else
+
-
    (let* ([len (string-length l)]
+
-
  [dest (make-string len)])
+
-
      (let loop ([i 0][j (- len 1)])
+
-
(unless (= i len)
+
-
(string-set! dest j
+
-
    (vector-ref translation
+
-
(char->integer (string-ref l i))))
+
-
(loop (+ i 1) (- j 1))))
+
-
      (loop (cons dest accum)))]))))
+
-
  (force-output))
+
 +
; -------------------------------
</pre>
</pre>
==Compiling==
==Compiling==
Line 99: Line 93:
==Running==
==Running==
<pre>
<pre>
-
gsi spectral-norm
+
gsi spectral-norm 5500
</pre>
</pre>

Latest revision as of 15:21, 26 February 2008

This is a Gambit implementation of the spectral-norm benchmark of the Computer Language Benchmarks Game.

The program

#!gsi-script

;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
;; Derived by Bradley Lucier from the Ikarus variant
;; derived by Michael D. Adams from the MzScheme variant

(declare (standard-bindings)(extended-bindings)(block)(not safe))

;;; Stupid boiler-plate for formatting floating point value
(define (roundto digits n)
  (let* ([e (expt 10 digits)]
         [num (round (abs (* e (inexact->exact n))))]
         [str (number->string (remainder num e))])
    (string-append
     (if (negative? n) "-" "")
     (number->string (quotient num e))
     "."
     (make-string (- digits (string-length str)) #\0)
     str)))

;; -------------------------------

(define (approximate n)
  (let ((u (make-f64vector n 1.0))
        (v (make-f64vector n 0.0)))
    (do ((i 0 (fx+ i 1)))
        ((fx= 10 i))
      (mulAtAv n u v)
      (mulAtAv n v u))
    (let loop ([i 0] [vBv 0.0] [vV 0.0])
      (if (fx< i n)
          (loop (fx+ i 1)
                (fl+ vBv (fl* (f64vector-ref u i) (f64vector-ref v i)))
                (fl+ vV (fl* (f64vector-ref v i) (f64vector-ref v i))))
          (flsqrt (fl/ vBv vV))))))

;; --------------

(define (A i j)
  (fl/ 1.0 (fixnum->flonum (fx+ (fx+ (fxquotient (fx* (fx+ i j) (fx+ (fx+ i j) 1)) 2) i) 1))))

;; --------------

(define (mulAv n v av)
  (do ((i 0 (fx+ i 1)))
      ((fx= n i))
    (f64vector-set! av i 0.0)
    (do ((j 0 (fx+ j 1)))
        ((fx= n j))
      (let ()
        (declare (inlining-limit 10000))
        (f64vector-set! av i (fl+ (f64vector-ref av i) (fl* (A i j) (f64vector-ref v j))))))))

;; --------------

(define (mulAtV n v atv)
  (do ((i 0 (fx+ i 1)))
      ((= n i))
    (f64vector-set! atv i 0.0)
    (do ((j 0 (fx+ j 1)))
        ((fx= n j))
      (let ()
        (declare (inlining-limit 10000))
        (f64vector-set! atv i (fl+ (f64vector-ref atv i) (fl* (A j i) (f64vector-ref v j))))))))

;; --------------

(define (mulAtAv n v atav) 
  (let ((u (make-f64vector n 0.0)))
    (mulAv n v u)
    (mulAtV n u atav)))

;; -------------------------------

(define (main . args)
  (let ((n (if (< (length args) 1)
               100
               (string->number (car args)))))
    (display (roundto 9 (approximate n))) (newline)))

; -------------------------------

Compiling

gsc spectral-norm

Running

gsi spectral-norm 5500
Personal tools
documentation