#lang racket
(require "rsound.rkt"
racket/flonum
ffi/vector
racket/unsafe/ops)
(define twopi (* 2 pi))
(define s16max #x7fff)
(define common-sample-rate 44100)
(provide twopi
s16max
sine-wave
sawtooth-wave
square-wave
harm3-wave
fader
dc-signal
signal-*s
signal-+s
make-tone
make-squaretone
make-harm3tone/memoized
ding
make-ding
split-in-4
times
vectors->rsound
echo1
raw-sine-wave
raw-square-wave
raw-sawtooth-wave
)
(define (build-flvector len fun)
(let ([newvec (make-flvector len)])
(for ([i (in-range len)])
(flvector-set! newvec i (exact->inexact (fun i))))
newvec))
(define (build-wavetable fun)
(build-flvector common-sample-rate (fun 1 common-sample-rate)))
(define ((make-table-based-wavefun vec) pitch sample-rate)
(let ([exact-pitch (inexact->exact pitch)])
(lambda (i)
(flvector-ref vec (modulo (* i exact-pitch) common-sample-rate)))))
(define (make-checked-wave-fun raw-wave-fun)
(let* ([table (build-wavetable raw-wave-fun)]
[table-based-fun (make-table-based-wavefun table)])
(lambda (pitch sample-rate)
(when (= 0 pitch)
(raise-type-error 'wave-fun "nonzero number" 0 pitch sample-rate))
(when (= 0 sample-rate)
(raise-type-error 'wave-fun "nonzero number" 1 pitch sample-rate))
(cond [(and (= sample-rate common-sample-rate)
(integer? pitch))
(table-based-fun (inexact->exact pitch) sample-rate)]
[else
(raw-wave-fun pitch sample-rate)]))))
(define (raw-sine-wave pitch sample-rate)
(let ([scalar (* twopi pitch)])
(lambda (i)
(let ([t (/ i sample-rate)])
(sin (* scalar t))))))
(define sine-wave (make-checked-wave-fun raw-sine-wave))
(define (raw-harm3-wave pitch sample-rate)
(let ([scalar1 (* twopi pitch)]
[scalar2 (* twopi 2 pitch)]
[scalar3 (* twopi 3 pitch)])
(lambda (i)
(let ([t (/ i sample-rate)])
(+ (sin (* scalar1 t))
(* 0.5 (sin (* scalar2 t)))
(* 0.25 (sin (* scalar3 t))))))))
(define harm3-wave (make-checked-wave-fun raw-harm3-wave))
(define (raw-sawtooth-wave pitch sample-rate)
(let ([scalar (exact->inexact (* 2 (* pitch (/ 1 sample-rate))))])
(lambda (i)
(let* ([unwrapped (+ 1.0 (* (exact->inexact i) scalar))]
[scaled (/ unwrapped 2.0)])
(- (* 2.0 (- scaled (floor scaled))) 1.0)))))
(define sawtooth-wave (make-checked-wave-fun raw-sawtooth-wave))
(define (raw-square-wave pitch sample-rate)
(let* ([period (* sample-rate (/ 1 pitch))])
(lambda (i)
(let* ([scaled (/ i period)]
[frac (- scaled (floor scaled))])
(cond [(< frac 0.5) 1.0]
[else -1.0])))))
(define square-wave (make-checked-wave-fun raw-square-wave))
(define (fader fade-frames)
(let ([p (expt 0.001 (/ 1 fade-frames))])
(lambda (i)
(expt p i))))
(define (dc-signal volume)
(lambda (i)
volume))
(define (signal-*s lof)
(lambda (i) (apply * (map (lambda (x) (x i)) lof))))
(define (signal-* a b) (signal-*s (list a b)))
(define (signal-+s lof)
(lambda (i) (apply + (map (lambda (x) (x i)) lof))))
(define (make-tone pitch volume frames sample-rate)
(fun->mono-rsound frames sample-rate (signal-*s (list (dc-signal volume) (sine-wave pitch sample-rate)))))
(define (make-squaretone pitch volume frames sample-rate)
(fun->mono-rsound frames sample-rate (signal-*s (list (dc-signal volume) (square-wave pitch sample-rate)))))
(define (make-harm3tone/memoized pitch volume frames sample-rate)
(let ([key (list pitch volume frames sample-rate)])
(hash-ref! tone-table
key
(lambda ()
(fun->mono-rsound frames sample-rate (signal-*s (list (fader 88200)
(dc-signal volume) (harm3-wave pitch sample-rate))))))))
(define tone-table (make-hash))
(define ding (fun->mono-rsound 44100 44100 (signal-*s (list (sine-wave 600 44100)
(dc-signal 0.35)
(fader 44100)))))
(define (make-ding pitch)
(fun->mono-rsound 44100 44100 (signal-*s (list (sine-wave pitch 44100)
(dc-signal 0.35)
(fader 44100)))))
(define (split-in-4 s)
(let ([len (/ (rsound-frames s) 4)])
(apply values (for/list ([i (in-range 4)])
(rsound-clip s (* i len) (* (+ 1 i) len))))))
(define (times n s)
(rsound-append* (build-list n (lambda (x) s))))
(define (vectors->rsound leftvec rightvec 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 len sample-rate)))
(define (adsr frames attack-len attack-height decay-len decay-height)
(let* ([t1 attack-len]
[t2 (+ t1 decay-len)]
[t3 frames])
(lambda (i)
(cond [(< i t1) (weighted (/ i attack-len) 0 attack-height)]
[(< i t2) (weighted (/ (- i t1) decay-len) attack-height decay-height)]
[(< i t3) decay-height]
[else 0]))))
(define (weighted s a b)
(+ (* a (- 1 s)) (* b s)))
(define delay 8820)
(define echo1
(let* ([vec-len (* 3 delay)]
[echovec (make-flvector vec-len 0.0)]
[vec-ptr 0])
(define (nth-echo n)
(flvector-ref echovec (modulo (- vec-ptr (* n delay)) vec-len)))
(lambda (in)
(let ([out (+ in (* 0.5 (nth-echo 1)) (* 0.25 (nth-echo 2)) (* 0.125 (nth-echo 3)))])
(flvector-set! echovec vec-ptr (exact->inexact in))
(set! vec-ptr (modulo (+ vec-ptr 1) vec-len))
out))))
(define (try-wave-fun fun)
(fun->mono-rsound (* 4 44100) 44100 (signal-*s (list (dc-signal 0.35)
(fun 100 44100)))))
(play-rsound (try-wave-fun square-wave))
(define (gug pitch)
(signal-+s (list (signal-*s (list (dc-signal 0.25)
(square-wave pitch 44100)))
(signal-*s (list
(dc-signal 0.25)
(sine-wave .5 44100)
(square-wave (* 2 pitch) 44100))))))
(change-loop
(rsound-append* (list (fun->mono-rsound (* 2 44100) 44100 (gug 100))
(fun->mono-rsound (* 2 44100) 44100 (gug 75))
(fun->mono-rsound (* 2 44100) 44100 (gug 79))
(fun->mono-rsound (* 2 44100) 44100 (gug 89)))))