;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File:         perm9.sch
; Description:  memory system benchmark using Zaks's permutation generator
; Author:       Lars Hansen, Will Clinger, and Gene Luks
; Created:      18-Mar-94
; Language:     Scheme
; Status:       Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; 940720 / lth Added some more benchmarks for the thesis paper.
; 970215 / wdc Increased problem size from 8 to 9; improved tenperm9-benchmark.
; 970531 / wdc Cleaned up for public release.
; 000820 / wdc Added the MpermNKL benchmark; revised for new run-benchmark.
; 071127 / wdc Simplified and ported for R6RS.

(import (rnrs base)
        (rnrs control)
        (rnrs io simple))

; This benchmark is in three parts.  Each tests a different aspect of
; the memory system.
;
;    storage allocation (while generating no garbage)
;    storage allocation and garbage collection at equilibrium
;    traversal of a large, linked, self-sharing structure
;
; The perm9 benchmark generates a list of all 362880 permutations of
; the first 9 integers, allocating 1349288 pairs (typically 10,794,304
; bytes), all of which goes into the generated list.  (That is, the
; perm9 benchmark generates absolutely no garbage.)  This represents
; a savings of about 63% over the storage that would be required by
; an unshared list of permutations.  The generated permutations are
; in order of a grey code that bears no obvious relationship to a
; lexicographic order.
;
; The tenperm9 benchmark repeats the perm9 benchmark 10 times, so it
; allocates and reclaims 13492880 pairs (typically 107,943,040 bytes).
; The live storage peaks at twice the storage that is allocated by the
; perm9 benchmark.  At the end of each iteration, the oldest half of
; the live storage becomes garbage.  Object lifetimes are distributed
; uniformly between 10.3 and 20.6 megabytes.
;
; The tenperm9 benchmark is the perm10:9:2:1 special case of the
; MpermNKL benchmark, which allocates a queue of size K and then
; performs M iterations of the following operation:  Fill the queue
; with individually computed copies of all permutations of a list of
; size N, and then remove the oldest L copies from the queue.  At the
; end of each iteration, the oldest L/K of the live storage becomes
; garbage, and object lifetimes are distributed uniformly between two
; volumes that depend upon N, K, and L.
;
; As a check on the result, and to preclude overly sophisticated
; compiler optimizations,  we compute the sum of the permuted
; integers over all permutations.
;
; The benchmarks are run by calling the following procedure:
;
;    (MpermNKL-benchmark M N K L)
;
; This benchmark assumes that
;
;    (RUN-BENCHMARK <string> <count> <thunk> <predicate>)
;
; reports the time required to call <thunk> the number of times
; specified by <count>, and uses <predicate> to test whether the
; result returned by <thunk> is correct.
 
; Date: Thu, 17 Mar 94 19:43:32 -0800
; From: luks@sisters.cs.uoregon.edu
; To: will
; Subject: Pancake flips
; 
; Procedure P_n generates a grey code of all perms of n elements
; on top of stack ending with reversal of starting sequence
; 
; F_n is flip of top n elements.
; 
; 
; procedure P_n
; 
;   if n>1 then
;     begin
;        repeat   P_{n-1},F_n   n-1 times;
;        P_{n-1}
;     end
; 

(define (permutations x)
  (let ((x x)
        (perms (list x)))
    (define (P n)
      (if (> n 1)
          (do ((j (- n 1) (- j 1)))
              ((zero? j)
               (P (- n 1)))
              (P (- n 1))
              (F n))))
    (define (F n)
      (set! x (revloop x n (list-tail x n)))
      (set! perms (cons x perms)))
    (define (revloop x n y)
      (if (zero? n)
          y
          (revloop (cdr x)
                   (- n 1)
                   (cons (car x) y))))
    (define (list-tail x n)
      (if (zero? n)
          x
          (list-tail (cdr x) (- n 1))))
    (P (length x))
    perms))

; Given a list of lists of numbers, returns the sum of the sums
; of those lists.
;
; for (; x != NULL; x = x->rest)
;     for (y = x->first; y != NULL; y = y->rest)
;         sum = sum + y->first;

(define (sumlists x)
  (do ((x x (cdr x))
       (sum 0 (do ((y (car x) (cdr y))
                   (sum sum (+ sum (car y))))
                  ((null? y) sum))))
      ((null? x) sum)))

(define (one..n n)
  (do ((n n (- n 1))
       (p '() (cons n p)))
      ((zero? n) p)))
   
(define (tenperm . rest)
  (let ((n (if (null? rest) 9 (car rest))))
    (MpermNKL-benchmark 10 n 2 1)))

(define (MpermNKL-benchmark m n k ell)
  (if (and (<= 0 m)
           (positive? n)
           (positive? k)
           (<= 0 ell k))
      (let ((id (string-append "perm"
                               (number->string m)
                               ":"
                               (number->string n)
                               ":"
                               (number->string k)
                               ":"
                               (number->string ell)))
            (queue (make-vector k '())))

        ; Fills queue positions [i, j).

        (define (fill-queue i j)
          (if (< i j)
              (begin (vector-set! queue i (permutations (one..n n)))
                     (fill-queue (+ i 1) j))))

        ; Removes ell elements from queue.

        (define (flush-queue)
          (let loop ((i 0))
            (if (< i k)
                (begin (vector-set! queue
                                    i
                                    (let ((j (+ i ell)))
                                      (if (< j k)
                                          (vector-ref queue j)
                                          '())))
                       (loop (+ i 1))))))

        (fill-queue 0 (- k ell))
        (run-benchmark id
                       m
                       (lambda ()
                         (fill-queue (- k ell) k)
                         (flush-queue)
                         queue)
                       (lambda (q)
                         (define (factorial n)
                           (if (= n 0)
                               1
                               (* n (factorial (- n 1)))))
                         (let ((q0 (vector-ref q 0))
                               (qi (vector-ref q (max 0 (- k ell 1)))))
                           (and (or (and (null? q0) (null? qi))
                                    (and (pair? q0)
                                         (pair? qi)
                                         (equal? (car q0) (car qi))))
                                (= (sumlists q0)
                                   (/ (* n (+ n 1) (factorial n)) 2)))))))
      (begin (display "Incorrect arguments to MpermNKL-benchmark")
             (newline))))

(define (run-benchmark . args)
  (apply run-r6rs-benchmark args))

(define (main)
  (let* ((input1 (read))
         (input2 (read))
         (input3 (read))
         (input4 (read))
         (output (read))
         (s4 (number->string input4))
         (s3 (number->string input3))
         (s2 (number->string input2))
         (s1 (number->string input1))
         (name "perm"))
    (MpermNKL-benchmark (hide input1 input1)
                        (hide input1 input2)
                        (hide input1 input3)
                        (hide input1 input4))))