#lang racket
(require "rsound.rkt"
"fft.rkt"
"integral-cycles.rkt"
"wavetable.rkt"
"network.rkt"
racket/flonum
racket/fixnum
ffi/vector
(for-syntax syntax/parse))
(provide rs-map
rs-map/idx
rs-scale
resample
resample/interp
clip
rs-mult
twopi
sine-wave
sawtooth-wave
approx-sawtooth-wave
square-wave
harm3-wave
pulse-wave
noise
rearrange
thresh
fader
frisellinator
dc-signal
signal-*s
signal-+s
signal-*
signal-+
thresh/signal
mono
indexed-signal
signal-scale
clip&volume
rsound->signal/left
rsound->signal/right
rs-largest-sample
make-tone
make-pulse-tone
wavefun->tone-maker
ding
make-ding
split-in-4
times
rs-overlay*
rs-overlay
vectors->rsound
tile-to-len
fader-snd
rsound-fft/left
rsound-fft/right
rsound-maximize-volume
midi-note-num->pitch
raw-sawtooth-wave
binary-logn
)
(define twopi (* 2 pi))
(define (rs-map fun sound)
(rs-map/idx (lambda (s i) (fun s)) sound))
(define (rs-map/idx fun sound)
(define left
(indexed-signal (lambda (i) (fun (rs-ith/left sound i) i))))
(define right
(indexed-signal (lambda (i) (fun (rs-ith/right sound i) i))))
(parameterize ([default-sample-rate (rsound-sample-rate sound)])
(signals->rsound (rs-frames sound)
left
right)))
(define (rs-scale scalar rsound)
(rs-map (lambda (x) (* x scalar)) rsound))
(define (clip sound start finish)
(unless (rsound? sound)
(raise-type-error 'rsound-clip "rsound" 0 sound start finish))
(unless (nonnegative-integer? start)
(raise-type-error 'rsound-clip "non-negative integer" 1 sound start finish))
(unless (nonnegative-integer? finish)
(raise-type-error 'rsound-clip "non-negative integer" 2 sound start finish))
(unless (and (<= 0 start finish (rs-frames sound)))
(error 'clip
frames-out-of-range-msg
start finish (rs-frames sound)))
(match-define (rsound data old-start old-stop sample-rate) sound)
(rsound data
(+ old-start (i2e start))
(+ old-start (i2e finish)) sample-rate))
(define frames-out-of-range-msg
(string-append "must have 0 < start < end < frames. "
"You provided start ~s and end ~s for a sound with ~s frames."))
(define (resample factor sound)
(define left
(indexed-signal
(lambda (i)
(rs-ith/left sound
(inexact->exact (floor (* factor i)))))))
(define right
(indexed-signal
(lambda (i) (rs-ith/right sound
(inexact->exact (floor (* factor i)))))))
(parameterize ([default-sample-rate
(rsound-sample-rate sound)])
(signals->rsound (inexact->exact
(floor (/ (rs-frames sound) factor)))
left
right)))
(define (resample/interp factor sound)
(define new-sound-len
(inexact->exact (floor (/ (rs-frames sound) factor))))
(define (the-sig extractor)
(lambda (i)
(define virtual-source-sample (min (sub1 (rs-frames sound))
(* factor i)))
(define lower-index (inexact->exact (floor virtual-source-sample)))
(define fractional-part (- virtual-source-sample lower-index))
(cond [(= fractional-part 0) (extractor sound lower-index)]
[else (+ (* (- 1.0 fractional-part) (extractor sound lower-index))
(* fractional-part (extractor sound (add1 lower-index))))])))
(define left
(indexed-signal (the-sig rs-ith/left)))
(define right
(indexed-signal (the-sig rs-ith/right)))
(parameterize ([default-sample-rate
(rsound-sample-rate sound)])
(signals->rsound new-sound-len
left
right)))
(define (rs-mult a b)
(define len1 (rs-frames a))
(define len2 (rs-frames b))
(define new-snd
(parameterize ([default-sample-rate
(rsound-sample-rate a)])
(silence len1)))
(for ([i (in-range (min len1 len2))])
(set-rs-ith/left/s16! new-snd
i
(inexact->exact
(floor
(* (rs-ith/left/s16 a i)
(rs-ith/left b i)))))
(set-rs-ith/right/s16! new-snd
i
(inexact->exact
(floor
(* (rs-ith/right/s16 a i)
(rs-ith/right b i))))))
new-snd)
(define (make-checked-wave-fun raw-wave-fun)
(define (raw-wave-fun/sr pitch sample-rate)
(raw-wave-fun pitch))
(let* ([table (build-wavetable raw-wave-fun/sr)]
[table-based-fun (make-table-based-wavefun table)])
(lambda (pitch)
(when (= 0 pitch)
(raise-type-error 'wave-fun "nonzero number" 0 pitch))
(cond [(integer? pitch)
(table-based-fun (inexact->exact pitch) (default-sample-rate))]
[else
(raw-wave-fun pitch)]))))
(define SR (exact->inexact (default-sample-rate)))
(define SRINV (/ 1.0 SR))
(define TPSRINV (* 2.0 pi SRINV))
(define (dc-signal volume)
(lambda () volume))
(define (indexed-signal fun)
(network ()
(idx ((simple-ctr 0 1)))
(out (fun idx))))
(define sine-wave
(network (pitch)
[angle (prev added 0.0)]
[added (angle-add angle (* pitch TPSRINV))]
[output (sin angle)]))
(define harm3-wave
(network (pitch)
(ctr ((simple-ctr 0 SRINV)))
(out (+ (sin (* twopi pitch ctr))
(* 0.5 (sin (* twopi 2.0 pitch ctr)))
(* 0.25 (sin (* twopi 3.0 pitch ctr)))))))
(define (raw-sawtooth-wave pitch)
(when (< (/ SR 2) pitch)
(raise-argument-error
'raw-sawtooth-wave
(format "pitch lower than ~s Hz" (/ SR 2))
0 pitch))
(define scalar (exact->inexact (* 2 (* pitch SRINV))))
(define (increment p)
(define next (fl+ p scalar))
(cond [(< next 1.0) next]
[else (- next 2.0)]))
(network ()
[b (prev a 0.0)]
[a (increment b)]
[out b]))
(define sawtooth-wave (make-checked-wave-fun raw-sawtooth-wave))
(define sawtooth-terms 20)
(define (raw-sawtooth-approx-wave pitch)
(let ([scalar (exact->inexact (* twopi (* pitch SRINV)))])
(indexed-signal
(lambda (i)
(for/fold ([sum 0.0])
([t (in-range 1 sawtooth-terms)])
(+ sum (* (expt -1 t) (/ 1 (* twopi t)) (sin (* i scalar t)))))))))
(define approx-sawtooth-wave (make-checked-wave-fun
raw-sawtooth-approx-wave))
(define pulse-wave
(network (duty-cycle pitch)
[angle (prev added 0.0)]
[added (angle-add/unit angle (* pitch SRINV))]
[out (pulse-wave-thresh angle duty-cycle)]))
(define (angle-add a b)
(define sum (+ a b))
(cond [(<= twopi sum) (- sum twopi)]
[else sum]))
(define (angle-add/unit a b)
(define sum (+ a b))
(cond [(<= 1.0 sum) (- sum 1.0)]
[else sum]))
(define (pulse-wave-thresh angle duty-cycle)
(cond [(< angle duty-cycle) 1.0] [else 0.0]))
(define square-wave
(network (pitch)
[out (pulse-wave 0.5 pitch)]))
(define (fader fade-frames)
(let ([p (expt 0.001 (/ 1 fade-frames))])
(network ()
(out (* p (prev out 1.0))))))
(define (frisellinator intro-frames)
(indexed-signal
(lambda (i)
(cond [(< intro-frames i) 1.0]
[else (* 0.5 (- 1.0 (cos (* pi (/ i intro-frames)))))]))))
(define (signal-* a b)
(network ()
[a-out (a)]
[b-out (b)]
(out (* a-out b-out))))
(define (signal-+ a b)
(network ()
(a-out (a))
(b-out (b))
(out (+ a-out b-out))))
(define (sig-scale volume signal)
(network ()
(s (signal))
(out (* volume s))))
(define (wavefun->tone-maker wavefun)
(let ([tone-table (make-hash)])
(lambda (pitch volume frames)
(define sample-rate (default-sample-rate))
(define key (list pitch volume sample-rate))
(define (compute-and-store)
(define snd (signal->rsound frames
(wavefun pitch volume sample-rate)))
(hash-set! tone-table key snd)
snd)
(match (hash-ref tone-table key #f)
[#f (compute-and-store)]
[(and s (struct rsound (data start stop sample-rate)))
(let ()
(define stored-frames (rs-frames s))
(cond [(= frames stored-frames) s]
[(< frames stored-frames) (clip s 0 frames)]
[else (compute-and-store)]))]))))
(define (wavefun->tone-maker/periodic wavefun)
(let ([tone-table (make-hash)])
(lambda (pitch volume frames)
(define sample-rate (default-sample-rate))
(define key (list pitch volume sample-rate))
(define (compute-and-store)
(define num-cycles (cycles-to-use pitch sample-rate))
(define generated-frames (round (* num-cycles (/ sample-rate pitch))))
(log-debug (format "generated ~s frames" generated-frames))
(define core
(parameterize ([default-sample-rate SR])
(signal->rsound generated-frames
(wavefun pitch volume))))
(define snd (tile-to-len core frames))
(when (< generated-frames too-long-to-cache)
(hash-set! tone-table key snd))
snd)
(match (hash-ref tone-table key #f)
[#f (compute-and-store)]
[(and s (struct rsound (data start stop sample-rate)))
(let ()
(define stored-frames (rs-frames s))
(cond [(= frames stored-frames) s]
[(< frames stored-frames) (clip s 0 frames)]
[else (compute-and-store)]))]))))
(define too-long-to-cache (* 44100 10))
(define (fader-as-wavefun fade-frames dc1 dc2)
(fader fade-frames))
(define fader-proxy (wavefun->tone-maker fader-as-wavefun))
(define (fader-snd fade-frames frames)
(fader-proxy fade-frames #f frames))
(define (tile-to-len snd frames)
(define copies (/ frames (rs-frames snd)))
(define integral-copies (floor copies))
(define leftover-frames (- frames (* (rs-frames snd) integral-copies)))
(rs-append*
(append (for/list ([i (in-range integral-copies)]) snd)
(list (clip snd 0 leftover-frames)))))
(define make-tone
(wavefun->tone-maker/periodic
(lambda (pitch volume)
(sig-scale volume (fixed-inputs sine-wave pitch)))))
(define make-harm3tone/unfaded
(wavefun->tone-maker/periodic
(lambda (pitch volume)
(sig-scale volume
(harm3-wave pitch)))))
(define (make-harm3tone pitch volume frames)
(rs-mult (fader-snd 88200 frames)
(make-harm3tone/unfaded pitch volume frames)))
(define (make-pulse-tone duty-cycle)
(when (not (< 0.0 duty-cycle 1.0))
(raise-argument-error 'make-pulse-tone
"number between 0 and 1"
0
duty-cycle))
(wavefun->tone-maker/periodic
(lambda (pitch volume)
(define wavelength (/ (default-sample-rate) pitch))
(define on-samples (inexact->exact (round (* duty-cycle wavelength))))
(define total-samples (inexact->exact (round wavelength)))
(define up volume)
(define down (- up))
(define (hi-lo idx)
(cond [(< idx on-samples) up]
[else down]))
(network ()
(idx ((loop-ctr total-samples 1)))
(out (hi-lo idx))))))
(define (make-ding pitch)
(parameterize ([default-sample-rate SR])
(signal->rsound SR
(signal-*s (list (fixed-inputs sine-wave pitch)
(dc-signal 0.35)
(fader SR))))))
(define ding (make-ding 600))
(define (split-in-4 s)
(let ([len (floor (/ (rs-frames s) 4))])
(apply values (for/list ([i (in-range 4)])
(clip s (* i len) (* (+ 1 i) len))))))
(define (times n s)
(rs-append* (build-list n (lambda (x) s))))
(define (vectors->rsound leftvec rightvec)
(define sample-rate (default-sample-rate))
(unless (equal? (vector-length leftvec) (vector-length rightvec))
(error 'vectors->rsound
"expected vectors of equal length, given vectors of lengths ~v and ~v."
(vector-length leftvec) (vector-length rightvec)))
(let* ([len (vector-length leftvec)]
[datamax (for/fold ((max-abs 0.0))
((x (in-vector leftvec))
[y (in-vector rightvec)])
(max (abs (real-part x))
(abs (real-part y))
max-abs))]
[newvec (make-s16vector (* 2 len))]
[scaling (/ s16max datamax)])
(for ([i (in-range len)])
(s16vector-set! newvec (* 2 i)
(inexact->exact
(round (* scaling
(real-part (vector-ref leftvec i))))))
(s16vector-set! newvec (add1 (* 2 i))
(inexact->exact
(round (* scaling
(real-part (vector-ref rightvec i)))))))
(rsound newvec 0 len sample-rate)))
(define (adsr frames attack-len attack-height decay-len decay-height)
(define slope1 (exact->inexact (/ attack-height attack-len)))
(define slope2 (exact->inexact (/ (- decay-height attack-height) decay-len)))
(define (ramp idx p)
(cond [(<= idx attack-len) (+ p slope1)]
[(<= idx decay-len) (+ p slope2)]
[(<= idx frames) p]
[else 0]))
(network ()
(frame ((simple-ctr 0 1)))
(volume (ramp frame (prev volume 0.0)))))
(define (binary-logn n)
(let ((binary-logn
(let loop ((k 1)
(l 0))
(if (>= k n)
l
(loop (* k 2) (+ l 1))))))
(if (= n (arithmetic-shift 1 binary-logn))
binary-logn
#f)))
(define (rsound-fft/left rsound)
(channel-fft (lambda (i) (rs-ith/left/s16 rsound i)) (rs-frames rsound)))
(define (rsound-fft/right rsound)
(channel-fft (lambda (i) (rs-ith/right/s16 rsound i)) (rs-frames rsound)))
(define (channel-fft accessor len)
(let* ([v (build-vector len
(lambda (i)
(/ (exact->inexact (accessor i)) s16max)))])
(if (binary-logn len)
(fft-complex-radix2-forward v)
(fft-complex-forward v))
v))
(define (rsound-maximize-volume rsound)
(let* ([scalar (fl/ 1.0 (exact->inexact (rs-largest-sample rsound)))])
(signals->rsound
(rs-frames rsound)
(rsound-sample-rate rsound)
(lambda (i) (fl* scalar (exact->inexact (rs-ith/left/s16 rsound i))))
(lambda (i) (fl* scalar (exact->inexact (rs-ith/right/s16 rsound i)))))))
(define (midi-note-num->pitch note-num)
(unless (real? note-num)
(raise-type-error 'midi-note-num->pitch "real" 0 note-num))
(* 440 (expt 2 (/ (- note-num 69) 12))))
(define ((rsound->signal/either ith-fun) rsound)
(unless (rsound? rsound)
(raise-type-error 'rsound->signal "rsound" 0 rsound))
(let ([len (rs-frames rsound)])
(lambda (t)
(cond [(< t len) (ith-fun rsound t)]
[else 0.0]))))
(define rsound->signal/left (rsound->signal/either rs-ith/left))
(define rsound->signal/right (rsound->signal/either rs-ith/right))
(define (thresh threshold n)
(let ([abs-thresh (abs threshold)])
(max (- abs-thresh) (min abs-thresh n))))
(define (thresh/signal threshold signal)
(define abs-threshold (abs threshold))
(define neg-threshold (- abs-threshold))
(define (limit-fun s)
(cond [(< s neg-threshold) neg-threshold]
[(< s abs-threshold) s]
[else abs-threshold]))
(network ()
(base (signal))
(out (limit-fun base))))
(define (signal-scale volume signal)
(define mult (lambda (s) (* volume s)))
(network ()
(s (signal))
(out (mult s))))
(define (clip&volume volume signal)
(signal-scale volume (thresh/signal 1.0 signal)))
(define (rs-overlay* los)
(assemble (map (lambda (s) (list s 0)) los)))
(define (rs-overlay sound1 sound2)
(assemble (list (list sound1 0)
(list sound2 0))))
(define-syntax (mono stx)
(syntax-parse stx
[(_ frames:expr timevar:id body:expr ...)
#'(signal->rsound frames
(indexed-signal
(lambda (timevar) body ...)))]))
(define (noise duration)
(define samples (* duration channels))
(define vec (make-s16vector samples))
(for ([i (in-range samples)])
(s16vector-set! vec i (- (random (* 2 s16max)) s16max)))
(rsound vec 0 duration (default-sample-rate)))
(define (rearrange frames fun orig)
(define samples (* frames channels))
(define vec (make-s16vector samples))
(for ([i (in-range frames)])
(define source (fun i))
(s16vector-set! vec (* channels i)
(rs-ith/left/s16 orig source))
(s16vector-set! vec (add1 (* channels i))
(rs-ith/right/s16 orig source)))
(rsound vec 0 frames (default-sample-rate)))
(define i2e inexact->exact)
(define (rs-largest-sample sound)
(buffer-largest-sample/range (rsound-data sound)
(rsound-start sound) (rsound-stop sound)
(rs-frames sound)))
(define (rs-largest-frame/range/left sound min-frame max-frame)
(buffer-largest-sample/range/left (rsound-data sound)
(rs-frames sound) min-frame max-frame))
(define (rs-largest-frame/range/right sound min-frame max-frame)
(buffer-largest-sample/range/right (rsound-data sound)
(rs-frames sound) min-frame max-frame))
(define (buffer-largest-sample/range buffer start stop frames)
(buffer-largest-sample/range/helper buffer (* channels start)
(* channels stop) 1))
(define (buffer-largest-sample/range/left buffer frames min-frame max-frame)
(frame-range-checks frames min-frame max-frame)
(buffer-largest-sample/range/helper buffer
(* channels min-frame)
(* channels max-frame)
2))
(define (buffer-largest-sample/range/right buffer frames min-frame max-frame)
(frame-range-checks frames min-frame max-frame)
(buffer-largest-sample/range/helper buffer
(add1 (* channels min-frame))
(add1 (* channels max-frame))
2))
(define (buffer-largest-sample/range/helper buffer min-sample max-sample increment)
(for/fold ([max-so-far 0.0])
([i (in-range min-sample max-sample increment)])
(max max-so-far (abs (s16vector-ref buffer i)))))
(define (frame-range-checks frames min-frame max-frame)
(when (not (and (<= 0 min-frame) (<= 0 max-frame)
(<= min-frame frames) (<= max-frame frames)))
(error 'frame-range-checks
"range limits ~v and ~v not in range 0 - ~v"
min-frame max-frame frames))
(when (not (< min-frame max-frame))
(error 'frame-range-checks
"range limits ~v and ~v not in order and separated by at least 1"
min-frame max-frame)))