;;; Utilities for generating sound
;;;
;;; samples are values from -1 to 1.
;;; almost all times are given as frequencies.
;;;
;;; oscillator functions are supposed to produce one full cycle on the
;;; input range [-1, 1[.
;;; 
;;; sound streams are modelled as generators: they are functions that
;;; produce the next sample when called.
;;;
;;; frequency streams are generators but produce frequencies instead of
;;; samples when called.
;;;
;;; in a few places, intervals are used.  These are given as fractions
;;; of octaves; that is, 1 means one octave up, -1 means one octave
;;; down, 7/12 means (approximately) a fifth.

;; constants

(define *display-width* 75)
(define *sample-rate* 44100)
(define *lowest-audible-hz* 100)
(define (freq->oscillator-delta f) (/ f *sample-rate*))
(define (freq->inexact-samples f) (/ *sample-rate* f))
(define (freq->samples f) (inexact->exact (floor (freq->inexact-samples f))))
(define (time->samples t) (inexact->exact (floor (* t *sample-rate*))))

(define *pi* (acos -1))

;; helpers

(define (interpolate weight s1 s2)
  (+ (* s1 (- 1 weight)) (* s2 weight)))

;; memories, used for delays and filters

(define (make-memory maxsize)
  (let ((memory (make-vector maxsize))
	(learn-index 1)
	(forget-index 0))

    (define (range idx) (modulo idx maxsize))
    (define (memlen) (range (- learn-index forget-index)))

    (define (learn! sample)
      (vector-set! memory learn-index sample)
      (set! learn-index (range (+ learn-index 1)))
      (if (= learn-index forget-index) (forget!)))

    (define (forget!)
      (let ((new-forget-index (range (+ forget-index 1)))
	    (val (vector-ref memory forget-index)))
	(if (= learn-index new-forget-index) #f
	  (begin
	    (set! forget-index new-forget-index)
	    val))))

    (define (relearn!)
      (let ((relearn-index (range (- forget-index 1))))
	(if (= learn-index relearn-index) #f
	  (begin
	    (set! forget-index relearn-index)
	    (vector-ref memory relearn-index)))))

    (define (peek n)
      (vector-ref memory (range (+ forget-index n))))

    (vector-fill! memory 0)
    (values memlen learn! forget! relearn! peek)))

;; oscillator functions

(define (osc-range x)
  (let ((modulus (- x (* 2 (floor (/ x 2))))))
    (if (> modulus 1) (- modulus 2) modulus)))

(define osc-sawtooth osc-range)

(define (osc-triangle x)
  (let ((x (osc-range x)))
    (cond ((> x 0) (osc-sawtooth (- (* x 2) 1)))
	  ((< x 0) (osc-sawtooth (- 1 (* x 2))))
	  (else -1))))

(define (osc-sine x) (sin (* x *pi*)))

;; other oscillators

(define (var-pulse fstream widthstream)
  (let ((curval 0))
    (lambda ()
      (set! curval (+ curval (freq->oscillator-delta (fstream))))
      (if (< (osc-range curval) (widthstream)) -1 1))))

(define (pulse flength)
  (let ((samples (freq->samples flength))
	(done 0))
    (lambda ()
      (set! done (+ done 1))
      (if (> done samples) 0 1))))

(define (natural-oscillator freq fadeoff stream)
  (let* ((x 0)
	 (dx 0)
	 (i-fact (/ (freq->inexact-samples freq) (* 2 *pi*)))
	 (f-fact (- 1 (freq->oscillator-delta fadeoff))))
    (lambda ()
      (set! dx (+ (* dx f-fact) (/ (- (stream) x) i-fact)))
      (set! x (+ x (/ dx i-fact)))
      x)))

;; basic stuff

(define (const->stream x) (lambda () x))
(define co const->stream)

(define (osc->stream osc fstream)
  (let ((curval 0))
    (lambda ()
      (set! curval (+ curval (freq->oscillator-delta (fstream))))
      (osc curval))))

(define (sinewave fstream) (osc->stream osc-sine fstream))
(define (sawtooth fstream) (osc->stream osc-sawtooth fstream))
(define (triangle fstream) (osc->stream osc-triangle fstream))

(define (mix stream1 stream2)
  (lambda () (+ (stream1) (stream2))))

(define (scale stream1 stream2)
  (lambda () (* (stream1) (stream2))))

(define (stream->fstream bfreq interval stream)
    (lambda () (* bfreq (expt 2 (* interval (stream))))))
(define fs stream->fstream)

(define (invert stream) (lambda () (- (stream))))
(define (sinify stream) (lambda () (osc-sine (stream))))

;; sync oscillators

(define (osc->stream/hardsync osc fstream master)
  (let ((curval 0)
	(master-last 0))
    (lambda ()
      (let ((master-new (master)))
	(if (and (< master-last 0) (>= master-new 0))
	  (set! curval 0)
	  (set! curval (+ curval (freq->oscillator-delta (fstream)))))
	(set! master-last master-new)
	(osc curval)))))

(define (osc->stream/softsync osc fstream master)
  (let ((curval 0))
    (lambda ()
      (let ((m (master))
	    (delta (freq->oscillator-delta (fstream))))
	(set! curval (if (< m 0) (- curval delta) (+ curval delta)))
	(osc curval)))))

(define (osc->stream/phaseshift osc fstream master)
  (let ((curval 0))
    (lambda ()
      (set! curval (+ curval (freq->oscillator-delta (fstream))))
      (osc (+ curval (master))))))

;; teeing signal

(define (stream->knot stream)
  (let ((master #f)
	(value 0))
    (lambda (reader)
      (if (eq? reader master) (set! value (stream)))
      (if (not master) (set! master reader))
      value)))

(define (knot->stream knot)
  (let ((id (gensym)))
    (lambda () (knot id))))

;; delay and echo

(define (adjust-by-actions amount increaser decreaser)
  (define (repeat n fn)
    (if (> n 0) (begin (fn) (repeat (- n 1) fn))))
  (if (> amount 0)
    (repeat amount increaser)
    (repeat (- amount) decreaser)))

(define (dyn-delay minfreq stream fstream)
  (call-with-values
    (lambda () (make-memory (freq->samples minfreq)))
    (lambda (memlen put! pop! unpop! peek)

      (define (adjust-delay samples)
	(adjust-by-actions (- samples (memlen)) unpop! pop!))

      (lambda ()
	(let* ((freq (max minfreq (fstream)))
	       (samples (freq->samples freq))
	       (rest (- (freq->inexact-samples freq) samples)))
	  (put! (stream))
	  (adjust-delay samples)
	  (interpolate rest (peek 0) (peek -1)))))))

(define (dyn-echo minfreq stream fstream envstream)
  (letrec ((signal (lambda () (+ (stream) (* (delayed) (envstream)))))
	   (knot (stream->knot signal))
	   (delayed (dyn-delay minfreq (knot->stream knot) fstream))
	   (output (knot->stream knot)))
    output))

;; filters

(define (add-to-average avg n val) (/ (+ val (* avg n)) (+ n 1)))
(define (sub-from-average avg n val) (/ (- (* avg n) val) (- n 1)))

(define (low-pass stream fstream)
  (let ((dynamic-average 0))
    (call-with-values
      (lambda () (make-memory (freq->samples *lowest-audible-hz*)))
      (lambda (memlen put! pop! unpop! peek)

	(define (learn! sample)
	  (set! dynamic-average
	    (add-to-average dynamic-average (memlen) sample))
	  (put! sample))

	(define (forget!)
	  (let* ((len (memlen))
		 (val (pop!)))
	    (if val
	      (set! dynamic-average
		(sub-from-average dynamic-average len val)))))

	(define (relearn!)
	  (let* ((len (memlen))
		 (val (unpop!)))
	    (if val
	      (set! dynamic-average
		(add-to-average dynamic-average len val)))))

	(define (adjust-filter samples)
	  (adjust-by-actions (- samples (memlen)) relearn! forget!))

	(lambda ()
	  (learn! (stream))
	  (adjust-filter (freq->samples (max *lowest-audible-hz* (fstream))))
	  dynamic-average)))))

(define (high-pass stream fstream)
  (let* ((knot (stream->knot stream))
	 (fknot (stream->knot fstream))
	 (filtered (low-pass (knot->stream knot) (knot->stream fknot)))
	 (fstream2 (knot->stream fknot))
	 (delstream (lambda () (* 2 (fstream2))))
	 (delayed (dyn-delay *lowest-audible-hz*
			     (knot->stream knot) delstream)))
    (lambda () (- (delayed) (filtered)))))

(define (band-pass stream fstream interval-stream)
  (let* ((fknot (stream->knot fstream))
	 (iknot (stream->knot interval-stream))
	 (fstream1 (knot->stream fknot))
	 (istream1 (knot->stream iknot))
	 (hp-fstream (lambda () (/ (fstream1) (expt 2 (istream1)))))
	 (fstream2 (knot->stream fknot))
	 (istream2 (knot->stream iknot))
	 (lp-fstream (lambda () (* (fstream2) (expt 2 (istream2)))))
	 (filtered (high-pass (low-pass stream lp-fstream) hp-fstream)))
    filtered))

;; testing

(define (show-sample s)
  (if (< s -1) (begin (display #\#) (newline))
    (begin (display #\space)
	   (show-sample (- s (/ 2 *display-width*))))))

(define (show n stream)
  (if (< n 1) (newline)
    (begin
      (show-sample (stream))
      (show (- n 1) stream))))

(define (stream->16bit stream)
  (lambda ()
    (let ((val (inexact->exact (floor (* 32768 (+ 1 (stream)))))))
      (cond ((< val 0) 0)
	    ((> val 65535) 65535)
	    (else val)))))

(define (write-stream t stream port)
  (let ((input (stream->16bit stream))
	(output port))
    (let loop ((samples (time->samples t)))
      (if (> samples 0)
	(let ((word (input)))
	  (write-byte (logand word 255) output)
	  (write-byte (ash word -8) output)
	  (loop (- samples 1)))))))

(define (play t stream)
  (write-stream
    t stream
    (open-output-process-port
      `(play "-t" raw "-c" 1 "-f" u "-s" w "-r" ,*sample-rate* "-"))))

(define (op-stream t stream)
  (write-stream t stream (current-output-port)))