;;; -*- syntax: common-lisp; base: 10; mode: lisp -*-
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File:             zeroexpand.ins
;;;
;;; Purpose:          
;;;
;;;                   A granular synthesis/time stretching instrument.
;;;                   Uses a zero-crossing algorithm to avoid having
;;;                   to envelope the grains.  Each grain is panned
;;;                   randomly to a channel
;;;
;;; Author:           Michael Edwards - m@michael-edwards.org
;;;
;;;
;;; $$ Last modified: 11:04:12 Fri May 22 2009 GMT Daylight Time
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :clm)

;; only allow negative to positive
(defmacro zero-cross (s1 s2)
  `(progn
     (unless (and (numberp ,s1) (numberp ,s2))
       (when debug
         (clm-print debug-stream "~%zero cross caught a non-number."))
       (setf happy nil))
     (and 
      (< ,s1 0.0)
      (>= ,s2 0.0))))

(defmacro get-samp ()
  `(if do-src
       (src src-gen)
     (readin rd)))

(defmacro fill-wave (array)
  `(let ((smp1 (get-samp)))
     (loop 
         for i from 1
         for smp2 = (get-samp)
         do
           (when (>= i wave-size)
             (when debug
               (clm-print debug-stream
                          "~%fill-wave: Couldn't find zero-crossing."))
             (setf happy nil)
             (return))
           (setf (aref ,array i) smp1)
           (when (and (> i min-grain)
                      (zero-cross smp1 smp2))
             (setf (aref ,array (1+ i)) smp2)
             ;; this causes the finally clause to trigger
             (loop-finish))
           (setf smp1 smp2)
         finally
           ;; store how many samples there are in the first element
           (setf (aref ,array 0) (1+ i))
           (when debug
             (clm-print debug-stream 
                        "~%fill-wave: ~d samples ~%Beginning samples: "
                        (aref ,array 0))
             (loop for j from 1 to 10 do
                   (clm-print debug-stream "~f " (aref ,array j)))
             (clm-print debug-stream "~%Final samples: ")
             (loop for j from (- i 10) below i do
                   (clm-print debug-stream "~f " (aref ,array j)))))))


(definstrument zeroexpand

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; Beginning of Instrument Parameters
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (file            ;; Input file
     time            ;; Output file start time
     &key
     (stretch 1)     ;; How many times to stretch the input.  We use
                     ;; either stretch or duration, not both.  NB Must be
                     ;; a whole number
     (channel 0)     ;; input channel to process
     (duration nil)  ;; Output duration: NB this will override stretch
     (start 0)       ;; Input file start time (seconds)
     (end nil)       ;; Input file end time (seconds); nil indicates the
                     ;; end of the file  
     (srt 1.0)       ;; Sampling-Rate Conversion factor (1 = no transposition)
                     ;; can also be a list whereby each will be assigned
                     ;; to a voice in turn (repeating the list where
                     ;; necessary) 
     (amp 1.0)       ;; amplitude (generally 0.0 - 1.0)
     (distance 0)    ;; how far away is the sound?
     (voices 1)      ;; how many streams?  NB if this is less than the
                     ;; number of srts it will be overriden
     (min-freq 50)   ;; minimum grain frequency in Hz (this translates
                     ;; into a minimum grain size (srate / min-freq)
                     ;; so the lower the freq, the higher the min grain size
     (amp-env '(0 1 100 1)) ;; Amp-Envelope for the output file
     (rev-amt 0)            ;; Reverb amount
     (rev-env '(0 1 100 1)) ;; Reverb envelope
     (debug nil)     ;; write all kinds of interesting data into 
                     ;; a file or to the terminal
     (debug-file nil) 
     (printing t)) ;; whether to print the number of seconds computed 

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; End of Instrument Parameters, beginning of Instrument Setup Code
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

         ;; Which sample in the output file do we begin on?
  (let* ((st (floor (* time *srate*)))
         (srts (if (listp srt)
                   srt
                 (list srt)))
         (lsrts (length srts))
         (vces (if (< voices lsrts)
                   lsrts
                 voices))
         ;; we need an array for the run loop
         (srtsa (make-array vces :initial-contents
                            (loop for i below vces collect
                                  (nth (mod i lsrts) srts))))
         ;; input file start sample
         (input-start-sample (floor (* start *srate*)))
         ;; open file handles for the src generators
         (f (open-input file :start input-start-sample :channel channel))
         (do-src (loop for s in srts unless (= s 1) do (return t)))
         (src-gen (when do-src (make-src :input f :srate (first srts))))
         (rd (unless do-src (make-readin :file f)))
         ;; Panning und Reverb generator
         (loc (make-locsig :distance distance :reverb
                           rev-amt :type mus-interp-sinusoidal)) 
         (output-chans (mus-channels *output*))
         ;; duration of the input file
         (snd-dur (sound-duration file))
         (endd (if end end snd-dur))
         (input-dur (- endd start))
         (dur (if duration
                  duration
                (* input-dur stretch)))
         ;; the stretch factor
         (strch (ceiling (if duration
                             (/ duration input-dur)
                           stretch)))
         ;; we move from the first waveform to the next over 'strch'
         ;; times.  The selection of whether to use wave1 or wave2
         ;; will be determined randomly but the chance of 2 is 0 at
         ;; the beginning, 1 (max) at the end.  Calculate the chances
         ;; here.  This will go from 0 to 1
         (chances (make-array strch :initial-contents
                              (loop with inc = (/ 1.0 (1- strch)) 
                                  for x from 0.0 by inc
                                  repeat strch collect x)))
         (min-grain (floor (/ *srate* min-freq)))
         ;; for each voice we'll increment the start point using
         ;; min-grain as our grain size to arrive at
         (hop (floor (/ min-grain vces)))
         ;; the first element of these arrays will always be
         (wave-size (* 2 min-grain))
         (wave1 (make-array wave-size
                            :element-type 'double-float
                            :initial-element 1000.0d0))
         (wave2 (make-array wave-size
                            :element-type 'double-float
                            :initial-element 1000.0d0))
         ;; we need pointers to our arrays in order to avoid copying
         (w1 wave1)
         (w2 wave2)
         (current-wave w1)
         ;; Envelope for the complete output file
         (ampf (make-env :envelope amp-env :scaler amp   
                         :duration dur))
         ;; Envelope for the Reverb Stream
         (renv (make-env :envelope rev-env :scaler rev-amt :duration
                         dur))
         (location 0.5)
         (out1-chan 0)
         (out2-chan 0)
         (count 0)
         (samp1 -1.0)
         (samp2 -1.0)
         (happy t)
         (debug-stream (when debug 
                         (if debug-file
                             (c-open-output-file debug-file)
                           *standard-output*)))
         ;; At which sample in the output file do we stop?
         (nd (+ st (floor (* *srate* dur)))))
    ;; Some sanity checks:
    (when (and duration (< duration input-dur))
      (error "Duration must be > than input file duration"))
    ;; Check that the given start and end times are not bigger than
    ;; the input file duration
    (when (or (> start snd-dur) 
              (and end (> end snd-dur)))
      (error "Illegal file access requested: ~
              Input duration = ~a, :start = ~a, :end = ~a"
             snd-dur start end))
    ;; Make sure that start isn't greater than end
    (when (and end (>= start end))
      (error ":start (~a) >= :end (~a) ????" start end))
    ;; Print the start time
    (when printing 
      (format t "~&Start time ~a. hop=~a min-grain=~a vces=~a do-src=~a~%"
              time hop min-grain vces do-src))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; End of setup code.  Beginning of run loop.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (run
     (loop for voice below vces do
           (declare (type :integer output-chans out1-chan out2-chan))
           (when printing
             (clm-print "~%Voice ~d" (1+ voice))) 
           (when debug
             (clm-print debug-stream "~%~%~%*********Voice ~d" (1+ voice))) 
           (unless (zerop voice)
             (when debug
               (clm-print debug-stream "~%*** Jumping to sample ~d"
                          input-start-sample))
             (if do-src
                 (progn
                   (mus-reset src-gen)
                   (setf (mus-location src-gen) input-start-sample
                         (mus-increment src-gen) (aref srtsa voice))
                   (when debug
                     (clm-print debug-stream "~%src=~f" (aref srtsa voice))))
               (progn
                 (mus-reset rd)
                 (setf (mus-location rd) input-start-sample))))
           (incf input-start-sample hop)
           ;; getting to the end of the file in last voice might have triggered
           ;; unhappy
           (setf happy t 
                 samp1 (get-samp)
                 samp2 (get-samp))  
           ;; find our starting point
           (loop for i from 0 do
                 (when (> i wave-size)
                   (clm-print debug-stream "~%Couldn't find zero-crossing.")
                   (loop-finish))
                 (if (zero-cross samp1 samp2)
                     (return)
                   (setf samp1 samp2
                         samp2 (get-samp))))
           (fill-wave wave1)
           (fill-wave wave2)
           (setf w1 wave1
                 w2 wave2)
           ;; wave loop
           (loop with out-pos = st 
               for wave-count from 0 
               while (and happy (< out-pos nd))
               do
                 ;; if requested, print each time we've computed a second of 
                 ;; sound
                 (when printing 
                   (if (= count *srate*)
                       (progn
                         (setq count 1)
                         (print (round (/ out-pos *srate*))))
                     (incf count)))
                 ;; (when (> out-pos nd)
                 ;; (return))
                 ;; do our wave transition
                 (loop for str below strch 
                     for ran = (random 1.0)
                     do
                       ;; random selection of current-wave
                       (setf current-wave (if (< ran (aref chances str))
                                              (progn 
                                                (when debug
                                                  (clm-print debug-stream
                                                             "~%wave 2"))
                                                w2)
                                            (progn 
                                              (when debug
                                                (clm-print debug-stream
                                                           "~%wave 1"))
                                              w1)))
                       (when debug
                         (clm-print debug-stream "~%out-pos = ~d" out-pos))
                       ;; turn off all our channels
                       (loop for chan below output-chans do
                             (setf (locsig-ref loc chan) 0.0))
                       ;; now turn up two of them randomly
                       (setf out1-chan (random output-chans)
                             out2-chan (if (= out1-chan (1- output-chans))
                                           0
                                         (1+ out1-chan))
                             location (+ .1 (random 0.8))
                             (locsig-ref loc out1-chan) (- 1.0 location)
                             (locsig-ref loc out2-chan) location)
                       (when (and debug (not happy))
                         (clm-print debug-stream
                                    "~%Not happy at sample loop!"))
                       (when happy
                         ;; remember: samples start at 1. 
                         ;; aref 0 is the wave length 
                         ;; sample generation loop
                         (when debug
                           (clm-print debug-stream 
                                      "~%About to write ~d samples"
                                      (aref current-wave 0)))
                         (loop for j from 1 to (aref current-wave 0) do
                               ;; Set the reverb amount according to our
                               ;; envelope NB 
                               ;; only works with mono reverb
                               (setf (locsig-reverb-ref loc 0) (env renv))
                               ;; Output the sample via locsig
                               (locsig loc out-pos (* (env ampf) 
                                                      (aref current-wave j)))
                               (incf out-pos))))
                 ;; generate new waves:
                 ;; we transition first from wave1 to 2, then 2 becomes 1 and
                 ;; we get a new wave etc. etc.
                 ;; but we don't want to have to copy samples around....
                 (if (evenp wave-count)
                     (progn
                       (fill-wave wave1)
                       (setf w1 wave2
                             w2 wave1))
                   (progn
                     (fill-wave wave2)
                     (setf w1 wave1
                           w2 wave2))))
           (restart-env ampf)
           (restart-env renv)))
    (when (and debug debug-file)
      (c-close debug-stream))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; End of instrument code
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|

(with-sound (:statistics t :scaled-to .99 :channels 2
                         :srate 96000 :data-format mus-lfloat 
                         :header-type mus-riff
                         :output "spitze.wav")
  (zeroexpand "spit.wav" 0 
              :stretch 5
              :min-freq 20
              :debug t
              :printing t
              ;; :rev-amt .02
              :voices 5
              :srt 1))


;;; use this algorithm if you want to catch an upward or downward zero-cross
(defmacro zero-cross (s1 s2)
  `(progn
     (unless (and (numberp ,s1) (numberp ,s2))
       (clm-print "zero cross caught a non-number.")
       (setf happy nil))
     (or (zerop ,s1)
         (zerop ,s2)
         (and (< ,s1 0.0)
              (> ,s2 0.0))
         (and (< ,s2 0.0)
              (> ,s1 0.0)))))


|#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; EOF zeroexpand.ins

