;;; with-sound and friends

(provide 'snd-ws.scm)

(defmacro ws-interrupt? ()
  `(if (c-g?) 
       (throw 'with-sound-interrupt)))



;;; -------- with-sound defaults --------

(define *clm-srate*             (default-output-srate))
(define *clm-file-name*         "test.snd")
(define *clm-channels*          (default-output-chans))
(define *clm-data-format*       (default-output-data-format))
(define *clm-header-type*       (default-output-header-type))
(define *clm-verbose*           #f)
(define *clm-play*              #f)
(define *clm-statistics*        #f)
(define *clm-reverb*            #f)
(define *clm-reverb-channels*   1)
(define *clm-reverb-data*       '())
(define *clm-table-size*        512)
(define *clm-file-buffer-size*  65536)
(define *clm-locsig-type*       mus-interp-linear)
(define *clm-clipped*           #t)
(define *clm-array-print-length* (print-length))
(define *clm-player*            #f)
(define *clm-notehook*          #f)
(define *clm-with-sound-depth*  0)           ; for CM, not otherwise used
(define *clm-default-frequency* 0.0)
(define *clm-safety*            0)           ; obsolete
(define *clm-delete-reverb*     #f)          ; should with-sound clean up reverb stream
(define *clm-threads*           4)
(define *clm-output-safety*     0)           ; if 1, assume output buffers will not need to be flushed except at the very end

(define *to-snd*                #t)
(define *default-player* (lambda (s) (play s :wait #t))) ; we need to perserve "play" because it is used as a keyword argument in with-sound


(define (times->samples beg dur) 
  "(times->samples beg dur) converts beg and (+ beg dur) to samples, returning both in a list"
  (list (seconds->samples beg) (seconds->samples (+ beg dur))))


;;; -------- definstrument --------

;(define definstrument define*) -- old form 2-Nov-05

(define *definstrument-hook* #f) ; for CM

(defmacro definstrument (args . body)
  (let* ((name (car args))
	 (targs (cdr args))
	 (utargs (let ((arg-names '()))
		   (for-each
		    (lambda (a)
		      (if (not (keyword? a))
			  (if (symbol? a)
			      (set! arg-names (cons a arg-names))
			      (set! arg-names (cons (car a) arg-names)))))
		    targs)
		   (reverse arg-names)))
	 (doc (if (string? (car body))
		  (let ((val (car body)))
		    (set! body (cdr body))
		    val)
		  "no help")))
  `(begin 
     (define* (,name ,@targs)
       ,doc
       (if *clm-notehook*
	   (*clm-notehook* (symbol->string ',name) ,@utargs))
       ((lambda () ; for inner defines, if any
	  ,@body)))
     ,@(if *definstrument-hook*
           (list (*definstrument-hook* name targs))
           (list)))))


;;; -------- with-sound --------

(define* (with-sound-helper thunk 
			    (srate *clm-srate*) 
			    (output *clm-file-name*) 
			    (channels *clm-channels*)
			    (header-type *clm-header-type*)
			    (data-format *clm-data-format*)
			    (comment #f)
			    (verbose *clm-verbose*)
			    (reverb *clm-reverb*)
			    (revfile "test.rev")
			    (reverb-data *clm-reverb-data*)
			    (reverb-channels *clm-reverb-channels*)
			    (continue-old-file #f)
			    (statistics *clm-statistics*)
			    (scaled-to #f)
			    (play *clm-play*)
			    (to-snd *to-snd*)
			    (clipped 'unset)
			    (notehook *clm-notehook*)               ; (with-sound (:notehook (lambda args (display args))) (fm-violin 0 1 440 .1))
			    (scaled-by #f)
			    (ignore-output #f)
			    (thread-output #f)
			    (thread-reverb #f)
			    (output-safety *clm-output-safety*))
  "with-sound-helper is the business portion of the with-sound macro"
  (let* ((old-srate (mus-srate))
	 (old-*output* *output*)
	 (old-*reverb* *reverb*)
	 (old-notehook *clm-notehook*)
	 (old-verbose *clm-verbose*)
	 (old-auto-update-interval (auto-update-interval))
	 (output-1 output)                    ; protect during nesting
	 (output-to-file (string? output))
	 (reverb-1 revfile)
	 (reverb-to-file (and reverb (string? revfile))))

    (if ignore-output
	(begin
	  (set! output-1 *clm-file-name*)
	  (set! output-to-file (string? output-1))))

    (dynamic-wind 

     (lambda () 
       (set! *clm-verbose* verbose)
       (set! *clm-notehook* notehook)
       (set! (clm-table-size) *clm-table-size*)
       (set! (clm-default-frequency) *clm-default-frequency*)
       (set! (mus-file-buffer-size) *clm-file-buffer-size*)
       (set! (locsig-type) *clm-locsig-type*)
       (set! (mus-array-print-length) *clm-array-print-length*)
       (set! (auto-update-interval) 0.0) ; turn it off
       (if (equal? clipped 'unset)
	   (if (and (or scaled-by scaled-to)
		    (member data-format (list mus-bfloat mus-lfloat mus-bdouble mus-ldouble)))
	       (set! (mus-clipping) #f)
	       (set! (mus-clipping) *clm-clipped*))
	   (set! (mus-clipping) clipped))
       (set! (mus-srate) srate))

     (lambda ()
       (if (not thread-output)
	   (begin
	     
	     (if output-to-file
		 (begin
		   (if continue-old-file
		       (begin
			 (set! *output* (continue-sample->file output-1))
			 (set! (mus-srate) (mus-sound-srate output-1)) ; "srate" arg shadows the generic func
			 (let ((ind (find-sound output-1)))
			   (if (sound? ind)
			       (close-sound ind))))
		       (begin
			 (if (file-exists? output-1) 
			     (delete-file output-1))
			 (set! *output* (make-sample->file output-1 channels data-format header-type comment))))
		   (if *output*
		       (set! (mus-safety *output*) output-safety)))
		 (begin
		   (if (not continue-old-file)
		       (if (or (vct? output-1)
			       (sound-data? output-1)
			       (vector? output-1))
			   (fill! output-1 0.0)))
		   (set! *output* output-1)))

	     (if reverb
		 (if reverb-to-file
		     (begin
		       (if continue-old-file
			   (set! *reverb* (continue-sample->file reverb-1))
			   (begin
			     (if (file-exists? reverb-1) 
				 (delete-file reverb-1))
			     (set! *reverb* (make-sample->file reverb-1 reverb-channels data-format header-type))))
		       (if *reverb*
			   (set! (mus-safety *reverb*) output-safety)))
		     (begin
		       (if (not continue-old-file)
			   (if (or (vct? reverb-1)
				   (sound-data? reverb-1)
				   (vector? reverb-1))
			       (fill! reverb-1 0.0)))
		       (set! *reverb* reverb-1)))))

	   ;; else thread-output
	   (begin
	     (if (file-exists? output-1) 
		 (delete-file output-1))
	     (set! (thread-output) (make-sample->file output-1 channels data-format header-type comment))
	     (set! (mus-safety (thread-output)) output-safety)
	     (if thread-reverb
		 (begin
		   (if (file-exists? reverb-1) 
		       (delete-file reverb-1))
		   (set! (thread-reverb) (make-sample->file reverb-1 reverb-channels data-format header-type))
		   (set! (mus-safety (thread-reverb)) output-safety)))
	     (set! statistics #f)
	     ))

       (let ((start (if statistics (get-internal-real-time)))
	     (flush-reverb #f)
	     (cycles 0)
	     (revmax #f))
	 (catch 'mus-error

		(lambda ()
		  (catch 'with-sound-interrupt
			 thunk
			 (lambda args 
			   (snd-print (format #f "with-sound interrupted: ~{~A~^ ~}" (cdr args)))
			   (set! flush-reverb #t)
			   args)))

		(lambda args
		  ;; hit mus-error, for example:
		  ;;   (with-sound () (fm-violin 0 1 440 .1 :amp-env '(0 0 1 1 1 2 3 0)))

		  ;; user might have listener closed, or no listener so...
		  (display (format #f ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args)))

		  ;; now try to get something to listener, since there may be no stdout
		  (snd-print (format #f ";~%with-sound mus-error: ~{~A~^ ~}~%" (cdr args)))
		  (set! flush-reverb #t)))
		  
	 (if (and reverb 
		  (not flush-reverb)) ; i.e. not interrupted by error and trying to jump out
	     (begin
	       (if thread-reverb
		   (if (not (= (mus-safety (thread-output)) 1)) (mus-close (thread-reverb)))
		   (if reverb-to-file
		       (mus-close *reverb*)))
	       (if statistics 
		   (if (or reverb-to-file
			   (vct? reverb-1)
			   (sound-data? reverb-1)
			   (vector? reverb-1))
		       (set! revmax (maxamp reverb-1))))
	       (if (not thread-reverb)
		   (begin
		     (if reverb-to-file
			 (set! *reverb* (make-file->sample reverb-1)))
		     (apply reverb reverb-data)                                   ; here is the reverb call(!)
		     (if reverb-to-file
			 (mus-close *reverb*))
		     (if (and reverb-to-file *clm-delete-reverb*)
			 (delete-file reverb-1))))))

	 (if thread-output
	     (if (not (= (mus-safety (thread-output)) 1)) (mus-close (thread-output)))
	     (if output-to-file
		 (mus-close *output*)))

	 (let ((snd-output #f)
	       (cur-sync #f))
	   (if statistics
	       (set! cycles (/ (* 1.0 (- (get-internal-real-time) start)) internal-time-units-per-second)))

	   (if (and to-snd output-to-file)
	       (let* ((cur (find-sound output-1)))
		 (set! cur-sync (and cur (sync cur)))
		 (if cur 
		     (set! snd-output (update-sound cur))
		     (if (= header-type mus-raw)
			 (set! snd-output (open-raw-sound output-1 channels srate data-format))
			 ;; open-sound here would either ask for raw settings or use possibly irrelevant defaults
			 (set! snd-output (open-sound output-1))))
		 (set! (sync snd-output) #t)))

	   (if statistics
	       ((if (procedure? statistics) ; :statistics (lambda (str) (snd-print str)) -- intended for auto test suite
		    statistics 
		    (if to-snd 
			snd-print 
			display))
		(format #f (if (not (member data-format (list mus-bdouble mus-ldouble)))
			       "~%;~A:~%  maxamp~A:~{ ~,4F~}~%~A  compute time: ~,3F~%"
			       "~%;~A:~%  maxamp~A:~{ ~,8F~}~%~A  compute time: ~,3F~%")
			(if output-to-file
			    output-1
			    (if (vct? output-1) "vct" 
				(if (sound-data? output-1) "sound-data"
				    (if (procedure? output-1) "function" 
					(if (vector? output-1) "vector"
					    "flush")))))
			(if (or scaled-to scaled-by) 
			    " (before scaling)" 
			    "")
			(if output-to-file
			    (if to-snd
				(maxamp snd-output #t) ; this is a list of chan maxs '(.1 .2)
				(let ((lst (mus-sound-maxamp output-1)))
				  (do ((i 0 (+ i 2)))
				      ((>= i (length lst)))
				    (list-set! lst i (/ (list-ref lst i) (mus-srate))))
				  lst))
			    (if (vct? output-1)
				(list (vct-peak output-1))
				(if (sound-data? output-1)
				    (sound-data-maxamp output-1)
				    (if (vector? output-1)
					(list (maxamp output-1))
					0.0))))
			(if revmax (format #f "  rev max: ~,4F~%" revmax) "")
			cycles)))

	   (if (or scaled-to scaled-by)
	       (if output-to-file
		   (let ((scale-output (or snd-output (open-sound output-1))))
		     (if scaled-to
			 (scale-to scaled-to scale-output)
			 (if scaled-by
			     (scale-by scaled-by scale-output)))
		     (save-sound scale-output)
		     (if (not to-snd) 
			 (close-sound scale-output)))
		   (if (vct? output-1)
		       (if scaled-to
			   (let ((pk (vct-peak output-1)))
			     (if (> pk 0.0)
				 (vct-scale! output-1 (/ scaled-to pk))))
			   (vct-scale! output-1 scaled-by))
		       (if (sound-data? output-1)
			   (if scaled-to
			       (let ((pk (sound-data-peak output-1)))
				 (if (> pk 0.0)
				     (sound-data-scale! output-1 (/ scaled-to pk))))
			       (sound-data-scale! output-1 scaled-by))
			   (if (vector? output-1)
			       (if scaled-to
				   (let ((pk (maxamp output-1)))
				     (if (> pk 0.0)
					 (let ((scl (/ scaled-to pk)))
					   (do ((i 0 (+ i 1)))
					       ((= i (length output-1)))
					     (set! (output-1 i) (* scl (output-1 i)))))))
				   (do ((i 0 (+ i 1)))
				       ((= i (length output-1)))
				     (set! (output-1 i) (* scaled-by (output-1 i))))))))))

	   (if (and play output-to-file)
	       (if to-snd
		   (if *clm-player*
		       (*clm-player* snd-output)
		       (*default-player* snd-output))
		   (*default-player* output-1))) ; this was (play output-1) which could not have worked?!

	   (if (and to-snd output-to-file)
	       (begin
		 (update-time-graph snd-output)
		 (goto-listener-end)
		 (if (number? cur-sync) (set! (sync snd-output) cur-sync)))))
	 output-1))

     (lambda () 
       (set! *clm-verbose* old-verbose)
       (set! *clm-notehook* old-notehook)
       (set! (auto-update-interval) old-auto-update-interval)
       (if *reverb*
	   (begin
	     (if thread-reverb
		 (if (not (= (mus-safety (thread-reverb)) 1)) (mus-close (thread-reverb)))
		 (mus-close *reverb*))
	     (set! *reverb* old-*reverb*)))
       (if *output*
	   (begin
	     (if thread-output
		 (if (not (= (mus-safety (thread-output)) 1)) (mus-close (thread-output)))
		 (if (mus-output? *output*)
		     (mus-close *output*)))
	     (set! *output* old-*output*)))
       (set! (mus-srate) old-srate)))))


(defmacro with-sound (args . body)
  `(with-sound-helper (lambda () ,@body) ,@args))


;;; -------- with-full-sound --------

(defmacro with-full-sound (args . body)
  ;; with-sound but display full sound in Snd window
  `(let ((snd (with-sound-helper (lambda () ,@body) ,@args)))
     (set! (x-bounds *snd-opened-sound*) (list 0.0 (/ (frames *snd-opened-sound*) (srate *snd-opened-sound*))))
     (let ((mx (apply max (maxamp *snd-opened-sound* #t))))
       (if (> mx 1.0)
	 (set! (y-bounds *snd-opened-sound*) (list (- mx) mx))))
     snd))


;;; -------- with-threaded-sound --------

(defmacro with-threaded-sound (args . body)
  (if (and (provided? 'snd-threads)
	   (not (= (optimization) 0)))
      (let ((split 
	     (lambda (l n k)
	       (define (split-1 s l n i)
		 (if (null? l)
		     (reverse s)
		     (if (= i n)
			 (split-1 (cons (car l) s) (cdr l) n 1)
			 (split-1 s (cdr l) n (+ i 1)))))
	       (split-1 '() l n (- n k))))

	    (remove-output-and-reverb-args
	     (lambda (lst)
	       (let ((badarg #f)
		     (new-args '()))
		 (for-each 
		  (lambda (arg)
		    (if badarg
			(set! badarg #f)
			(if (not (member arg (list :output :reverb :revfile :reverb-data :reverb-channels)))
			    (set! new-args (cons arg new-args))
			    (set! badarg #t))))
		  lst)
		 (reverse new-args)))))

	(let ((lists '()))
	  (do ((i 0 (+ 1 i)))
	      ((= i *clm-threads*))
	    (set! lists (cons (split body *clm-threads* i) lists)))

	  (let ((new-args (remove-output-and-reverb-args args)))

	    `(with-sound-helper 
	      (lambda ()
		(let ((threads '())
		      (thread-output (make-thread-variable))
		      (thread-reverb (and *reverb* (make-thread-variable)))
		      (mix-lock (make-lock))
		      (main-output *output*)
		      (main-reverb *reverb*))

		  (set! *output* thread-output)
		  (if thread-reverb (set! *reverb* thread-reverb))
		  
		  ,@(map
		     (lambda (expr)
		       `(set! threads (cons (make-thread 
					     (lambda ()
					       (let* ((reverb-tmp (and *reverb* (snd-tempnam)))
						      (tmp (with-sound-helper 
							    (lambda ()
							      ,@expr
							      #f)
							    :thread-output thread-output
							    :thread-reverb thread-reverb
							    :output (snd-tempnam)
							    :revfile reverb-tmp
							    :to-snd #f
							    ,@new-args
							    )))
						 (grab-lock mix-lock)
						 (display (format #f "mix ~S [~D]~%" tmp (mus-safety main-output)))
						 (if (= (mus-safety main-output) 1)
						     (begin
						       (sample->file+ main-output (thread-output))
						       (mus-close (thread-output)))
						     (mus-mix main-output tmp))
						 (if *reverb*
						     (if (= (mus-safety main-output) 1)
							 (begin
							   (sample->file+ main-reverb (thread-reverb))
							   (mus-close (thread-reverb)))
							 (mus-mix main-reverb reverb-tmp)))
						 (release-lock mix-lock)
						 (delete-file tmp))))
					    threads)))
		     lists)
		  
		  (for-each 
		   (lambda (thread) 
		     (join-thread thread))
		   threads)
		  
		  (if main-reverb (set! *reverb* main-reverb))
		  (set! *output* main-output)))
	      
	      ,@args))))
      
      `(with-sound-helper
	(lambda ()
	  ,@body)
	,@args)))




;;; -------- with-temp-sound --------

(defmacro with-temp-sound (args . body)
  `(let ((old-file-name *clm-file-name*)
	 (old-to-snd *to-snd*))
     ;; with-sound but using tempnam for output (can be over-ridden by explicit :output) and does not open result in Snd
     (dynamic-wind
	 (lambda () 
	   (set! *clm-file-name* (snd-tempnam))
	   (set! *to-snd* #f))
	 (lambda ()
	   (with-sound-helper (lambda () ,@body) ,@args)) ; dynamic-wind returns this as its result
	 (lambda ()
	   (set! *to-snd* old-to-snd)
	   (set! *clm-file-name* old-file-name)))))


;;; -------- clm-load --------

(define (clm-load file . args) 
  "(clm-load file . args) loads 'file' in the context of with-sound"
  (apply with-sound-helper (lambda () (load file)) args))


;;; -------- with-mixed-sound --------

(define (with-mixed-sound-mix-info id snd)

  (define (find-if pred l)
    (cond ((null? l) #f)
	  ((pred (car l)) (car l))
	  (else (find-if pred (cdr l)))))

  (let ((all-info (sound-property 'with-mixed-sound-info snd)))
    ;; each entry is '(mx-id beg chans note)
    (find-if (lambda (info)
	       (and (>= id (car info))
		    (< id (+ (car info) (caddr info)))))
	     all-info)))

(defmacro with-mixed-sound (args . body)
  `(let* ((output (with-sound-helper (lambda () #f) ,@args :to-snd #t)) ; pick up args for output
	  (outsnd (find-sound output)))

     (if (sound? outsnd)
	 (let ((mix-info '())
	       (old-sync (sync outsnd)))

	   ;; if multichannel output, make sure cross-chan mixes move together 
	   (if (> (channels outsnd) 1)
	       (begin
		 (reset-hook! mix-release-hook)
		 (add-hook! mix-release-hook
			    (lambda (id samps-moved)
			      (let ((new-pos (+ samps-moved (mix-position id)))
				    (base (sync id)))
				(do ((mx (integer->mix base) (integer->mix (+ (mix->integer mx) 1))))
				    ((or (not (mix? mx))
					 (not (= (sync mx) base))))
				  (set! (mix-position mx) new-pos))
				#t)))))

	   ;; click shows the original note list entry
	   (reset-hook! mix-click-hook)
	   (add-hook! mix-click-hook
		      (lambda (id)
			(let ((info (with-mixed-sound-mix-info id outsnd)))
			  (report-in-minibuffer (format #f "mix ~A: ~A" 
						      id (or (and info
								  (cadddr info))
							     (/ (mix-position id) (* 1.0 (srate outsnd))))))
			  #t))) ; #t -> don't print the mix id in the minibuffer

	   (dynamic-wind
	       (lambda ()
		 (set! (sync outsnd) 0)
		 (do ((chan 0 (+ 1 chan)))
		     ((= chan (channels outsnd)))
		   (set! (squelch-update outsnd chan) #t)))

	       (lambda ()
		 (for-each
		  (lambda (note)
		    (let* ((snd (with-temp-sound (,@args :ignore-output #t :clipped #f) (eval (append (list (car note) 0.0) (cddr note)) (current-environment))))
			   ;; I can't immediately find a way around the "eval" 
			   (beg (floor (* (srate outsnd) (cadr note))))
			   ;; can't use seconds->samples here because the global mus-srate value might not match the local one
			   (mx (car (mix snd beg #t outsnd #f #t #t)))     ; all chans mixed, current output sound, with mixes, with auto-delete
			   (chans (mus-sound-chans snd)))
		      (set! (mix-name mx) (format #f "(~A ~A)" (car note) (cadr note)))
		      (do ((chan 0 (+ 1 chan)))
			  ((= chan chans))
			(set! (sync (integer->mix (+ (mix->integer mx) chan))) (mix->integer mx)))
		      (set! mix-info (cons (list mx beg chans note) mix-info))))
		  ',body)
		 (set! (sound-property 'with-mixed-sound-info outsnd) (reverse mix-info)))

	       (lambda ()
		 (set! (sync outsnd) old-sync)
		 (do ((chan 0 (+ 1 chan)))
		     ((= chan (channels outsnd)))
		   (set! (squelch-update outsnd chan) #f)
		   ;; fixup y bounds to show waveform unclipped
		   (let ((mx (ceiling (maxamp outsnd chan))))
		     (set! (y-bounds outsnd chan) (list (- mx) mx)))
		   ;; fixup mix tags so they overlap less often
		   (let ((mxs (mixes outsnd chan)))
		     (let ((hgt 0))
		       (for-each
			(lambda (m)
			  (set! (mix-tag-y m) hgt)
			  (set! hgt (modulo (+ hgt 30) 100)))
			mxs)))
		   (update-time-graph outsnd chan))))))
     output))

;(with-mixed-sound () (fm-violin 0 .1 440 .1) (fm-violin 1 .1 660 .1))
;(with-mixed-sound (:channels 2) (fm-violin 0 .1 440 .1 :degree 0) (fm-violin 1 .1 660 .1 :degree 45))


(define* (with-mixed-sound->notelist (output-file "temp.scm") snd)
  (let* ((outsnd (or snd (selected-sound) (car (sounds))))
	 (mix-info (sound-property 'with-mixed-sound-info outsnd)))
    (if (not mix-info)
	(throw 'no-such-mixed-sound (list "with-mixed-sound->notelist" outsnd))
	(let ((cur-mixes (mixes outsnd 0)) ; for now assume each mix is multichannel
	      (oput (open-output-file output-file)))
	  (display (format #f "(with-sound (:channels ~D)~%" (channels snd)) oput)
	  (for-each
	   (lambda (id)
	     (let ((info (with-mixed-sound-mix-info id snd)))
	       (if info
		   (let ((call (cadddr info)))
		     (if (not (= (cadr info) (mix-position id)))
			 (display (format #f "  (~A ~,3F~{ ~A~})~%"
					  (car call) 
					  (/ (mix-position id) (* 1.0 (srate snd)))
					  (cddr call))
				  oput)
			 (display (format #f "  ~A~%" call) oput)))
		   (report-in-minibuffer "can't find note associated with mix ~A" id))))
	   cur-mixes)
	  (display (format #f ")~%") oput)
	  (close-output-port oput)))))



;;; -------- with-marked-sound --------

(defmacro with-marked-sound (args . body)
  `(let ((old-notehook *clm-notehook*)
	 (mark-list '()))
     (dynamic-wind
	 (lambda ()
	   (set! *clm-notehook* (lambda (name . args)
				  (set! mark-list (cons (append (list name) args) mark-list)))))

	 (lambda ()
	   (let* ((result (with-sound-helper (lambda () ,@body) ,@args))
		  (snd (find-sound result))
		  (old-update (squelch-update snd 0)))
	     (dynamic-wind
		 (lambda ()
		   (set! (squelch-update snd 0) #t))
		 (lambda ()
		   (for-each
		    (lambda (descr)
		      (let ((m (add-mark (floor (* (srate snd) (cadr descr))) snd)))
			(set! (mark-name m) (format #f "~A ~A ~A" (car descr) (cadr descr) (caddr descr)))))
		    mark-list))
		 (lambda ()
		   (set! (squelch-update snd 0) old-update)))
	     result))
		  
	 (lambda ()
	   (set! *clm-notehook* old-notehook)))))

;;; (with-marked-sound () (do ((i 0 (+ 1 i))) ((= i 5)) (fm-violin i .1 440 .1)))



;;; -------- sound-let --------
;;;
;;; (with-sound () (sound-let ((a () (fm-violin 0 .1 440 .1))) (mus-mix "test.snd" a)))

(defmacro sound-let (snds . body) 
  `(let ((temp-files '())
	 (old-hook-list (hook->list new-sound-hook))) ; save old new-sound-hook (nested sound-lets etc)
     (begin
       (reset-hook! new-sound-hook)
       (add-hook! new-sound-hook (lambda (file)       ; save current sound-let temp file list
				   (if (string? file) ; try to ignore vcts and sound-data objects
				       (set! temp-files (cons file temp-files)))))
       (let ((val (let ,(map (lambda (arg) 
			       (if (> (length arg) 2)
				                      ; if with-sound, embed with-temp-sound
				   `(,(car arg) (with-temp-sound ,(cadr arg) ,@(cddr arg)))
				   arg))              ; else use direct (normal var in the let)
			     snds)
		    ,@body)))                         ; sound-let body
	 (for-each (lambda (file)                     ; clean up all local temps
		     (if (and (string? file)          ; is it a file? (might be a vct or sound-data object)
			      (file-exists? file))
			 (delete-file file)))
		   temp-files)
	 (reset-hook! new-sound-hook)                 ; restore old new-sound-hook (should this happen before ,@body?)
	 (if (not (null? old-hook-list))
	     (for-each (lambda (proc)
			 (add-hook! new-sound-hook proc))
		       old-hook-list))
	 val))))                                      ; return body result



;;; -------- Common Music --------

(define* (init-with-sound
	  (srate *clm-srate*) 
	  (output *clm-file-name*) 
	  (channels *clm-channels*)
	  (header-type *clm-header-type*)
	  (data-format *clm-data-format*)
	  (comment #f)
	  ;(verbose *clm-verbose*) ; why is this commented out?
	  (reverb *clm-reverb*)
	  (revfile "test.rev")
	  (reverb-data *clm-reverb-data*)
	  (reverb-channels *clm-reverb-channels*)
	  (continue-old-file #f)
	  (statistics *clm-statistics*)
	  (scaled-to #f)
	  (play *clm-play*)
	  (to-snd *to-snd*)
	  (scaled-by #f))
  "(init-with-sound . args) is the first half of with-sound; it sets up the CLM output choices, reverb, etc. Use \
finish-with-sound to complete the process."
  (let ((old-srate (mus-srate))
	(start (if statistics (get-internal-real-time)))
	(output-to-file (string? output))
	(reverb-to-file (and reverb (string? revfile))))
    (if output-to-file
	(if continue-old-file
	    (begin
	      (set! *output* (continue-sample->file output))
	      (set! (mus-srate) (mus-sound-srate output))
	      (let ((ind (find-sound output)))
		(if (sound? ind)
		    (close-sound ind))))
	    (begin
	      (if (file-exists? output) 
		  (delete-file output))
	      (set! *output* (make-sample->file output channels data-format header-type comment))))
	(begin
	  (if (not continue-old-file)
	      (if (or (vct? output)
		      (sound-data? output)
		      (vector? output))
		  (fill! output 0.0)))
	  (set! *output* output)))

    (if reverb
	(if reverb-to-file
	    (if continue-old-file
		(set! *reverb* (continue-sample->file revfile))
		(begin
		  (if (file-exists? revfile) 
		      (delete-file revfile))
		  (set! *reverb* (make-sample->file revfile reverb-channels data-format header-type))))
	    (begin
	      (if (not continue-old-file)
		  (if (or (vct? revfile)
			  (sound-data? revfile)
			  (vector? revfile))
		      (fill! revfile 0.0)))
	      (set! *reverb* revfile))))

    (list 'with-sound-data
	  output
	  reverb
	  revfile
	  old-srate
	  statistics
	  to-snd
	  scaled-to
	  scaled-by
	  play
	  reverb-data
	  start)))

(define (finish-with-sound wsd)
  "(finish-with-sound wsd) closes the notelist process started by init-with-sound"
  (if (eq? (car wsd) 'with-sound-data)
      (let ((cycles 0)
	    (output (list-ref wsd 1))
	    (reverb (list-ref wsd 2))
	    (revfile (list-ref wsd 3))
	    (old-srate (list-ref wsd 4))
	    (statistics (list-ref wsd 5))
	    (to-snd (list-ref wsd 6))
	    (scaled-to (list-ref wsd 7))
	    (scaled-by (list-ref wsd 8))
	    (play (list-ref wsd 9))
	    (reverb-data (list-ref wsd 10))
	    (start (list-ref wsd 11)))

	(if reverb
	    (begin
	      (mus-close *reverb*)
	      (if (string? revfile)
		  (set! *reverb* (make-file->sample revfile))
		  (set! *reverb* revfile))
	      (apply reverb reverb-data)
	      (mus-close *reverb*)))
	(if (mus-output? *output*)
	    (mus-close *output*))

	(if statistics
	    (set! cycles (/ (- (get-internal-real-time) start) 100)))
	(if (and to-snd (string? output))
	    (let ((snd-output (open-sound output)))
	      (set! (sync snd-output) #t)
	      (if statistics
		  (snd-print 
		   (format #f "~A:~%  maxamp: ~A,~%  compute time: ~A~%"
			   output
			   (maxamp snd-output #t)
			   cycles)))
		 (if (or scaled-to scaled-by)
		     (begin
		       (if scaled-to
			   (scale-to scaled-to snd-output)
			   (if scaled-by
			       (scale-by scaled-by snd-output)))
		       (save-sound snd-output)))
	      (if play (*default-player* snd-output))
	      (update-time-graph snd-output)))
	(set! (mus-srate) old-srate)
	output)
      (throw 'wrong-type-arg
	     (list "finish-with-sound" wsd))))


(define wsdat-play ; for cm
  (make-procedure-with-setter
   (lambda (w)
     "accessor for play field of init-with-sound struct"
     (list-ref w 9))
   (lambda (w val)
     (list-set! w 9 val))))


;;; -------- with-sound save state --------

(define (ws-save-state filename)
  "(ws-save-state filename) is an after-save-state-hook function that saves the current with-sound global settings"

  (define (open-appending filename)
    (open-output-file filename "a"))

  (define (close-appending fd)
    (close-output-port fd))

  (let ((fd (open-appending filename)))
    ;; fd is a Scheme port at this point (not an integer), so we can use format etc
    ;; should the save-state file load this file if it hasn't been loaded? (what path?)
    (format fd "~%~%;;; from ws.scm~%")
    (format fd "(if (defined? '*clm-srate*)~%")
    (format fd "    (begin~%")
    (format fd "      (set! *clm-srate* ~A)~%" *clm-srate*)
    (format fd "      (set! *clm-file-name* ~S)~%" *clm-file-name*)
    (format fd "      (set! *clm-channels* ~A)~%" *clm-channels*)
    (format fd "      (set! *clm-data-format* ~A)~%" (mus-data-format->string *clm-data-format*))
    (format fd "      (set! *clm-header-type* ~A)))~%" (mus-header-type->string *clm-header-type*))
    (close-appending fd)))

(add-hook! after-save-state-hook ws-save-state)


;;; -------- ->frequency --------

(define ->frequency
  (let ((main-pitch (/ 440.0 (expt 2.0 (/ 57 12)))) ; a4 = 440Hz is pitch 57 in our numbering
	(last-octave 0)                             ; octave number can be omitted
	(ratios (vector 1.0 256/243 9/8 32/27 81/64 4/3 1024/729 3/2 128/81 27/16 16/9 243/128 2.0)))
    (lambda* (pitch pythagorean)          ; pitch can be pitch name or actual frequency
      "(->frequency pitch pythagorean) returns the frequency (Hz) of the 'pitch', a CLM/CM style note name as a \
symbol: 'e4 for example.  If 'pythagorean', the frequency calculation uses small-integer ratios, rather than equal-tempered tuning."
      (if (symbol? pitch)
	  (let* ((name (string-downcase (symbol->string pitch)))
		 (base-char (string-ref name 0))
		 (sign-char (and (> (string-length name) 1)
				 (not (char-numeric? (string-ref name 1)))
				 (not (char=? (string-ref name 1) #\n))
				 (string-ref name 1)))
		 (octave-char (if (and (> (string-length name) 1)
				       (char-numeric? (string-ref name 1))) 
				  (string-ref name 1)
				  (if (and (> (string-length name) 2) 
					   (char-numeric? (string-ref name 2)))
				      (string-ref name 2)
				      #f)))
		 (base (modulo (+ 5 (- (char->integer base-char) (char->integer #\a))) 7)) ; c-based (diatonic) octaves
		 (sign (if (not sign-char) 0 (if (char=? sign-char #\f) -1 1)))
		 (octave (if octave-char (- (char->integer octave-char) (char->integer #\0)) last-octave))
		 (base-pitch (+ sign (case base ((0) 0) ((1) 2) ((2) 4) ((3) 5) ((4) 7) ((5) 9) ((6) 11))))
		 (et-pitch (+ base-pitch (* 12 octave))))
	    (set! last-octave octave)
	    (if pythagorean
		(* main-pitch (expt 2 octave) (ratios base-pitch))
		(* main-pitch (expt 2.0 (/ et-pitch 12)))))
	  pitch))))


;;; -------- ->sample --------

(define (->sample beg)
  "(->sample time-in-seconds) -> time-in-samples"
  (round (* (if (not (null? (sounds))) (srate) (mus-srate)) beg)))



;;; -------- defgenerator --------

;;;  :(defgenerator (osc :make-wrapper (lambda (gen) (set! (osc-freq gen) (hz->radians (osc-freq gen))) gen)) freq phase)
;;;  #<unspecified>
;;;  :(define hi (make-osc 440.0 0.0))
;;;  #<unspecified>
;;;  :hi
;;;  (osc 0.125378749798983 0.0)

;;; besides setting up the list accessors, the make function, and the type predicate, defgenerator
;;;   calls add-clm-field to tell run the type of each list element (only actually needed if
;;;   there are different types in use)
;;; it also adds the built-in methods mus-name, mus-reset, mus-run, and mus-describe (if they don't already exist), and
;;;   mus-frequency if a "frequency" field exists (treated as radians)
;;;   mus-phase if a "phase" or "angle" field exists
;;;   mus-scaler if "r" or "amplitude",
;;;   mus-order if "n" or "order"
;;;   mus-offset if "ratio" (mimics nrxy*)

(define (find-if pred l)
  (cond ((null? l) #f)
	((pred (car l)) (car l))
	(else (find-if pred (cdr l)))))

(defmacro defgenerator (struct-name . fields)
  (let* ((name (if (list? struct-name) (car struct-name) struct-name))

	 (wrapper (or (and (list? struct-name)
			   (or (and (> (length struct-name) 2)
				    (equal? (struct-name 1) :make-wrapper)
				    (struct-name 2))
			       (and (= (length struct-name) 5)
				    (equal? (struct-name 3) :make-wrapper)
				    (struct-name 4))))
		      (lambda (gen) gen)))

	 (sname (if (string? name) name (symbol->string name)))

	 (field-names (map (lambda (n)
			     (symbol->string (if (list? n) (car n) n)))
			   fields))

	 (field-types (map (lambda (n)
			     (if (and (list? n) (cadr n) (eq? (cadr n) :type)) 
				 (snd-error (format #f ":type indication for defgenerator (~A) field (~A) should be after the default value" name n)))
			     (if (and (list? n)
				      (= (length n) 4)
				      (eq? (n 2) :type))
				 (n 3)
				 (if (and (list? n)
					  (= (length n) 2))
				     (if (number? (cadr n))
					 (if (rational? (cadr n))
					     'int
					     'float)
					 (if (string? (cadr n))
					     'string
					     (if (char? (cadr n))
						 'char
						 (if (or (equal? (cadr n) #t)
							 (equal? (cadr n) #f))
						     'boolean
						     'float))))
				     'float)))
			   fields))

	 (original-methods (or (and (list? struct-name)
				    (or (and (> (length struct-name) 2)
					     (equal? (struct-name 1) :methods)
					     (struct-name 2))
					(and (= (length struct-name) 5)
					     (equal? (struct-name 3) :methods)
					     (struct-name 4))))
			       (list)))

	 (method-exists? (lambda (method)
			   (and (not (null? original-methods))
				(find-if (lambda (g)
					   (and (list? g)
						(list? (cadr g))
						(eq? (car (cadr g)) method)))
					 (cdr original-methods)))))

	 (phase-field-name (and (not (method-exists? 'mus-phase))
				(let ((fld (find-if (lambda (name) 
						      (or (string=? name "phase") 
							  (string=? name "angle")))
						    field-names)))
				  (and fld (string-append "-" fld)))))

	 (frequency-field-name (and (not (method-exists? 'mus-frequency))
				    (find-if (lambda (name) 
					       (string=? name "frequency"))
					     field-names)
				    "-frequency"))

	 (offset-field-name (and (not (method-exists? 'mus-offset))
				 (find-if (lambda (name) 
					    (string=? name "ratio"))
					  field-names)
				 "-ratio"))

	 (scaler-field-name (and (not (method-exists? 'mus-scaler))
				 (let ((fld (find-if (lambda (name) 
						       (or (string=? name "r")
							   (string=? name "amplitude")))
						     field-names)))
				   (and fld (string-append "-" fld)))))

	 (order-field-name (and (not (method-exists? 'mus-order))
				(let ((fld (find-if (lambda (name) 
						      (or (string=? name "n") 
							  (string=? name "order")))
						    field-names)))
				  (and fld (string-append "-" fld)))))

	 ;; using append to splice out unwanted entries
	 (methods `(append ,original-methods
			   
			   (if ,phase-field-name
			       (list 
				(list 'mus-phase
				      (lambda (g)
					(,(string->symbol (string-append sname (or phase-field-name "oops"))) g))
				      (lambda (g val)
					(set! (,(string->symbol (string-append sname (or phase-field-name "oops"))) g) val))))
			       (list))
			   
			   (if ,frequency-field-name
			       (list 
				(list 'mus-frequency
				      (lambda (g)
					(radians->hz (,(string->symbol (string-append sname (or frequency-field-name "oops"))) g)))
				      (lambda (g val)
					(set! (,(string->symbol (string-append sname (or frequency-field-name "oops"))) g) (hz->radians val))
					val)))
			       (list))
			   
			   (if ,offset-field-name
			       (list 
				(list 'mus-offset
				      (lambda (g)
					(,(string->symbol (string-append sname (or offset-field-name "oops"))) g))
				      (lambda (g val)
					(set! (,(string->symbol (string-append sname (or offset-field-name "oops"))) g) val)
					val)))
			       (list))
			   
			   (if ,order-field-name
			       (list  ; not settable -- maybe use mus-length?
				(list 'mus-order
				      (lambda (g)
					(,(string->symbol (string-append sname (or order-field-name "oops"))) g))))
			       (list))
			   
			   (if ,scaler-field-name
			       (list 
				(list 'mus-scaler
				      (lambda (g)
					(,(string->symbol (string-append sname (or scaler-field-name "oops"))) g))
				      (lambda (g val)
					(set! (,(string->symbol (string-append sname (or scaler-field-name "oops"))) g) val))))
			       (list))
			   
			   (if ,(not (method-exists? 'mus-describe))
			       (list 
				(list 'mus-describe
				      (lambda (g)
					(let ((desc (mus-name g))
					      (first-time #t))
					  (for-each
					   (lambda (field)
					     (set! desc (string-append desc 
								       (format #f "~A~A: ~A"
									       (if first-time " " ", ")
									       field
									       (if (string=? field "frequency")
										   (radians->hz ((symbol->value (string->symbol (string-append ,sname "-" field))) g))
										   ((symbol->value (string->symbol (string-append ,sname "-" field))) g)))))
					     (set! first-time #f))
					   (list ,@field-names))
					  desc))))
			       (list))
			   
			   (if ,(not (method-exists? 'mus-run))
			       (list
				(list 'mus-run
				      (lambda (g arg1 arg2)
					(,(string->symbol sname) g arg1)))) ; this assumes the run-time function takes two args
			       (list))
			   
			   (if ,(not (method-exists? 'mus-reset))
			       (list 
				(list 'mus-reset
				      (lambda (g)
					(for-each
					 (lambda (name type orig)
					   (if (or (not (string=? type "clm"))
						   (not ((symbol->value (string->symbol (string-append ,sname "-" name))) g)))
					       (set! ((string->symbol (string-append ,sname "-" name)) g) orig)
					       (mus-reset ((symbol->value (string->symbol (string-append ,sname "-" name))) g))))
					 (list ,@field-names)
					 (list ,@(map symbol->string field-types))
					 (list ,@(map (lambda (n)
							(if (and (list? n)
								 (>= (length n) 2))
							    (cadr n)
							    0.0))
						      fields))))))
			       (list))
			   
			   (if ,(not (method-exists? 'mus-name))
			       (list 
				(list 'mus-name
				      (lambda (g) 
					,sname)
				      (lambda (g new-name)
					(set-car! (cdr (assoc 'mus-name (g (- (length g) 1))))
						  (lambda (g) 
						    new-name))))) ; depend on closures?
			       (list)))))
    
    `(begin
       (define ,(string->symbol (string-append sname "?"))
	 (lambda (obj)
	   (and (list? obj)
		(eq? (car obj) ',(string->symbol sname)))))

       (define ,(string->symbol (string-append sname "-methods"))
	 (lambda ()
	   ,methods))

       (define* (,(string->symbol (string-append "make-" sname))
		 ,@(map (lambda (n)
			  (if (and (list? n)
				   (>= (length n) 2))
			      (list (car n) (cadr n))
			      (list n 0.0)))
			fields))
	 (,wrapper (if (list? ,methods)
		       (list ',(string->symbol sname)
			     ,@(map string->symbol field-names)
			     ,methods)
		       (list ',(string->symbol sname)
			     ,@(map string->symbol field-names)))))

       ,@(map (let ((ctr 1))
		(lambda (n type)
		  (let ((val `(define ,(string->symbol (string-append sname "-" n))
				(make-procedure-with-setter
				 (lambda (arg)
				   "generator field accessor"
				   (arg ,ctr))
				 (lambda (arg val)
				   (list-set! arg ,ctr val))))))
		    (add-clm-field sname (string-append sname "-" n) ctr type)
		    (set! ctr (+ 1 ctr))
		    val)))
	      field-names field-types))))


(define def-clm-struct defgenerator)



;;; -------- clm-display-globals --------
;;;
;;; display all the globals that might affect with-sound unexpectedly

(define (clm-display-globals)

  (format #f ";CLM globals:~%;  *clm-srate*: ~A (default: ~A, mus-srate: ~A)~%;  *clm-file-name*: ~A~%;  *clm-channels: ~A (default: ~A)~%;  *clm-data-format*: ~A (default: ~A)~%;  *clm-header-type*: ~A (default: ~A)~%;  *clm-reverb-channels*: ~A, *clm-reverb-data*: ~A~%;  *clm-table-size*: ~A~%;  *clm-file-buffer-size*: ~A (~A)~%;  *clm-locsig-type*: ~A~%;  *clm-array-print-length*: ~A (~A)~%;  *clm-notehook*: ~A~%;  *clm-default-frequency*: ~A~%;  *clm-clipped*: ~A, mus-clipping: ~A, mus-prescaler: ~A~%;  *clm-threads*: ~A~%;  *clm-output-safety*: ~A~%~%"

	  *clm-srate* (default-output-srate) (mus-srate)
	  *clm-file-name*
	  *clm-channels* (default-output-chans)
	  (mus-data-format->string *clm-data-format*) (mus-data-format->string (default-output-data-format))
	  (mus-header-type->string *clm-header-type*) (mus-header-type->string (default-output-header-type))
	  *clm-reverb-channels* *clm-reverb-data*
	  *clm-table-size*
	  *clm-file-buffer-size* (mus-file-buffer-size)
	  *clm-locsig-type*
	  *clm-array-print-length* (print-length)
	  *clm-notehook*
	  *clm-default-frequency*
	  *clm-clipped* (mus-clipping)
	  (mus-prescaler)
	  *clm-threads*
	  *clm-output-safety*))




;;; -------- with-threaded-channels

(define (with-threaded-channels snd func)
  (let ((chns (channels snd)))
    (if (and (provided? 'snd-threads)
	     (> chns 1))
	
	(dynamic-wind

	 (lambda ()
	   (do ((chn 0 (+ 1 chn)))
	       ((= chn chns))
	     (set! (squelch-update snd chn) #t)))
	   
	 (lambda ()
	   (let ((threads '()))
	     (do ((chn 0 (+ 1 chn)))
		 ((= chn chns))
	       (let ((lchn chn))
		 (set! threads (cons (make-thread (lambda () 
						    (func snd lchn))) 
				     threads))))
	     (for-each 
	      (lambda (expr) 
		(join-thread expr))
	      threads)))

	 (lambda ()
	   (do ((chn 0 (+ 1 chn)))
	       ((= chn chns))
	     (set! (squelch-update snd chn) #f))))

	;; else do it without threads
	(do ((chn 0 (+ 1 chn)))
	    ((= chn chns))
	  (func snd chn)))))


;;; -------- *clm-search-list*

;;; PERHAPS: doc/test *clm-search-list*, and use to choose input/output loc?

(define *clm-search-list* (list "."))

(define (clm-find-file name)
  (if (file-exists? name)
      name
      (call-with-exit
       (lambda (return)
	 (for-each
	  (lambda (path)
	    (let ((len (string-length path)))
	      (if (> len 0)
		  (let ((new-name (string-append path (if (not (char=? (path (- len 1)) #\/)) "/" "") name)))
		    (if (file-exists? new-name)
			(return new-name))))))
	  *clm-search-list*)
	 #f))))

#|
(with-sound ()
  (let ((fd (make-file->sample "oboe.snd"))
	(len (mus-sound-frames "oboe.snd")))
    (run
     (lambda ()
       (do ((i 0 (+ i 1)))
	   ((= i len))
	 (outa i (* .5 (file->sample fd i 0))))))))
|#


(define (mix-notelists . notelists)
  ;; assume the 2nd parameter is the begin time in seconds (the 1st is the instrument name)
  (sort! 
   (apply append notelists)
   (lambda (note1 note2)
     (< (cadr note1) (cadr note2)))))

#|
(mix-notelists '((fm-violin 0 1 440 .1)
		 (fm-violin 1 1 550 .1))
	       '((bird 0 .1 )
		 (bird .2 .1)
		 (bird 1.2 .3)
		 (bird .5 .5)))
((bird 0 0.1) (fm-violin 0 1 440 0.1) (bird 0.2 0.1) (bird 0.5 0.5) (fm-violin 1 1 550 0.1) (bird 1.2 0.3))
|#


(define* (with-simple-sound-helper thunk (output "test.snd") (channels 1) (srate 44100) (data-format mus-lfloat) (header-type mus-next))
  (let ((old-output *output*))
    (dynamic-wind
	(lambda ()
	  (set! *output* (make-sample->file output channels data-format header-type "with-simple-sound output")))
	(lambda ()
	  (thunk)
	  output)
	(lambda ()
	  (mus-close *output*)
	  (set! *output* old-output)))))

(defmacro with-simple-sound (args . body)
  `(with-simple-sound-helper (lambda () ,@body) ,@args))
