Programming language shootout: fannkuch

From Gambit wiki

Revision as of 17:31, 22 February 2008 by Bjlucier (Talk | contribs)
Jump to: navigation, search

This is a Gambit implementation of the fannkuch 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 O'Caml variant, by Christophe Papazian

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

(define (write-permutation perm)
  (for-each write (vector->list perm))
  (newline))

;; Find first value where r[i] != i
;; and increment (mod j+2) all values up to that (i.e. set them to j+1)
;; returning i+2
(define (choose-next r)
  (let loop ((i 0))
    (if (eq? (vector-ref r i) i)
        (loop (fx+ 1 i))
        (let loop ((j 0))
          (if (eq? j i)
              (begin (vector-set! r j (fxremainder (fx+ 1 (vector-ref r j)) (fx+ j 2)))
                     (fx+ j 2))
              (begin (vector-set! r j (fx+ j 1))
                     (loop (fx+ j 1))))))))

;; Count number of "pancake flips" it takes to get p[0]=1
;; Does not side-effect p, uses s as a temporary
;; "Pancake flip" = Reverse first p[0]-1 elements
(define (count-flips n p s)
  ;; Check if all p[i] != i+1
  (define (check i)
    (or (eq? i n)
        (and (not (eq? (vector-ref p i) (fx+ i 1)))
             (check (fx+ i 1)))))
  ;; If all p[i] != i+1
  (if (check 0)
      (begin
        ;; set all s[i] = p[i]
        (do ((i 0 (fx+ i 1)))
            ((eq? i n))
          (vector-set! s i (vector-ref p i)))
        ;; keep reversing the first s[0]-1 values of s until s[0] = 1
        ;; and return number of flippings
        (do ((flips 0 (fx+ flips 1))
             (s0 (fx- (vector-ref s 0) 1)
                 (fx- (vector-ref s 0) 1)))
            ((eq? s0 0)
             flips)
          ;; reverse the first s[0]-1 values of s
          (do ((i 0  (fx+ i 1))
               (j s0 (fx- j 1)))
              ((fx>= i j))
            (let ((tmp (vector-ref s i)))
              (vector-set! s i (vector-ref s j))
              (vector-set! s j tmp)))))
      0))

;; Build a new permutation by "braiding":
;;  For every i in [1..n-1]:
;;    Shift each p[j<i] down by one
;;    and put p[0] at p[i]
(define (braid n p)
  ;; For every i in [1..n-1]
  (do ((i 1 (fx+ i 1)))
      ((eq? i n))
    ;; Shift each p[j] down by one
    ;; and put p[0] at p[i]
    (let ((t (vector-ref p 0)))
      (do ((j 0 (fx+ j 1)))
          ((eq? j i))
        (vector-set! p j (vector-ref p (fx+ j 1))))
      (vector-set! p i t))))

(define (fannkuch n r p s m z)
  (let ((i (choose-next r)))
    (if (fx> i n)
        m
        (begin
          (if (fx> z 0) (write-permutation p))
          (braid i p)
          (fannkuch n r p s (max m (count-flips n p s)) (fx- z 1))))))

(define (main . args)
  (let ((n (string->number (car args))))
    (let ((r (make-vector n))
          (p (make-vector n))
          (s (make-vector n 0)))

      ;; Init r and p to [1,...,n]
      (do ((i 0 (fx+ 1 i)))
          ((eq? i n))
        (vector-set! r i (fx+ i 1))
        (vector-set! p i (fx+ i 1)))

      ;; No need to init s; it is only used as a temporary

      (let ((x (fannkuch n r p s 0 30)))
        (display "Pfannkuchen(")(display n)(display ") = ")
        (display x)(newline)))))

Compiling

gsc fannkuch

Running

gsi fannkuch n
Personal tools
documentation