cyclone/examples/threading/benchmarks/paraffins.scm

;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.

(import (scheme base) (scheme read) (scheme write) (scheme time) (srfi 18))

;;; This benchmark uses the following R6RS procedures.

(define (div x y)
  (quotient x y))

;;; End of (faked) R6RS procedures.

(define (gen n)
  (let* ((n/2 (div n 2))
         (radicals (make-vector (+ n/2 1) '(H))))

    (define (rads-of-size n)
      (let loop1 ((ps
                   (three-partitions (- n 1)))
                  (lst
                   '()))
        (if (null? ps)
            lst
            (let* ((p (car ps))
                   (nc1 (vector-ref p 0))
                   (nc2 (vector-ref p 1))
                   (nc3 (vector-ref p 2)))
              (let loop2 ((rads1
                           (vector-ref radicals nc1))
                          (lst
                           (loop1 (cdr ps)
                                  lst)))
                (if (null? rads1)
                    lst
                    (let loop3 ((rads2
                                 (if (= nc1 nc2)
                                     rads1
                                     (vector-ref radicals nc2)))
                                (lst
                                 (loop2 (cdr rads1)
                                        lst)))
                      (if (null? rads2)
                          lst
                          (let loop4 ((rads3
                                       (if (= nc2 nc3)
                                           rads2
                                           (vector-ref radicals nc3)))
                                      (lst
                                       (loop3 (cdr rads2)
                                              lst)))
                            (if (null? rads3)
                                lst
                                (cons (vector 'C
                                              (car rads1)
                                              (car rads2)
                                              (car rads3))
                                      (loop4 (cdr rads3)
                                             lst))))))))))))

    (define (bcp-generator j)
      (if (odd? j)
          '()
          (let loop1 ((rads1
                       (vector-ref radicals (div j 2)))
                      (lst
                       '()))
            (if (null? rads1)
                lst
                (let loop2 ((rads2
                             rads1)
                            (lst
                             (loop1 (cdr rads1)
                                    lst)))
                  (if (null? rads2)
                      lst
                      (cons (vector 'BCP
                                    (car rads1)
                                    (car rads2))
                            (loop2 (cdr rads2)
                                   lst))))))))

    (define (ccp-generator j)
      (let loop1 ((ps
                   (four-partitions (- j 1)))
                  (lst
                   '()))
        (if (null? ps)
            lst
            (let* ((p (car ps))
                   (nc1 (vector-ref p 0))
                   (nc2 (vector-ref p 1))
                   (nc3 (vector-ref p 2))
                   (nc4 (vector-ref p 3)))
              (let loop2 ((rads1
                           (vector-ref radicals nc1))
                          (lst
                           (loop1 (cdr ps)
                                  lst)))
                (if (null? rads1)
                    lst
                    (let loop3 ((rads2
                                 (if (= nc1 nc2)
                                     rads1
                                     (vector-ref radicals nc2)))
                                (lst
                                 (loop2 (cdr rads1)
                                        lst)))
                      (if (null? rads2)
                          lst
                          (let loop4 ((rads3
                                       (if (= nc2 nc3)
                                           rads2
                                           (vector-ref radicals nc3)))
                                      (lst
                                       (loop3 (cdr rads2)
                                              lst)))
                            (if (null? rads3)
                                lst
                                (let loop5 ((rads4
                                             (if (= nc3 nc4)
                                                 rads3
                                                 (vector-ref radicals nc4)))
                                            (lst
                                             (loop4 (cdr rads3)
                                                    lst)))
                                  (if (null? rads4)
                                      lst
                                      (cons (vector 'CCP
                                                    (car rads1)
                                                    (car rads2)
                                                    (car rads3)
                                                    (car rads4))
                                            (loop5 (cdr rads4)
                                                   lst))))))))))))))

    (let loop ((i 1))
      (if (> i n/2)
          (vector (bcp-generator n)
                  (ccp-generator n))
          (begin
            (vector-set! radicals i (rads-of-size i))
            (loop (+ i 1)))))))

(define (three-partitions m)
  (let loop1 ((lst '())
              (nc1 (div m 3)))
    (if (< nc1 0)
        lst
        (let loop2 ((lst lst)
                    (nc2 (div (- m nc1) 2)))
          (if (< nc2 nc1)
              (loop1 lst
                     (- nc1 1))
              (loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst)
                     (- nc2 1)))))))

(define (four-partitions m)
  (let loop1 ((lst '())
              (nc1 (div m 4)))
    (if (< nc1 0)
        lst
        (let loop2 ((lst lst)
                    (nc2 (div (- m nc1) 3)))
          (if (< nc2 nc1)
              (loop1 lst
                     (- nc1 1))
              (let ((start (max nc2 (- (div (+ m 1) 2) (+ nc1 nc2)))))
                (let loop3 ((lst lst)
                            (nc3 (div (- m (+ nc1 nc2)) 2)))
                  (if (< nc3 start)
                      (loop2 lst (- nc2 1))
                      (loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst)
                             (- nc3 1))))))))))

(define (nb n)
  (let ((x (gen n)))
    (+ (length (vector-ref x 0))
       (length (vector-ref x 1)))))

(define (main)
  (let* ((count (read))
         (input1 (read))
         (output (read))
         (s2 (number->string count))
         (s1 (number->string input1))
         (name "paraffins"))
    (run-r7rs-benchmark
     (string-append name ":" s1 ":" s2)
     count
     (lambda () 
       #;(thread-start!
         (make-thread
           (lambda ()
             (nb (hide count input1)))))
       (thread-start!
         (make-thread
           (lambda ()
             (nb (hide count input1)))))
       (nb (hide count input1))
     )
     (lambda (result) (= result output)))))

;;; The following code is appended to all benchmarks.

;;; Given an integer and an object, returns the object
;;; without making it too easy for compilers to tell
;;; the object will be returned.

(define (hide r x)
  (call-with-values
   (lambda ()
     (values (vector values (lambda (x) x))
             (if (< r 100) 0 1)))
   (lambda (v i)
     ((vector-ref v i) x))))

;;; Given the name of a benchmark,
;;; the number of times it should be executed,
;;; a thunk that runs the benchmark once,
;;; and a unary predicate that is true of the
;;; correct results the thunk may return,
;;; runs the benchmark for the number of specified iterations.

(define (run-r7rs-benchmark name count thunk ok?)

  ;; Rounds to thousandths.
  (define (rounded x)
    (/ (round (* 1000 x)) 1000))

  (display "Running ")
  (display name)
  (newline)
  (flush-output-port (current-output-port))
  (let* ((j/s (jiffies-per-second))
         (t0 (current-second))
         (j0 (current-jiffy)))
    (let loop ((i 0)
               (result #f))
      (cond ((< i count)
             (loop (+ i 1) (thunk)))
            ((ok? result)
             (let* ((j1 (current-jiffy))
                    (t1 (current-second))
                    (jifs (- j1 j0))
                    (secs (inexact (/ jifs j/s)))
                    (secs2 (rounded (- t1 t0))))
               (display "Elapsed time: ")
               (write secs)
               (display " seconds (")
               (write secs2)
               (display ") for ")
               (display name)
               (newline)
               (display "+!CSVLINE!+")
               (display (this-scheme-implementation-name))
               (display ",")
               (display name)
               (display ",")
               (display secs)
               (newline)
               (flush-output-port (current-output-port)))
             result)
            (else
             (display "ERROR: returned incorrect result: ")
             (write result)
             (newline)
             (flush-output-port (current-output-port))
             result)))))
(define (this-scheme-implementation-name)
  (string-append "cyclone-" (Cyc-version)))
(main)