;;; **********************************************************************
;;; CM's test suite, works in both Guile and CLTL (assuming Scheme syntax
;;; is enabled.) To test CM, load this file and then call (test-cm)
;;;
;;; The tests assume that the following vars exist at load time:
;;; *features*      Tests check for :guile :cmu :clm :cmn :midishare
;;; The following vars must be defined if their *feature* exists:
;;; midishare-directory
;;; clm-directory
;;; cmn-directory
;;; **********************************************************************

(when (member ':guile *features*)
  (defmacro iter args (scheme-loop args))
  )

(define tmp-directory "/tmp/")

(define (clean-tmp)
  (unless (member ':guile *features*)
    ;; clear out existing tmp files....
    (do ((typs '("cm" "mid" "midi" "sco" "aiff" "clm" "eps" "cmn" )
               (cdr typs)))
        ((null? typs) #f)
      (dolist (f (directory (format #f "~a*.~a" 
                                    tmp-directory (car typs))))
        (delete-file f)))))

;;;
;;;
;;;

(define (test-cm . testdir)
  (if (not (null? testdir))
    (set! tmp-directory (car testdir)))
  (clean-tmp)
  (test-cm-core)
  (test-cm-output))

(define (test-cm-core)
  (test-iter)
  (test-objects-and-slots)
  (test-object-editing)
  (test-object-saving)
  (test-rhythm-and-tempo)
  (test-note-keynum-and-hertz)
  (test-tunings-and-modes)
  (test-pattern-generation))

(define (test-cm-output)
  (test-midifile-output)
  (test-csound-output)
  (when (member :clm *features*)
    (test-clm-output))
  (when (member :cmn *features*)
    (test-cmn-output))
  (when (member :midishare *features*)
    (test-midishare-output)))

(cd tmp-directory) ;; make sure we write to tmp-directory!

;;;
;;; test implementation
;;;

(defmacro deftest (name args str . body)
  (let ((vars '((x #f)
                (y #f)
                (z #f)
                (%n 0))))
    `(define ,(cons name args)
       (let (,@vars )
         ;; gag compiler warnings about any unused vars...
         ,@(loop for v in vars collect (car v))
         (format #t "~%Testing ~a." ,str)
         ,@body
         (values)))))

(defmacro check (str form )
  `(begin
    (set! %n (+ %n 1))
    (format #t "~%  ~a. Checking ~a ... " %n ,str)
    (if ,form
      (begin (format #t "OK")
             true)
      (begin (format #t "~s FAILED." ',form)
             false))))

(define *fudge-factor* .0001)

(define (@= a b )
  ;; approximate equality
  (or (= a b)
      (let ((z (abs (- a b))))
        (< z *fudge-factor*))))

(define (clear-dictionary)
  (hash-clear! *dictionary*))

;;;
;;; Common Music Test Suite
;;;

(deftest test-iter () 
  "iteration clauses" 
  (check "for...below...collect" 
         (equal? (iter for i below 10 collect i)
                 '(0 1 2 3 4 5 6 7 8 9)))
  (check "for...to...sum"
         (equal? (iter for i to 10 sum i)
                 55))
  (check "for...downto...count" 
         (equal? (iter for i from 0 downto -10 count (even? i))
                 6))
  (check "for...above...minimize" 
         (equal? (iter for i from 0 above -10 minimize i)
                 -9))
  
  (check "in...by cddr"
         (equal? (iter for x in '(0 1 2 3 4 5 6 7 8 9)
                       by 'cddr collect x)
                 '(0 2 4 6 8)))
  (check "for...on...by"
         (equal? (iter for x on '(0 1 2)
                       by 'cdr collect x)
                 
                 '((0 1 2) (1 2) (2))))
  (check "for...in...thereis/false"
         (equal? (iter for x in '(0 1 2 3 4 5 6 7 8 9) 
                       thereis (= x 400))
                 false))
  (check "for...in...thereis/true"
         (equal? (iter for x in '(0 1 2 3 4 5 6 7 8 9) 
                       thereis (= x 4))
                 true))
  (check "for...in...never/false" 
         (equal? (iter for x in '(0 1 2 3 4 5 6 7 8 9) 
                       never (= x 4))
                 false))
  (check "for...in...never/true" 
         (equal? (iter for x in '(0 1 2 3 4 5 6 7 8 9) 
                       never (= x 40))
                 true))
  (check "for in always/false"
         (equal? (iter for x in '(0 2 3 4 5 6 7 8 9)
                       always (= x 40))
                 false))
  (check "for in always/true"
         (equal? (iter for x in '(0 2 3 4 5 6 7 8 9)
                       always (< x 40))
                 true))
  (check "with...collect...do" 
         (equal? (iter repeat 10 with x = 0 
                       collect x 
                       do (set! x (+ x 1)))
                 '(0 1 2 3 4 5 6 7 8 9)))
  (check "repeat...count"
         (equal? (iter repeat 4 count 4)
                 4))
  (check "repeat...for...=...then"
         (equal? (iter repeat 10 
                       for x = true then (not x)
                       collect x)
                 (list true false true false true false 
                       true false true false)))
  (check "repeat count/true" 
         (equal? (iter repeat 10 count #t)
                 10))
  (check "repeat count/false" 
         (equal? (iter repeat 10 count #f)
                 0))
  (check "collect...collect" 
         (equal? (iter for i to 4 
                       collect i collect (* 2 i))
                 '(0 0 1 2 2 4 3 6 4 8)))
  (check "nconc"
         (equal? (iter for i from -2 to 2 by 2 nconc (list i (- i)))
                 '(-2 2 0 0 2 -2)))
  (check "from -10 downto 10" 
         (equal? (iter for i from -10 downto 10 by -1 collect i)
                 '()))
  (check "downfrom 4 downto -4 by"
         (equal? (iter for i downfrom 4 downto -4 by 2 collect i)
                 '(4 2 0 -2 -4)))
  ;; this might be false or ()
  (check "from 10 to -10" 
         (equal? (iter for i from 10 to -10 by 1 collect i)   ; -> NIL
                 '()))
  (check "to 4 downto 4"
         (equal? (iter for i to 4
                       for j downfrom 4
                       collect i collect j)
                 '(0 4 1 3 2 2 3 1 4 0)))
  (check "with"
         (equal? (iter with a and b = 'x and c = 2
                       repeat 2
                       for x = 1 then 'fred
                       collect (list x a b c))
                 '((1 #f x 2) (fred #f x 2))))
  (check "across...append"
         (equal? (iter for i across #(0 1 2 3) 
                       append (list i (expt 2 i)))
                 '(0 1 1 2 2 4 3 8)))
  (check "minimize...maximize"
         (equal? (iter for x in '(-1 2000 -222222 2222222 99)
                       minimize x into a
                       maximize x into b
                       finally (return (cons a b)))
                 '(-222222 . 2222222)))
  (check "with...while...sum...do..finally"
         (equal? (iter with a = 0 and b = -1
                       while (< a 10)
                       sum a into foo do (set! a (+ a 1))
                       finally (return (list foo b)))
                 '(45 -1)))
  (check "if...else...and"
         (equal? (iter for j in '(1 2 1 4 1)
                       if (even? j) collect j
                       else collect (- j)
                       and collect 'foo)
                 '(-1 foo 2 -1 foo 4 -1 foo)))
  (check "for...until"
         (equal? (iter for i from 0
                       until (> i 4) collect i)
                 '(0 1 2 3 4)))
  (check "for...while...when...collect"
         (equal? (iter for i from 0
                       while (< i 9)
                       when (even? i) collect i)
                 '(0 2 4 6 8)))
  (check "when...return"
         (equal? (iter for x from 1
                       when (> x 6)
                       return (list 'hiho x ))
                 '(hiho 7)))
  (check "for i =...for j ="
         (equal? (iter repeat 4
                       for i = 9 then (+ i 1)
                       for j = (+ i 1)
                       collect (list i j))
                 '((9 10) (10 11) (11 12) (12 13))))
  (check "for x...then x+1"
         (equal? (iter repeat 4
                       for x = 0 then (+ x 1)
                       while (< x 4)
                       collect x)
                 '(0 1 2 3))))

(deftest test-objects-and-slots () 
  "new, initargs, and sv"
  ;; keyword args
  (set! x (new midi :channel 7 :time 0 :duration 1
               :amplitude .5 keynum 90))
  (check "new keyword inits" 
         (loop for e in '((channel 7) (time 0) 
                          (duration 1) (amplitude .5)
                          (keynum 90))
               always (equal? (slot-ref x (car e)) (cadr e))))
  
  ;; symbol args in reverse order
  (set! x (new midi  keynum 90 amplitude .5 duration 1
               time 0 channel 7))
  (check "new symbol inits" 
         (loop for e in '((channel 7) (time 0) 
                          (duration 1) (amplitude .5)
                          (keynum 90))
               always (equal? (slot-ref x (car e)) (cadr e))))
  
  (check "sv accessing" (equal? (sv x channel) 7))
  (sv x channel 1 time 4)
  (check "sv setting" (and (equal? (sv x channel) 1)
                           (equal? (sv x time) 4))))

(deftest test-object-editing ()
  "sequences, naming and subobject editing"
  (clear-dictionary)
  (set! x (new seq :name 'rick
               :subobjects (loop for i below 10 
                                 collect (new midi time i))))
  ;; test name
  (check "find-object sym" (find-object 'rick))
  (check "find-object read-macro" #&rick)
  (check "find-object string" (find-object "rick"))
  (check "find-object ucase string" (find-object "RICK"))
  (check "list-named-objects" (member x (list-named-objects)))
  
  ;; test renaming
  (rename-object x 'fred)
  (check "renaming object" (find-object 'fred))
  (check "old name free" (not (find-object 'rick #f)))
  
  ;; test subobjects
  (check "subobjects" (= (length (subobjects x)) 10))
  (set! y (new midi :time 1))
  (set! (subobjects x) (list y))
  (check "subobjects setting" (= (length (subobjects x)) 1))
  
  ;; test subobject editing
  (append-object (new midi :time 2) x)
  (check "append-object" (and (= (length (subobjects x)) 2)
                              (equal? (car (subobjects x)) y)))
  (set! z (new midi :time 0))
  ;; insert at front
  (insert-object z x)
  (check "insert-object front"
         (and (= (length (subobjects x)) 3)
              (equal? (car (subobjects x)) z)))
  
  ;; insert middle: (0 1 [1.5] 2)
  (set! z (new midi :time 1.5))
  (insert-object z x)
  (check "insert-object middle" 
         (and (= (length (subobjects x)) 4)
              (equal? (third (subobjects x)) z)))
  ;; insert duplicate time: (0 1 1.5 2 [2])
  ;; insertion  should  be at end.
  (set! z (new midi :time 2))
  (insert-object z x)
  (check "insert-object with duplicate time"
         (and (= (length (subobjects x)) 5)
              (equal? (end (subobjects x)) z)))
  ;; insert after end
  (set! z (new midi :time 22))
  (insert-object z x)  
  (check "insert-object end"
         (and (= (length (subobjects x)) 6)
              (equal? (end (subobjects x)) z)))
  ;; removal
  (remove-object z x)
  (check "remove-object" (= (length (subobjects x)) 5))
  (remove-subobjects x)
  (check "remove-subobjects" (= (length (subobjects x)) 0))
  )

(deftest test-object-saving ()
  "save-object" 
  (clear-dictionary)
  (set! x (new seq :name 'rick
               :subobjects (loop for i below 10 
                              collect (new midi time i))))
  (set! y (format false "~a~a" tmp-directory "foo.cm"))
  (save-object x y)
  (check "saved file exists" (file-exists? y))
  (rename-object x 'bif)
  (load y)
  (set! z (find-object 'rick))
  (check "load saved object"
         (and z (= (length (subobjects z)) 10)))
  (check "reloaded slot values"
         (and z
              (equal? '(0 1 2 3 4 5 6 7 8 9)
                      (loop for i in (subobjects z)
                         collect (sv i time))))))

(deftest test-rhythm-and-tempo ()
  "rhythm"
  (clear-dictionary)
  (check "rhythm symbols and ratios"
         (loop for i in '(x t e q h w d l)
            for j in '(64th 32nd 8th 4er 1/2 1 2 4)
            for k in '(1/64 1/32 1/8 1/4 1/2 1 2 4)
            always 
            (and (@= (rhythm i) (rhythm j) )
                 (@= (rhythm j) (rhythm k) ))))
  
  (check "triplets, quintuplets, dots"
         (and (@= (rhythm 't16) (* 1/3 .5) )
              (@= (rhythm 't8.) (+ (* 1/3 1.0)
                                   (* 1/6 1.0)))
              (@= (rhythm 'qq) (* 1/5 4.0))
              (@= (rhythm 'w...) (+ 4.0 2 1 .5))
              (@= (rhythm 'te) (* 1/3 1.0))))
  
  (check "rhythm expressions"
         (and (@= (rhythm 'w-s) 3.75 )
              (@= (rhythm 'q+q+q+q) 4.0 )
              (@= (rhythm 'q+q+q-q) 2.0 )
              (@= (rhythm 'w+h+q+e+s)
                  (rhythm 'w....))
              (@= (rhythm 's*4) 1.0 )))
  
  (check "tempo and beat"
         (and (@= (* 2/3 (rhythm 'q 60) )
                  (rhythm 'q 90)
                  )
              (= (rhythm 'q 60 'q)
                 (rhythm 'h 60 'h)
                 (rhythm 'q. 60 'q.)))))
              
(deftest test-note-keynum-and-hertz ()
  "notes, keynums and hertz in standard scale"
  (clear-dictionary)
  (check "note" (and (equal? 'a4 (note 'a4))
                     (equal? 'a4 (note 69))
                     (equal? 'a4 (note 440 :hz t))))
  (check "keynum" (and (equal? 69 (keynum 'a4))
                       (equal? 69 (keynum 69))
                       (= 69 (keynum 440 :hz t))))
  (check "hertz" (and (@= 440 (hertz 'a4))
                      (@= 440 (hertz 69))
                      (@= 440  (hertz 440 :hz t))))
  (check "scale<" (and (scale< 'ef5 'ef6)
                       (not (scale<  'ef6 'ef5))
                       (not (scale< 'ef6 'ef6))
                       (scale<  60 'df4)
                       (not (scale< 'df4 60))
                       (scale< 60 61)))
  (check "scale<=" (and (scale<= 'ef5 'ef6)
                        (scale<= 'ef6 'ef6)))
  (check "scale=" (and (scale= 'c4 'bs3)
                       (scale= 61 'df4)
                       (scale= 'df4 'cs4)
                       (scale= 60 'dff4)))
  (check "scale>" (and (not (scale> 'ef5 'ef6))
                       (scale>  'ef6 'ef5)
                       (not (scale> 'ef6 'ef6))
                       (not (scale>  60 'df4))
                       (scale> 'df4 60)
                       (not (scale> 60 61)))))

(deftest test-tunings-and-modes ()
  "tunings and modes"
  (clear-dictionary))

(deftest test-pattern-generation ()
  "patterns"
  ;; next with non-pattern data
  (clear-dictionary)
  (check "(next 1)" (equal? (next 1) 1))
  (check "(next 1 true)" (equal? (next 1 true) '(1)))
  (check "(next 1 5)" (equal? (next 1 5) '(1 1 1 1 1)))
  ;; next periods
  (set! x (new cycle :of (list 1 2 3)))
  (check "cycle" (loop for i in '(1 2 3 1 2 3)
                       always (equal? (next x) i)))
  (equal? "cycle period" 
          (equal? (next x true) '(1 2 3) ))
  ;; period length
  (set! x (new cycle :of '(1 2 3) :for 4))
  (check "period length"
         (and (equal? (next x true) '(1 2 3 1))
              (equal? (next x true) '(2 3 1 2))
              (equal? (next x true) '(3 1 2 3))))
  ;; repeat factor
  (set! x (new cycle :of '(1 2 3) :repeat 2))
  (loop repeat 6 do (next x))
  (check "period repeat"
         (equal? (next x) :end-of-data))
  ;; eop?
  (set! x (new cycle :of '(1 2 3) :for 4 ))
  (next x t)
  (check "eop?" (eop? x))
  ;; eod?
  (set! x (new cycle :of '(1 2 3) :for 4 :repeat 2))
  (loop repeat 9 do (next x))
  (check "eod?"  (eod? (next x) ))
  (set! x (new cycle :of '(1 2 3)
               :for (new cycle :of '(1 2 3) )))
  (check "period pattern"
         (and (equal? (next x true) '(1))
              (equal? (next x true) '(2 3))
              (equal? (next x true) '(1 2 3))))
  ;; subpatterns
  (set! x (new cycle :of
               (list (new cycle :of '(1 1 1))
                     (new cycle :of '(2 2 2))
                     (new cycle :of '(3 3 3)))))
  (check "subpatterns"
         (equal? (next x true) '(1 1 1 2 2 2 3 3 3)))
  ;; motives
  (set! x (new cycle :of (list (new cycle :of 1 :name 'ff)
                               2
                               #&ff
                               3)))
  (check "subpattern motives"
         (equal? (next x t) '(1 2 1 3)))
  ;; pval
  (set! x (new cycle :of (list (pval (+ 1 1))
                               (pval (+ 2 2 ))
                               (pval (+ 3 3)))))
  (check "pval" (equal? (next x true) '(2 4 6)))
  ;; notes
  (set! x (new cycle :notes (list 60 61 62)))
  (check "notes"
         (equal? (next x true)
                 (note '(60 61 62))))
  ;; keynums
  (set! x (new cycle :keynums '(c4 cs4 d4)))
  (check "keynums"
         (equal? (next x true)
                 (keynum '(c4 cs4 d4)))))

(deftest test-midifile-output ()
  "midi file output"
  (clear-dictionary)
  (set! x (format #f "~a~a" tmp-directory "foo.midi"))
  (events (list (new midi time 0 duration 1 keynum 33)
                (new midi time 1 duration 1 keynum 66)
                (new midi time 2 duration 1 keynum 66 ))
          x)
  (set! y (import-events x))
  (check "first event midimsg"
         (is-a? (car (subobjects y)) <midi-event>))
  (check "import times" 
         (loop for i in (cdr (subobjects y))
               for j in '(0 1 2)
               always (@= (sv i time) j )))
  (set! y (import-events x :tempo 120))
  (check "import with tempo"
         (loop for i in (cdr (subobjects y))
               for j in '(0 .5 1)
               always (@= (sv i time) j ))))

;;; for some reason define-class has to be
;;; at top-level in scheme.

(defobject i1 (i)
             ((dur :initform 1)
              frq
              amp)
    (:parameters time dur frq amp))

(deftest test-csound-output ()
  "sco file output"
  (clear-dictionary)
  
  (check "i1 parameters"
         (loop for x in (class-parameters (find-class 'i1))
               always (member (car x) '(time dur frq amp))))
  (set! x (format false "~a~a" tmp-directory "test.sco"))
  (events (list (new i1 :time 0 :frq 440 :amp .2))
          x)
  (check "sco file exists" (file-exists? x))

  (set! y (open-file x :input))
  (check "sco file parameter values"
         (and (equal? (read y) 'i1)
              (equal? (read y) 0)
              (equal? (read y) 1)
              (equal? (read y) 440)
              (equal? (read y) .2)))
  (close-file y :input)
  )

(define <fm-violin> #f)
(define (test )
  (process repeat 10
           output (make-instance 
                   <fm-violin> :startime (now)
                   :dur 1 :amplitude .1 
                   :frequency 440)))

(deftest test-clm-output ()
  "clm output"
  (compile-file (format #f "~av.ins" clm-directory))
  (load  (if (member :cmu *features*)
           (format #f "~av.cmucl" clm-directory)
           (format #f "~av" clm-directory)))
  (check "fm-violin object"
         (and (find-class 'fm-violin #f)
              (object-parameters
               (make-instance (find-class 'fm-violin)))))
  (events (test) "test.clm")
  (check "output .clm"
         (probe-file (format #f "~atest.clm" tmp-directory)))
  (events (test) "test.aiff" :channels 2 :srate 44100 :play #f)
  (check "output .aiff"
         (probe-file  (format #f "~atest.aiff" tmp-directory))))

(deftest test-cmn-output ()
  "cmn output"
  (clear-dictionary)
  (unless (member ':cmn *features*)
    (load (format #f "~acmn-all" cmn-directory)))
  (define (testcmn stf len nts)
    (let ((nts (new heap :notes nts)))
      (process while (< (now) len)
               for n = (next nts)
               output (new midi :time (now)
                           :duration 1
                           :keynum n
                           :channel stf)
               wait 1)))
  (set! x '((0 :name "Viola" :clef :alto :meter (4 4))
            (1 :name "Flute" :clef :treble :meter (4 4))))
  ;; generate a .eps file
  (events (list (testcmn 0 12 '(c3 d ef f g))
                (testcmn 1 12 '(c5 d ef f g)))
          "testcmn1.eps" 
          :staffing x
          :size 24
          :title "Hiho!")
  (check ".eps output" (probe-file "testcmn1.eps"))
  ;; generate a .cmn file
  (events (list (testcmn 0 12 '(c3 d ef f g))
                (testcmn 1 12 '(c5 d ef f g)))
          "testcmn2.cmn" 
          :staffing x
          :size 24
          :title "Hiho!")
  (check ".cmn output" (probe-file "testcmn2.cmn")))

(deftest test-midishare-output ()
  "midishare and player interface"
  (check "midishare loaded" (equal? (midishare) 1))
  (check "midi-open" (equal? (midi-open) (find-object "midi.port")))
  (define (testms chan)
    (process for k from 60 to 72
             output (new midi :time (now)
                         :keynum k
                         :duration .5
                         :amplitude .9
                         :channel chan)
             wait .25))
  (set! x (events (testms 0) "midi.port"))  ; logical chan 0 -> port 0 chan 0
  (check "sent chromatic scale" (equal? x "midi.port"))
  (sleep 5)
  (define (dim-test-1 chan dur amp-1 amp-2 steps)
    (process with amp-val 
             with step-time = (/ dur steps 1.0)
             for i to steps do
             (set! amp-val (round (interpl (now) (list 0 amp-1 dur amp-2))))
             (if (= i 0)
               (output (new midi 
                         :time (now)
                         :channel chan
                         :duration dur
                         :amplitude amp-1))
               (output (new midi-control-change :time (now)
                            :channel chan
                            :controller 7
                            :value amp-val)))

           (wait step-time)))
  (set! x (events (list (new midi-program-change :time 0 
                             :channel 0 :program 40)
                        (dim-test-1 0 2 90 0 20))
                  "midi.port"))
  (check "sent violin diminuendo" (equal? x "midi.port"))
  (sleep 5)
  (events (testms 0) "test.mp")
  (sleep 5)
  ;; this isnt working in osx 10.3.8 / OpenMCL 0.14.2
  ;;  (player-save-midifile (find-object "test.mp") "player.mid")
  (midi-close)
  )



