;;; -*- 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