Commit 3eb3c4d0 authored by IOhannes m zmölnig's avatar IOhannes m zmölnig

Imported Upstream version 16.6

parent 248790ac
Snd is a sound editor written by Bill Schottstaedt (bil@ccrma.stanford.edu).
Except where otherwise noted, it is Copyright 1996-2013 Bill Schottstaedt.
Except where otherwise noted, it is Copyright 1996-2016 Bill Schottstaedt.
......
Snd change log
14-Jun: Snd 16.6.
30-May: snd-lint.scm, symbol takes any number of args.
6-May: Snd 16.5.
29-Mar: --with-webserver configuration (Kjetil Matheussen)
28-Mar: Snd 16.4.
......
Snd 16.5
Snd 16.6.
Kjetil Matheussen added the --with-webserver configuration flag to Snd, and
made all the supporting changes.
added snd-lint.scm (Snd extensions for lint)
Daniel Hensel sent instructions to build Snd in OSX -- see README.Snd.
s7's symbol function now takes any number of string args
these are all concatenated to form the new symbol name
s7's make-vector no longer takes an optional fourth argument.
ttaenc removed: it appears to be dead (no movement in 10 years), or infected.
checked: gtk 3.21.2, sbcl 1.3.6, Fedora 24
changed spectr.scm to export only *spectr*, rgb.scm *rgb*.
checked: sbcl 1.3.4|5, gtk 3.20.2|3 3.21.1, gsl 2.1
Thanks!: Greg Santucci, Daniel Lopez, Kjetil Matheussen, Daniel Hensel
Thanks!: Joe Python, Tito Latini.
\ No newline at end of file
......@@ -73,22 +73,24 @@
(set! b (cons (float-vector 1.0 (c k) (c (+ k 1))) b)))))
(define (prototype->highpass n num den)
(do ((g 1.0)
(numt (make-float-vector (length num)))
(dent (make-float-vector (length den)))
(k 0 (+ k 2))
(i 0 (+ i 3)))
((>= k n)
(set! (numt 0) g)
(list numt dent))
(set! g (* g (/ (num (+ i 2)) (den (+ i 2)))))
(set! (numt i ) 1.0)
(set! (numt (+ i 1)) (/ (num (+ i 1)) (num (+ i 2))))
(set! (numt (+ i 2)) (/ (num i) (num (+ i 2))))
(set! (dent i ) 1.0)
(set! (dent (+ i 1)) (/ (den (+ i 1)) (den (+ i 2))))
(set! (dent (+ i 2)) (/ (den i) (den (+ i 2))))))
(define (prototype->highpass n proto)
(let ((num (car proto))
(den (cadr proto)))
(do ((g 1.0)
(numt (make-float-vector (length num)))
(dent (make-float-vector (length den)))
(k 0 (+ k 2))
(i 0 (+ i 3)))
((>= k n)
(set! (numt 0) g)
(list numt dent))
(set! g (* g (/ (num (+ i 2)) (den (+ i 2)))))
(set! (numt i ) 1.0)
(set! (numt (+ i 1)) (/ (num (+ i 1)) (num (+ i 2))))
(set! (numt (+ i 2)) (/ (num i) (num (+ i 2))))
(set! (dent i ) 1.0)
(set! (dent (+ i 1)) (/ (den (+ i 1)) (den (+ i 2))))
(set! (dent (+ i 2)) (/ (den i) (den (+ i 2)))))))
;;; ---------------- Butterworth ----------------
......@@ -124,7 +126,7 @@ freq (srate = 1.0): (make-butterworth-highpass 8 .1)"))
(lambda (n fc)
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (butterworth-prototype n))
(hproto (prototype->highpass n (car proto) (cadr proto)))
(hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
......@@ -188,7 +190,7 @@ fc = cutoff freq (srate = 1.0): (make-chebyshev-highpass 8 .1 .01)"))
(lambda* (n fc (ripple 1.0))
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (chebyshev-prototype n ripple))
(hproto (prototype->highpass n (car proto) (cadr proto)))
(hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
......@@ -253,7 +255,7 @@ fc = cutoff freq (srate = 1.0): (make-inverse-chebyshev-highpass 10 .1 120)"))
(lambda* (n fc (loss-dB 60.0))
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (inverse-chebyshev-prototype n loss-dB))
(hproto (prototype->highpass n (car proto) (cadr proto)))
(hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
......@@ -342,7 +344,7 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(lambda* (n fc)
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (bessel-prototype n))
(hproto (prototype->highpass n (car proto) (cadr proto)))
(hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
......@@ -431,9 +433,7 @@ fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 9
(set! (num j ) 1.0)
(set! (num (+ j 1)) (* -2.0 (real-part z)))
(set! (num (+ j 2)) pz))))
(let* ((optarg0 (* k1p k1p))
(optarg1 (/ 1.0 e))
(minf (minimize-function findv 0.0 (/ 1.0 e) optarg0 optarg1))
(let* ((minf (minimize-function findv 0.0 (/ 1.0 e) (* k1p k1p) (/ 1.0 e)))
(v0 (/ (* k minf)
(* n (gsl-ellipk (* k k1)))))
(vals (gsl-ellipj v0 (- 1.0 m)))
......@@ -470,7 +470,7 @@ fc = cutoff freq (srate = 1.0): (make-elliptic-highpass 8 .25 .01 90)"))
(lambda* (n fc (ripple 1.0) (loss-dB 60.0))
(if (odd? n) (set! n (+ n 1)))
(let* ((proto (elliptic-prototype n ripple loss-dB))
(hproto (prototype->highpass n (car proto) (cadr proto)))
(hproto (prototype->highpass n proto))
(coeffs (analog->digital n (car hproto) (cadr hproto) fc)))
(make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
......
......@@ -1437,7 +1437,7 @@
;; rocky 31 1
;; (an experiment with wave-train in place of pulsed env)
(let* ((wave-len 256)
(pulse (let ((v (make-float-vector wave-len 0.0))
(pulse (let ((v (make-float-vector wave-len))
(pulse-ampf (make-env '(0.000 0.000 0.063 0.312 0.277 0.937 0.405 1.000 0.617 0.696 0.929 0.146 2.000 0.000) :length wave-len)))
(do ((i 0 (+ i 1)))
((= i wave-len))
......@@ -1852,7 +1852,7 @@
(pulse-samps (seconds->samples pulse-dur))
(pulse-sep (seconds->samples pulse-dur))
(pulses 0)
(obank (make-oscil-bank freqs (make-float-vector 7 0.0) amps #t)))
(obank (make-oscil-bank freqs (make-float-vector 7) amps #t)))
(do ((i start (+ i pulse-sep)))
((>= i stop))
(let ((pulse-stop (+ i pulse-samps)))
......@@ -2960,7 +2960,7 @@
(do ((i 0 (+ i 1)))
((= i 40))
(savannah-2 (+ beg 1.29 .36 (* i .0145)) (* amp af) 5600)
(set! af (if (< i 20) (+ af .004) (- af .004)))))
(set! af ((if (< i 20) + -) af 0.004))))
(savannah-7 (+ beg 2.27) (* .4 amp))
......@@ -3625,7 +3625,7 @@
(initial-ampf (make-env '(0 0 1 1 10 1 11 0) :duration initial-dur :scaler (* amp initial-amp)))
(initial-gen (make-oscil initial-pitch))
(buzz-frq-table (let ((v (make-float-vector buzz-size 0.0))
(buzz-frq-table (let ((v (make-float-vector buzz-size))
(bfrqf (make-env (vector 0 (if gliss-up
(values buzz-low .5 buzz-mid 1 buzz-high)
(values buzz-high .5 buzz-mid 1 buzz-low)))
......@@ -3635,7 +3635,7 @@
((= i buzz-size))
(set! (v i) (env bfrqf)))
v))
(buzz-amp-table (let ((v (make-float-vector buzz-size 0.0))
(buzz-amp-table (let ((v (make-float-vector buzz-size))
(bampf (make-env (if gliss-up
'(0 0 1 1 2.5 .7 3 0 3.5 0)
'(0 0 .5 1 2 1 3 0 3.5 0))
......@@ -3985,8 +3985,8 @@
(stop (seconds->samples (+ beg dur)))
(ampf (make-env '(0.000 0.000 0.052 0.100 0.130 0.538 0.261 0.845 0.438 0.983 0.580 0.917 0.738 0.720 0.860 0.475 0.941 0.172 1.000 0.000)
:duration dur :scaler (/ amp 2.25)))
(gen1 (make-rxyk!cos 3360 (/ -200 3360) 0.7))
(gen2 (make-rxyk!cos 3760 (/ 200 3760) 0.3))
(gen1 (make-rxyk!cos 3360 -5/84 0.7)) ; (/ 200 3360)
(gen2 (make-rxyk!cos 3760 5/94 0.3)) ; (/ 200 3760)
(gen3 (make-polywave 3660 (list 1 (* .25 .98) 2 (* .25 .02))))
(frqf (make-env '(0 1 .1 0 .95 0 1.0 -.1) :duration dur :scaler (hz->radians 10.0)))
(rnd (make-rand-interp 100 (hz->radians 3))))
......@@ -4125,7 +4125,7 @@
0.794 0.510 0.831 0.510 0.909 0.494 1.000 0.499)
:duration bump-dur :offset -0.5)))
(let ((bump-wave (make-float-vector bump-samps 0.0)))
(let ((bump-wave (make-float-vector bump-samps)))
(do ((i 0 (+ i 1)))
((= i bump-samps))
(set! (bump-wave i) (env bump)))
......@@ -4288,14 +4288,14 @@
;;; American crow
(define (nrcos->polywave n r scl)
(if (< 0 n 8192)
(if (not (< 0 n 8192))
(error 'out-of-range "nrcos->polywave: too many partials")
(let ((lst ())
(total (polynomial (make-float-vector n 1.0) r)))
(set! scl (/ scl total))
(do ((i 0 (+ i 1)))
((= i n) (reverse lst))
(set! lst (cons (* scl (expt r i)) (cons (+ i 1) lst)))))
(error 'out-of-range "nrcos->polywave: too many partials")))
(set! lst (cons (* scl (expt r i)) (cons (+ i 1) lst)))))))
(defanimal (american-crow beg amp)
(let ((dur 0.27))
......@@ -7280,9 +7280,9 @@
(set! (ampfs 4) (make-env '(0.000 0.000 0.159 0.995 0.314 0.997 0.598 0.000 1.000 0.000)
:duration dur :scaler .01))
(let ((frqs (make-float-vector 5 0.0))
(amps (make-float-vector 5 0.0)))
(let ((obank (make-oscil-bank frqs (make-float-vector 5 0.0) amps)))
(let ((frqs (make-float-vector 5))
(amps (make-float-vector 5)))
(let ((obank (make-oscil-bank frqs (make-float-vector 5) amps)))
(do ((i start (+ i 1)))
((= i stop))
(let ((frq (env frqf)))
......
......@@ -40,8 +40,7 @@
(XtVaSetValues label (list XmNlabelString s1))
(XmStringFree s1)))
(let* ((light-blue *position-color*)
(form (XtCreateManagedWidget "form" xmFormWidgetClass shell
(let* ((form (XtCreateManagedWidget "form" xmFormWidgetClass shell
(list XmNbackground white
XmNforeground black
XmNresizePolicy XmRESIZE_GROW)))
......@@ -78,7 +77,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground light-blue)))
XmNbackground *position-color*)))
;; amp
(amp (XtCreateManagedWidget "amp:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
......@@ -105,7 +104,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground light-blue)))
XmNbackground *position-color*)))
;; fm index
(fm-index (XtCreateManagedWidget "fm index:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
......@@ -132,7 +131,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground light-blue)))
XmNbackground *position-color*)))
;; c/m ratio
(cm-ratio (XtCreateManagedWidget "c/m ratio:" xmLabelWidgetClass form
(list XmNleftAttachment XmATTACH_FORM
......@@ -159,7 +158,7 @@
XmNrightAttachment XmATTACH_FORM
XmNshowValue #f
XmNorientation XmHORIZONTAL
XmNbackground light-blue)))
XmNbackground *position-color*)))
(frequency 220.0)
(low-frequency 40.0)
(high-frequency 2000.0)
......@@ -221,7 +220,7 @@
(let* ((bufsize 256)
(srate 22050)
(work-proc #f)
;(data (make-float-vector bufsize 0.0))
;(data (make-float-vector bufsize))
(port (mus-audio-open-output mus-audio-default srate 1 mus-lshort (* bufsize 2))))
(if (< port 0)
(format () "can't open DAC!"))
......@@ -239,7 +238,7 @@
(XtUnmanageChild shell)))
(set! work-proc (XtAppAddWorkProc app
(lambda (ignored-arg)
(let ((data (make-float-vector bufsize 0.0)))
(let ((data (make-float-vector bufsize)))
(do ((i 0 (+ 1 i)))
((= i bufsize))
(float-vector-set! data i (* amplitude playing
......
......@@ -51,7 +51,7 @@
(do ((i 0 (+ i 1)))
((= i *clm-rt-bufsize*))
(set! (data i) (func)))
(mus-audio-write *output* (copy data (make-float-vector (list 1 *clm-rt-bufsize*) 0.0)) *clm-rt-bufsize*)
(mus-audio-write *output* (copy data (make-float-vector (list 1 *clm-rt-bufsize*))) *clm-rt-bufsize*)
#f)
(begin
(mus-audio-close *output*)
......@@ -118,24 +118,21 @@
(if (> (random 1.0) 0.5) (set! cellsiz (+ 1 cellsiz)))
(set! cellctr cellbeg)))
(format () "dur: ~A, freq: ~A, amp: ~A, index: ~A~%"
dur
(let ((freq (* cfreq 16.351 16
(expt 2 (/ (vmode (vpits cellctr))
12.0)))))
(let ((freq (* cfreq 16.351 16
(expt 2 (/ (vmode (vpits cellctr)) 12.0)))))
(format () "dur: ~A, freq: ~A, amp: ~A, index: ~A~%"
dur
(if (< (* 8 freq) *clm-srate*)
freq
(/ freq 4)))
(* camp 0.3) cindex)
(/ freq 4))
(* camp 0.3)
cindex)
(set! func (make-rt-violin dur
(let ((freq (* cfreq 16.351 16
(expt 2 (/ (vmode (vpits cellctr))
12.0)))))
(set! func (make-rt-violin dur
(if (< (* 8 freq) *clm-srate*)
freq
(/ freq 4)))
(* camp 0.3) :fm-index cindex))
(/ freq 4))
(* camp 0.3) :fm-index cindex)))
(set! len (ceiling (/ (seconds->samples dur) bufsize)))))
func)))
......@@ -262,8 +259,7 @@
(app (cadr shell-app))
(shell (car shell-app))
(dpy (XtDisplay shell))
(screen (DefaultScreenOfDisplay dpy))
(black (BlackPixelOfScreen screen)))
(black (BlackPixelOfScreen (DefaultScreenOfDisplay dpy))))
(define (get-color color)
(let ((col (XColor))
......
......@@ -25,7 +25,7 @@
;;; -------- strings (unterminated)
(define (read-chars len)
(define* (read-chars (len 4))
(let ((str (make-string len)))
(do ((i 0 (+ i 1)))
((= i len) str)
......@@ -239,16 +239,15 @@
(define (read-au-header file)
(with-input-from-file file
(lambda ()
(let ((magic (read-chars 4)))
(let ((magic (read-chars)))
(if (not (string=? magic ".snd"))
(error 'bad-header "~A is not an au file: ~A" file)
(let* ((data-location (read-bint32))
(data-size (read-bint32))
(sample-type (read-bint32))
(srate (read-bint32))
(chns (read-bint32))
(comment (io-read-string)))
(list magic data-location data-size sample-type srate chns comment)))))))
(chns (read-bint32)))
(list magic data-location data-size sample-type srate chns (io-read-string)))))))) ; io-read-string = comment
(define (write-au-header file chns srate data-size sample-type comment) ; data-size in bytes
;; common sample-types: 1 mulaw, 2 linear_8, 3 linear_16, 4 linear_24, 5 linear_32, 6 float, 5 double, 27 alaw
......@@ -277,11 +276,11 @@
(current-location 0))
(with-input-from-file file
(lambda ()
(let ((magic (read-chars 4)))
(let ((magic (read-chars)))
(if (not (string=? magic "FORM"))
(error 'bad-header "~A is not an aif file: ~A" file magic)
(let (;(size (read-bint32))
(magic (read-chars 4)))
(magic (read-chars)))
(set! current-location 12)
(if (not (member magic '("AIFF" "AIFC") string=?))
(error 'bad-header "~A is not an aif file: ~A" file magic)
......@@ -289,7 +288,7 @@
(call-with-exit
(lambda (return)
(let loop ()
(let ((chunk (read-chars 4))
(let ((chunk (read-chars))
(chunk-size (read-bint32)))
(if (odd? chunk-size) (set! chunk-size (+ chunk-size 1)))
(if (string=? chunk "SSND")
......
This diff is collapsed.
......@@ -6,8 +6,7 @@
(define goertzel-channel
(let ((documentation "(goertzel-channel freq beg dur snd (chn 0)) returns the amplitude of the 'freq' spectral component"))
(lambda* (freq (beg 0) dur snd chn)
(let* ((sr (srate snd))
(rfreq (/ (* 2.0 pi freq) sr))
(let* ((rfreq (/ (* 2.0 pi freq) (srate snd)))
(cs (* 2.0 (cos rfreq))))
(let ((reader (make-sampler beg snd chn))
(len (- (if (number? dur) dur (- (framples snd chn) beg)) 2))
......@@ -158,14 +157,12 @@
(do ((ctr 0 (+ ctr 1)))
((= ctr len))
(let* ((ahead-samp (next-sample reader))
(diff-ahead (abs (- ahead-samp last-ahead-samp)))
(avg-ahead (moving-average mx-ahead diff-ahead))
(avg-ahead (moving-average mx-ahead (abs (- ahead-samp last-ahead-samp))))
(dly0-samp (delay dly0 ahead-samp))
(cur-diff (abs (- dly0-samp last-dly0-samp)))
(cur-avg (moving-average mx cur-diff))
(dly1-samp (delay dly1 ahead-samp))
(diff-behind (abs (- dly1-samp last-dly1-samp)))
(avg-behind (moving-average mx-behind diff-behind)))
(avg-behind (moving-average mx-behind (abs (- dly1-samp last-dly1-samp)))))
(set! last-ahead-samp ahead-samp)
(set! last-dly0-samp dly0-samp)
(set! last-dly1-samp dly1-samp)
......@@ -401,7 +398,7 @@
(if (> pops 0)
(format () "~%; fixed ~D ~D-sample ~A" pops size (if (= pops 1) "pop" "pops"))
(quit))))
(list 4 8 16 32))))
'(4 8 16 32))))
(if (= total-pops 0)
(format () "~%; no pops found")))
......
This diff is collapsed.
......@@ -1720,7 +1720,7 @@ mus_float_t mus_ncos(mus_any *ptr, mus_float_t fm)
(+ 1 (* n 2)))))
(with-sound (:scaled-to 1.0)
(do ((i 0 (1+ i))
(do ((i 0 (+ i 1))
(x 0.0 (+ x .01)))
((= i 200)) ; glitch at 100 (= 1)
(outa i (ncos-with-inversions 1 (* pi x)) *output*)))
......@@ -1886,11 +1886,11 @@ bool mus_is_nsin(mus_any *ptr)
(define (smax coeffs)
(let* ((n (vct-length coeffs))
(dcos (make-vct n 1.0)))
(do ((i 0 (1+ i)))
(do ((i 0 (+ i 1)))
((= i n))
(vct-set! dcos i (* (+ i 1) (vct-ref coeffs i))))
(let ((partials ()))
(do ((i 0 (1+ i)))
(do ((i 0 (+ i 1)))
((= i n))
(set! partials (append (list (vct-ref dcos i) (+ i 1)) partials)))
(let ((Tn (partials->polynomial (reverse partials))))
......@@ -1900,7 +1900,7 @@ bool mus_is_nsin(mus_any *ptr)
(lambda (root)
(let ((acr (acos root))
(sum 0.0))
(do ((i 0 (1+ i)))
(do ((i 0 (+ i 1)))
((= i n))
(set! sum (+ sum (* (vct-ref coeffs i) (sin (* (+ i 1) acr))))))
(if (> (abs sum) mx)
......@@ -1920,7 +1920,7 @@ bool mus_is_nsin(mus_any *ptr)
(den (sin a2)))
(if (= den 0.0)
0.0
(/ (* (sin (* n a2)) (sin (* (1+ n) a2))) den))))
(/ (* (sin (* n a2)) (sin (* (+ n 1) a2))) den))))
(define (find-mid-max n lo hi)
(let ((mid (/ (+ lo hi) 2)))
......@@ -2008,7 +2008,7 @@ mus_float_t mus_nsin(mus_any *ptr, mus_float_t fm)
(den (sin a2)))
(if (= den 0.0)
0.0
(/ (* (sin (* n a2)) (sin (* (1+ n) a2))) den)))
(/ (* (sin (* n a2)) (sin (* (+ n 1) a2))) den)))
*/
#if HAVE_SINCOS
double val, a2, ns, nc, s, c;
......@@ -3317,7 +3317,7 @@ mus_float_t mus_chebyshev_t_sum(mus_float_t x, int n, mus_float_t *tn)
(let ((t2n (vct 0.5 0.25 0.25))
(x 0.0)
(dx (hz->radians 10.0)))
(do ((i 0 (1+ i)))
(do ((i 0 (+ i 1)))
((= i 22050))
(outa i (mus-chebyshev-odd-t-sum x 3 t2n))
(set! x (+ x dx)))))
......@@ -9393,7 +9393,7 @@ typedef struct {
(cf (exp (/ (- le ls) (1- num))))
(max-diff 0.0)
(xstart start))
(do ((i 0 (1+ i)))
(do ((i 0 (+ i 1)))
((= i num)
max-diff)
(let ((val1 (* start (exp (* (/ i (1- num)) (- le ls)))))
......
......@@ -40,9 +40,6 @@
(sin (phases i))))))
sum))
(define open-input make-file->sample)
(define two-pi (* 2 pi))
(define (simple-out beg dur freq amp)
......@@ -137,14 +134,12 @@
(define (simple-osc beg dur freq amp)
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
(freqs (make-float-vector 20)))
(let ((obank (make-oscil-bank freqs
(let ((fv (make-float-vector 20 0.0)))
(do ((i 0 (+ i 1)))
((= i 20) fv)
(set! (freqs i) (hz->radians (* (+ i 1) 100)))))
(make-float-vector 20 1.0)
#t)))
(freqs (make-float-vector 20))
(fv (make-float-vector 20)))
(do ((i 0 (+ i 1)))
((= i 20))
(set! (freqs i) (hz->radians (* (+ i 1) freq))))
(let ((obank (make-oscil-bank freqs fv (make-float-vector 20 1.0) #t)))
(set! amp (* 0.05 amp))
(do ((i start (+ i 1)))
((= i end))
......@@ -397,12 +392,12 @@
(let ((foflen (if (= *clm-srate* 22050) 100 200)))
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
(ampf (make-env :envelope (or ae (list 0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
(ampf (make-env :envelope (or ae '(0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
(frq0 (hz->radians f0))
(frq1 (hz->radians f1))
(frq2 (hz->radians f2))
(vibr (make-oscil 6))
(vibenv (make-env :envelope (or ve (list 0 1 100 1)) :scaler vib :duration dur))
(vibenv (make-env :envelope (or ve '(0 1 100 1)) :scaler vib :duration dur))
(win-freq (/ two-pi foflen))
(wt0 (make-wave-train :size foflen :frequency frq)))
(let ((foftab (mus-data wt0)))
......@@ -416,7 +411,7 @@
(outa i (* (env ampf) (wave-train wt0 (* (env vibenv) (oscil vibr)))))))))
(define (simple-amb beg dur freq amp)
(let ((os (if (> freq 1) (make-oscil freq) (make-rand freq)))
(let ((os ((if (> freq 1) make-oscil make-rand) freq))
(start (seconds->samples beg))
(end (seconds->samples (+ beg dur))))
(do ((i start (+ i 1))) ((= i end))
......@@ -534,7 +529,7 @@
(define (simple-ina beg dur amp file)
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
(fil (open-input file)))
(fil (make-file->sample file)))
(do ((i start (+ i 1))
(ctr 0 (+ ctr 1)))
((= i end))
......@@ -864,10 +859,10 @@
(format () "~A ~A~%" (xs 1) (mus-xcoeff flt 1))))
(let ((data (mus-data flt)))
(if (> (data 0) 1.0) (format () "data overflow? ~A~%" (data 0))))
(let ((is intdat)
(fs fltdat))
(if (not (= (is 1) 3)) (format () "intdat let: ~A~%" (is 1)))
(if (> (abs (- (fs 1) 3.14)) .001) (format () "fltdat let: ~A~%" (fs 1))))
(if (not (= (intdat 1) 3))
(format () "intdat let: ~A~%" (intdat 1)))
(if (> (abs (- (fltdat 1) 3.14)) 0.001)
(format () "fltdat let: ~A~%" (fltdat 1)))
(outa i (* amp (filter flt (oscil os)))))))
(define (sample-arrintp beg dur freq amp)
......@@ -1125,8 +1120,7 @@
(modulator-phase-incr (hz->radians (* mc-ratio freq))))
(do ((i beg (+ i 1)))
((= i end))
(let* ((modulation (* index (sin modulator-phase)))
(pm-val (* amp (sin (+ carrier-phase modulation)))))
(let ((pm-val (* amp (sin (+ carrier-phase (* index (sin modulator-phase)))))))
;; no integration in phase modulation (it's a phase change)
(set! carrier-phase (+ carrier-phase carrier-phase-incr))
(set! modulator-phase (+ modulator-phase modulator-phase-incr))
......@@ -1221,7 +1215,7 @@
((= i n))
(set! (modulators i) (hz->radians (* freq (mc-ratios i) (mod-phases i))))
(set! (fm-indices i) (hz->radians (* freq (indexes i) (mc-ratios i)))))
(let ((ob (make-oscil-bank modulators (make-float-vector n 0.0) fm-indices #t)))
(let ((ob (make-oscil-bank modulators (make-float-vector n) fm-indices #t)))
(do ((i start (+ i 1)))
((= i end))
(outa i (* amp (oscil cr (oscil-bank ob))))))))))
......@@ -1233,7 +1227,7 @@
(frq-scl (hz->radians frequency)))
(let ((maxdev (* frq-scl fm-index)))
(let ((index1 (* maxdev (/ 5.0 (log frequency))))
(index2 (* maxdev 3.0 (/ (- 8.5 (log frequency)) (+ 3.0 (/ frequency 1000)))))
(index2 (/ (* maxdev 3.0 (- 8.5 (log frequency))) (+ 3.0 (/ frequency 1000))))
(index3 (* maxdev (/ 4.0 (sqrt frequency))))
(carrier (make-oscil frequency))
(fmosc1 (make-oscil frequency))
......@@ -1262,7 +1256,7 @@
(md (make-oscil (* freq modrat)))
(ca (make-oscil (* freq casrat) caspha))
(fm-ind0 (hz->radians (* modind modrat freq)))
(fm-ind1 (hz->radians (* casind (/ casrat modrat) freq))))
(fm-ind1 (hz->radians (/ (* casind casrat freq) modrat))))
(do ((i start (+ i 1)))
((= i end))
(outa i (* amp
......@@ -1474,11 +1468,10 @@
(<= (cadr loop-data) (car loop-data)))
(error 'no-loop-positions)
(let* ((loop-start (car loop-data))
(loop-end (cadr loop-data))
(loop-length (+ 1 (- loop-end loop-start)))
(loop-length (- (+ (cadr loop-data) 1) loop-start))
(sound-section (float-vector-scale! (file->array sound 0 loop-start loop-length (make-float-vector loop-length)) amp))
(original-loop-duration (/ loop-length (srate sound)))
(tbl (make-table-lookup :frequency (/ freq original-loop-duration) :wave sound-section)))
(tbl (make-table-lookup :frequency (/ (* freq (srate sound)) loop-length)
:wave sound-section)))
;; "freq" here is how fast we read (transpose) the sound -- 1.0 returns the original
(do ((i beg (+ i 1)))
((= i end))
......@@ -1585,8 +1578,7 @@
(float-vector 0.0 (hz->radians frequency) (* 1.0 n)))
(define (sndclmdoc-sum-of-odd-sines gen fm)
(let* ((angle (gen 0))
(a2 (* angle 0.5))
(let* ((a2 (* (gen 0) 0.5))
(n (gen 2))
(den (* n (sin a2)))
(result (if (< (abs den) 1.0e-9)
......@@ -1650,12 +1642,12 @@
(let ((foftab (make-float-vector foflen)))
(let ((start (seconds->samples beg))
(end (seconds->samples (+ beg dur)))
(ampf (make-env :envelope (or ae (list 0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
(ampf (make-env :envelope (or ae '(0 0 25 1 75 1 100 0)) :scaler amp :duration dur))
(frq0 (hz->radians f0))
(frq1 (hz->radians f1))
(frq2 (hz->radians f2))
(vibr (make-oscil 6))
(vibenv (make-env :envelope (or ve (list 0 1 100 1)) :scaler vib :duration dur))
(vibenv (make-env :envelope (or ve '(0 1 100 1)) :scaler vib :duration dur))
(win-freq (/ (* 2 pi) foflen))
(wt0 (make-wave-train :wave foftab :frequency frq)))
(do ((i 0 (+ i 1)))
......@@ -1743,11 +1735,9 @@
(outa i (convolve ff)))))
(definstrument (sndclmdoc-granulate-sound file beg dur (orig-beg 0.0) (exp-amt 1.0))
(let* ((f-srate (srate file))
(f-start (round (* f-srate orig-beg)))
(f (make-readin file :start f-start))
(st (seconds->samples beg))
(new-dur (or dur (- (mus-sound-duration file) orig-beg))))
(let ((f (make-readin file :start (round (* (srate file) orig-beg))))
(st (seconds->samples beg))
(new-dur (or dur (- (mus-sound-duration file) orig-beg))))
(let ((exA (make-granulate :input f :expansion exp-amt))
(nd (+ st (seconds->samples new-dur))))
(do ((i st (+ i 1)))
......
This diff is collapsed.
This diff is collapsed.