;;;
;;; Time-stamp: <2009-05-06 12:13:10 noel>
;;;
;;; Copyright (C) by Noel Welsh.
;;;

;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.

;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <[email protected]>
;;
;;
;; Commentary:

#lang scheme/base

(require
 (planet schematics/schemeunit:3/base)
 (planet schematics/schemeunit:3/test)
 (planet williams/science:3/science)
 "benchmark-log.ss")

(require (for-syntax
          scheme/base
          (lib "main-collects.ss" "setup")))

(provide
 benchmark-time*
 benchmark-time

 faster*?
 faster?
 
 as-fast*?
 as-fast?

 check-faster
 check-as-fast

 check-faster-times
 
 benchmark-case
 benchmark-test-case-log-file
 this-expression-benchmark-log-file
 )

;;
;; Record run times
;;

;; cpu-time : (() -> any) -> integer
(define (cpu-time thunk)
  (let-values (([result cpu real gc] (time-apply thunk null)))
    cpu))

;; (() -> any) -> (vectorof integer)
(define (benchmark-time* thunk)
  (collect-garbage)
  (list->vector
   (for/list ([i (in-range 10)])
     (begin0 (cpu-time thunk)
       (collect-garbage)))))

(define-syntax benchmark-time
  (syntax-rules ()
    [(benchmark-time expr ...)
     (benchmark-time* (lambda () expr ...))]))


;;
;; Analyse run times
;;

;; (vectorof number) (vectorof number) -> (U #t #f)
;;
;; Implementation of one-tailed Student t-test with equal
;; number of samples and equal variance
;;
;; #t if the means are significantly different at the 0.05 level
(define (t-test? times1 times2)
  (define p 0.05)
  (define n (vector-length times1))
  (define std-dev (sqrt (/ (variance times1) (variance times2) 2)))
  (define t (/ (- (mean times1) (mean times2)) (* std-dev (sqrt (/ 2 n)))))
  (< (t-distribution-pdf t (- (* 2 n) 2)) p))

;; struct statististics : float float float float float
;;
;; slowdown > 1 indicates 1 is slower than 2
(define-struct statistics (mean1 mean2 std-dev1 std-dev2 slowdown))

(define (times->statistics times1 times2)
  (make-statistics (mean times1)
                   (mean times2)
                   (standard-deviation times1)
                   (standard-deviation times2)
                   (/ (mean times1) (mean times2))))

(define (compare-times times1 times2 operator printer verbose?)
  (let* ([m1 (mean times1)]
         [m2 (mean times2)]
         [success? (operator m1 m2)])
    (when verbose?
      (printer (times->statistics times1 times2) success?))
    success?))

(define ((current-output-printer name1 name2 comparison) statistics success?)
  (newline)
  (if success?
      (printf "~a was ~a than ~a\n" name1 comparison name2)
      (printf "~a was NOT ~a than ~a\n" name1 comparison name2))
  (display "------------------------------------------------------------\n")
  (printf "Statistics for ~a\n" name1)
  (printf "Mean:     ~a\n" (statistics-mean1 statistics))
  (printf "Std dev.: ~a\n" (statistics-std-dev1 statistics))
  (newline)
  (printf "Statistics for ~a\n" name2)
  (printf "Mean:     ~a\n" (statistics-mean2 statistics))
  (printf "Std dev.: ~a\n" (statistics-std-dev2 statistics))
  (newline)
  (printf "~a took ~a the time of ~a\n" name1 (statistics-slowdown statistics) name2)
  (display "------------------------------------------------------------\n"))

(define (faster*? name1 times1 name2 times2 [verbose? #t])
  (compare-times times1 times2 <
                 (current-output-printer name1 name2 "faster")
                 verbose?))

(define-syntax faster?
  (syntax-rules ()
    [(faster? [name1 expr1 ...] [name2 expr2 ...])
     (faster*? name1 (benchmark-time expr1 ...)
               name2 (benchmark-time expr2 ...))]))

(define (as-fast*? name1 times1 name2 times2 [verbose? #t])
  (compare-times times1 times2 <=
                 (current-output-printer name1 name2 "as fast")
                 verbose?))

(define-syntax as-fast?
  (syntax-rules ()
    [(as-fast? [name1 expr1 ...] [name2 expr2 ...])
     (as-fast*? name1 (benchmark-time expr1 ...)
                name2 (benchmark-time expr2 ...))]))


;;
;; SchemeUnit Checks
;;

(define ((check-printer name1 name2 comparison) statistics success?)
  (if success?
      #t
      (with-check-info
       (('name1 name1)
        ('name2 name2)
        ('mean1 (statistics-mean1 statistics))
        ('mean2 (statistics-mean2 statistics))
        ('std-dev1 (statistics-std-dev1 statistics))
        ('std-dev2 (statistics-std-dev2 statistics))
        ('slowdown (statistics-slowdown statistics))
        ('message (format "~a was not ~a than ~a" name1 comparison name2)))
       (fail-check))))

(define-check (check-faster name1 thunk1 name2 thunk2)
  (compare-times (benchmark-time* thunk1)
                 (benchmark-time* thunk2)
                 <
                 (check-printer name1 name2 "faster")
                 #t))

(define-check (check-as-fast name1 thunk1 name2 thunk2)
  (compare-times (benchmark-time* thunk1)
                 (benchmark-time* thunk2)
                 <=
                 (check-printer name1 name2 "as fast")
                 #t))


(define-check (check-faster-times times1 times2)
  (compare-times times1
                 times2
                 <
                 (check-printer "1" "2" "faster")
                 #t))


;;
;; Benchmark Test Case
;;

;; struct (benchmark-test-case schemeunit-test-case) : string
(define-struct (benchmark-test-case schemeunit-test-case) (log-file))

;; syntax this-expression-benchmark-log-file : () -> path
(define-syntax (this-expression-benchmark-log-file stx)
  (syntax-case stx ()
    [(this-expression-benchmark-log-file)
     ;; The expressions generating directory and file-name
     ;; below are cut'n'paste from
     ;; this-expression-source-directory and
     ;; this-expression-file-name from etc.ss in MzLib.  I
     ;; tried to use the macros (as so maintain
     ;; abstraction) but just couldn't get the things to
     ;; pickup the right source location.
     (with-syntax
         ([directory
           (let* ([source (syntax-source stx)]
                  [source (and (path? source) source)]
                  [local (or (current-load-relative-directory) (current-directory))]
                  [dir (path->main-collects-relative
                        (or (and source (file-exists? source)
                                 (let-values ([(base file dir?) (split-path source)])
                                   (and (path? base)
                                        (path->complete-path base local))))
                            local))])
             (if (and (pair? dir) (eq? 'collects (car dir)))
                 (with-syntax ([d dir])
                   #'(main-collects-relative->path 'd))
                 (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
                   #'(bytes->path d))))]
          [file-name
           (let* ([f (syntax-source stx)]
                  [f (and f (path? f) (file-exists? f)
                          (let-values ([(base file dir?) (split-path f)]) file))])
             (if f
                 (with-syntax ([f (path->bytes f)]) #'(bytes->path f))
                 #'#f))])
       (syntax/loc stx
         (build-path
          directory
          (string-append
           (path->string file-name)
           ".benchmark-log"))))]))

;; syntax benchmark-case : expr ... -> test-case
(define-syntax (benchmark-case stx)
  (syntax-case stx ()
    [(_ name expr ...)
     (with-syntax ([log-file
                    (datum->syntax
                     stx
                     '(this-expression-benchmark-log-file)
                     stx)])
       (syntax
        (make-benchmark-test-case
         name
         (lambda ()
           (let* ([test-thunk (lambda () expr ...)]
                  [times (benchmark-time* test-thunk)]
                  [previous-run (find-most-recent-run log-file name)])
             (when previous-run
                 (check-faster-times times (run-times previous-run)))
             (add-run log-file name times)
             #t))
         log-file)))]))

;; faster? : (() -> any) (() -> any) : (U #t #f)
;;
;; True if thunk1 is faster than thunk2, false otherwise
;;(define (faster? thunk1 thunk2)
;;  (let ([time1 (collect-and-time thunk1)]
;;        [time2 (collect-and-time thunk2)])
;;    (< (mean time1) (mean time2))))