From: Frank Buss
Subject: sound synthesis
Date: Fri, 26 Nov 2004 00:13:49 +0000
Message-ID: <co5sft$bgl$1@newsreader2.netcologne.de> For my Lisp CPU (http://www.frank-buss.de/lispcpu/ , still not much to
see) I need some sound output. I think simple FM synthesis is sufficient.
For testing it, I've written a WAVE-writer and created a door bell with
ADSR envelope for the notes. Looks like for this kind of calculations
LispWorks is much better than CLISP:
CLISP: 17.3 seconds
LispWorks: 1.4 seconds
I hope I can do this in real time on the FPGA.
Output converted to MP3: http://www.frank-buss.de/tmp/test.mp3
The code:
(defun make-samples-array (sample-rate seconds &optional function)
(declare (float sample-rate seconds))
(let* ((sample-count (round (* sample-rate seconds)))
(samples (make-array sample-count
:element-type 'float
:initial-element 0.0)))
(when function
(dotimes (i sample-count)
(let ((time (float (* (/ seconds sample-count) i))))
(setf (aref samples i) (funcall function time)))))
samples))
(defun write-wave (sample-rate samples)
(with-open-file (s "c:/tmp/test.wav"
:direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(flet ((write-uint-16 (uint-16)
(write-byte (logand #xff uint-16) s)
(write-byte (logand #xff (ash uint-16 -8)) s))
(write-uint-32 (uint-32)
(write-byte (logand #xff uint-32) s)
(write-byte (logand #xff (ash uint-32 -8)) s)
(write-byte (logand #xff (ash uint-32 -16)) s)
(write-byte (logand #xff (ash uint-32 -24)) s)))
(write-uint-32 #x46464952)
(write-uint-32 (+ (* 2 (length samples)) 36))
(write-uint-32 #x45564157)
(write-uint-32 #x20746d66)
(write-uint-32 16)
(write-uint-16 1)
(write-uint-16 1)
(write-uint-32 (round sample-rate))
(write-uint-32 (round (* 2.0 sample-rate)))
(write-uint-16 2)
(write-uint-16 16)
(write-uint-32 #x61746164)
(write-uint-32 (* 2 (length samples)))
(dotimes (i (length samples))
(write-uint-16 (round (* 32767.0 (aref samples i))))))))
(defun mix (target-samples source-samples start sample-rate)
(let ((ofs (round (* sample-rate start))))
(dotimes (i (length source-samples))
(incf (aref target-samples (+ ofs i))
(aref source-samples i)))))
(defun normalize (samples)
(let ((max-sample 0)
(min-sample 0))
(dotimes (i (length samples))
(let ((sample (aref samples i)))
(when (< sample min-sample) (setf min-sample sample))
(when (> sample max-sample) (setf max-sample sample))))
(setf max-sample (max (- min-sample) max-sample))
(dotimes (i (length samples))
(setf (aref samples i) (/ (aref samples i) max-sample)))))
(defparameter *WARN-ON-FLOATING-POINT-CONTAGION* nil)
(defun adsr-generator (time
sustain-time
attack-time
decay-time
sustain-factor
release-time)
(declare (float time sustain-time
attack-time decay-time sustain-factor release-time))
(let* ((t1 attack-time)
(t2 (+ t1 decay-time))
(t3 (+ t2 sustain-time))
(t4 (+ t3 release-time)))
(cond ((< time 0.0) 0.0)
((<= time t1) (/ time attack-time))
((<= time t2) (+ 1.0
(* (/ (- 1.0 sustain-factor) decay-time)
(- t1 time))))
((<= time t3) sustain-factor)
((<= time t4) (+ sustain-factor
(* (/ sustain-factor release-time)
(- t3 time))))
(t 0.0))))
(defun fm-gong (time freq)
(declare (float time freq))
(let* ((adsr (adsr-generator time 1.0 0.01 0.1 0.8 1.0))
(adsr-freq (adsr-generator time .3 0.001 0.3 0.3 1.0))
(mod-freq (* 1.98 freq))
(sin-freq (* 5.0 adsr-freq (sin (* 2 pi mod-freq time)))))
(sin (* adsr (sin (+ (* 2 pi freq time) sin-freq))))))
(defun make-gong (sample-rate freq)
(declare (float sample-rate freq))
(make-samples-array sample-rate
3.0
#'(lambda (time) (fm-gong time freq))))
(defun three-gongs ()
(let* ((note-exp (expt 2 (/ 1 12)))
(note-base 200)
(note-1 (float (* note-base (expt note-exp 7))))
(note-2 (float (* note-base (expt note-exp 4))))
(note-3 (float (* note-base (expt note-exp 0))))
(sample-rate 22050.0)
(samples (make-samples-array sample-rate 4.7))
(gong1 (make-gong sample-rate note-1))
(gong2 (make-gong sample-rate note-2))
(gong3 (make-gong sample-rate note-3)))
(mix samples gong1 0.0 sample-rate)
(mix samples gong2 0.8 sample-rate)
(mix samples gong3 1.6 sample-rate)
(normalize samples)
(write-wave sample-rate samples)))
--
Frank Bu�, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de From: Rainer Joswig
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 00:57:27 +0000
Message-ID: <joswig-D19230.01572726112004@news-50.dca.giganews.com> In article <············@newsreader2.netcologne.de>,
Frank Buss <··@frank-buss.de> wrote:
> For my Lisp CPU (http://www.frank-buss.de/lispcpu/ , still not much to
> see) I need some sound output. I think simple FM synthesis is sufficient.
> For testing it, I've written a WAVE-writer and created a door bell with
> ADSR envelope for the notes. Looks like for this kind of calculations
> LispWorks is much better than CLISP:
>
> CLISP: 17.3 seconds
> LispWorks: 1.4 seconds
>
> I hope I can do this in real time on the FPGA.
For a more comprehensive system for doing sound synthesis
with Lisp see: Common Lisp Music
http://ccrma.stanford.edu/software/clm/ From: Frank Buss
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 01:40:56 +0000
Message-ID: <co61j8$j0j$1@newsreader2.netcologne.de> Rainer Joswig <······@lisp.de> wrote:
> For a more comprehensive system for doing sound synthesis
> with Lisp see: Common Lisp Music
>
> http://ccrma.stanford.edu/software/clm/
thanks, there are really some good ideas from many other programs
in this library.
I wonder if it is possible to write a cool demo in Lisp, like the ones
at http://www.farb-rausch.com/ , for example the several minutes long
demo "the product":
http://www.scene.org/file.php?file=/demos/groups/farb-rausch/fr08_final.zip&fileinfo
Needs Windows and DirectX 8, but has nice synthesized sound and graphics
and is only 64 kB long! Another good idea for my Lisp CPU :-)
--
Frank Bu�, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de From: Wade Humeniuk
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 02:11:55 +0000
Message-ID: <Lhwpd.190460$df2.190346@edtnps89> Frank Buss wrote:
> For my Lisp CPU (http://www.frank-buss.de/lispcpu/ , still not much to
> see) I need some sound output. I think simple FM synthesis is sufficient.
> For testing it, I've written a WAVE-writer and created a door bell with
> ADSR envelope for the notes. Looks like for this kind of calculations
> LispWorks is much better than CLISP:
>
> CLISP: 17.3 seconds
> LispWorks: 1.4 seconds
>
This is great. I added a few declarations and changed write-wave slightly.
It now runs twice as fast! Thanks Frank! Hope you do not mind.
Wade
Before
WAVE 2 > (time (three-gongs))
Timing the evaluation of (THREE-GONGS)
; Loading fasl file C:\Program Files\Xanalys\LispWorks\lib\4-3-0-0\modules\util\callcoun.fsl
user time = 1.632
system time = 0.010
Elapsed time = 0:00:02
Allocation = 94344048 bytes standard / 3542 bytes conses
0 Page faults
Calls to %EVAL 33
NIL
After
WAVE 61 > (time (three-gongs))
Timing the evaluation of (THREE-GONGS)
user time = 0.711
system time = 0.000
Elapsed time = 0:00:00
Allocation = 39908840 bytes standard / 3729 bytes conses
0 Page faults
Calls to %EVAL 33
NIL
WAVE 62 >
(in-package :wave)
(defun make-samples-array (sample-rate seconds &optional function)
(declare (float sample-rate seconds))
(let* ((sample-count (round (* sample-rate seconds)))
(samples (make-array sample-count
:element-type 'float
:initial-element 0.0)))
(when function
(dotimes (i sample-count)
(let ((time (float (* (/ seconds sample-count) i))))
(setf (aref samples i) (funcall function time)))))
samples))
(defun write-wave (sample-rate samples)
(declare (type (simple-array float (*)) samples)
(optimize (speed 3) #+lispworks(float 0)))
(with-open-file (s "c:/tmp/test.wav"
:direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(flet ((write-uint-16 (uint-16)
(write-byte (ldb (byte 8 0) uint-16) s)
(write-byte (ldb (byte 8 8) uint-16) s))
(write-uint-32 (uint-32)
(write-byte (ldb (byte 8 0) uint-32) s)
(write-byte (ldb (byte 8 8) uint-32) s)
(write-byte (ldb (byte 8 16) uint-32) s)
(write-byte (ldb (byte 8 24) uint-32) s)))
(write-uint-32 #x46464952)
(write-uint-32 (+ (* 2 (length samples)) 36))
(write-uint-32 #x45564157)
(write-uint-32 #x20746d66)
(write-uint-32 16)
(write-uint-16 1)
(write-uint-16 1)
(write-uint-32 (round sample-rate))
(write-uint-32 (round (* 2.0 sample-rate)))
(write-uint-16 2)
(write-uint-16 16)
(write-uint-32 #x61746164)
(write-uint-32 (* 2 (length samples)))
(fdotimes (i (length samples))
(write-uint-16 (round (* 32767.0s0 (aref samples i))))))))
(defun mix (target-samples source-samples start sample-rate)
(declare (type (simple-array float (*)))
(float start sample-rate)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let ((ofs (round (* sample-rate start))))
(dotimes (i (length source-samples))
(incf (aref target-samples (+ ofs i))
(aref source-samples i)))))
(defun normalize (samples)
(declare (type (simple-array float (*)) samples)
(optimize (speed 3) #+lispworks(float 0) (safety 0)))
(let ((max-sample 0.0s0)
(min-sample 0.0s0))
(declare (float max-sample min-sample))
(dotimes (i (length samples))
(let ((sample (aref samples i)))
(declare (float sample))
(when (< sample min-sample) (setf min-sample sample))
(when (> sample max-sample) (setf max-sample sample))))
(setf max-sample (max (- min-sample) max-sample))
(dotimes (i (length samples))
(setf (aref samples i) (/ (aref samples i) max-sample)))))
(defparameter *WARN-ON-FLOATING-POINT-CONTAGION* nil)
(defun adsr-generator (time
sustain-time
attack-time
decay-time
sustain-factor
release-time)
(declare (float time sustain-time
attack-time decay-time sustain-factor release-time)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let* ((t1 attack-time)
(t2 (+ t1 decay-time))
(t3 (+ t2 sustain-time))
(t4 (+ t3 release-time)))
(declare (float t1 t2 t3 t4))
(cond ((< time 0.0s0) 0.0s0)
((<= time t1) (/ time attack-time))
((<= time t2) (+ 1.0s0
(* (/ (- 1.0s0 sustain-factor) decay-time)
(- t1 time))))
((<= time t3) sustain-factor)
((<= time t4) (+ sustain-factor
(* (/ sustain-factor release-time)
(- t3 time))))
(t 0.0s0))))
(defun fm-gong (time freq)
(declare (float time freq)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let* ((adsr (adsr-generator time 1.0s0 0.01s0 0.1s0 0.8s0 1.0s0))
(adsr-freq (adsr-generator time .3s0 0.001s0 0.3s0 0.3s0 1.0s0))
(mod-freq (* 1.98s0 freq))
(sin-freq (* 5.0s0 adsr-freq (sin (* 2.0s0 pi mod-freq time)))))
(declare (float asdr asdr-freq mod-freq sin-freq))
(sin (* adsr (sin (+ (* 2 pi freq time) sin-freq))))))
(defun make-gong (sample-rate freq)
(declare (float sample-rate freq))
(make-samples-array sample-rate
3.0
#'(lambda (time) (fm-gong time freq))))
(defun three-gongs ()
(let* ((note-exp (expt 2 (/ 1 12)))
(note-base 200)
(note-1 (float (* note-base (expt note-exp 7))))
(note-2 (float (* note-base (expt note-exp 4))))
(note-3 (float (* note-base (expt note-exp 0))))
(sample-rate 22050.0s0)
(samples (make-samples-array sample-rate 4.7))
(gong1 (make-gong sample-rate note-1))
(gong2 (make-gong sample-rate note-2))
(gong3 (make-gong sample-rate note-3)))
(mix samples gong1 0.0s0 sample-rate)
(mix samples gong2 0.8s0 sample-rate)
(mix samples gong3 1.6s0 sample-rate)
(normalize samples)
(write-wave sample-rate samples))) From: Wade Humeniuk
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 02:14:45 +0000
Message-ID: <pkwpd.190463$df2.82269@edtnps89> Oops made some sort of error in the code. The last few changes I made
broke it somehow.
Wade From: Wade Humeniuk
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 02:21:34 +0000
Message-ID: <Oqwpd.190465$df2.174631@edtnps89> Wade Humeniuk wrote:
> Oops made some sort of error in the code. The last few changes I made
> broke it somehow.
>
> Wade
Here is the corrected file. Not sure what I did wrong.
Changes to write-wave and added declarations. Thanks
again (if you did not get it the first time). This
is great!
Wade
(in-package :wave)
(defun make-samples-array (sample-rate seconds &optional function)
(declare (float sample-rate seconds))
(let* ((sample-count (round (* sample-rate seconds)))
(samples (make-array sample-count
:element-type 'float
:initial-element 0.0)))
(when function
(dotimes (i sample-count)
(let ((time (float (* (/ seconds sample-count) i))))
(setf (aref samples i) (funcall function time)))))
samples))
(defun write-wave (sample-rate samples)
(declare (type (simple-array float (*)) samples)
(optimize (speed 3) #+lispworks(float 0)))
(with-open-file (s "c:/tmp/test.wav"
:direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(flet ((write-uint-16 (uint-16)
(write-byte (ldb (byte 8 0) uint-16) s)
(write-byte (ldb (byte 8 8) uint-16) s))
(write-uint-32 (uint-32)
(write-byte (ldb (byte 8 0) uint-32) s)
(write-byte (ldb (byte 8 8) uint-32) s)
(write-byte (ldb (byte 8 16) uint-32) s)
(write-byte (ldb (byte 8 24) uint-32) s)))
(write-uint-32 #x46464952)
(write-uint-32 (+ (* 2 (length samples)) 36))
(write-uint-32 #x45564157)
(write-uint-32 #x20746d66)
(write-uint-32 16)
(write-uint-16 1)
(write-uint-16 1)
(write-uint-32 (round sample-rate))
(write-uint-32 (round (* 2.0 sample-rate)))
(write-uint-16 2)
(write-uint-16 16)
(write-uint-32 #x61746164)
(write-uint-32 (* 2 (length samples)))
(dotimes (i (length samples))
(write-uint-16 (round (* 32767.0s0 (aref samples i))))))))
(defun mix (target-samples source-samples start sample-rate)
(declare (type (simple-array float (*)))
(float start sample-rate)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let ((ofs (round (* sample-rate start))))
(dotimes (i (length source-samples))
(incf (aref target-samples (+ ofs i))
(aref source-samples i)))))
(defun normalize (samples)
(declare (type (simple-array float (*)) samples)
(optimize (speed 3) #+lispworks(float 0) (safety 0)))
(let ((max-sample 0.0s0)
(min-sample 0.0s0))
(declare (float max-sample min-sample))
(dotimes (i (length samples))
(let ((sample (aref samples i)))
(declare (float sample))
(when (< sample min-sample) (setf min-sample sample))
(when (> sample max-sample) (setf max-sample sample))))
(setf max-sample (max (- min-sample) max-sample))
(dotimes (i (length samples))
(setf (aref samples i) (/ (aref samples i) max-sample)))))
(defparameter *WARN-ON-FLOATING-POINT-CONTAGION* nil)
(defun adsr-generator (time
sustain-time
attack-time
decay-time
sustain-factor
release-time)
(declare (float time sustain-time
attack-time decay-time sustain-factor release-time)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let* ((t1 attack-time)
(t2 (+ t1 decay-time))
(t3 (+ t2 sustain-time))
(t4 (+ t3 release-time)))
(declare (float t1 t2 t3 t4))
(cond ((< time 0.0s0) 0.0s0)
((<= time t1) (/ time attack-time))
((<= time t2) (+ 1.0s0
(* (/ (- 1.0s0 sustain-factor) decay-time)
(- t1 time))))
((<= time t3) sustain-factor)
((<= time t4) (+ sustain-factor
(* (/ sustain-factor release-time)
(- t3 time))))
(t 0.0s0))))
(defun fm-gong (time freq)
(declare (float time freq)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let* ((adsr (adsr-generator time 1.0s0 0.01s0 0.1s0 0.8s0 1.0s0))
(adsr-freq (adsr-generator time .3s0 0.001s0 0.3s0 0.3s0 1.0s0))
(mod-freq (* 1.98s0 freq))
(sin-freq (* 5.0s0 adsr-freq (sin (* 2.0s0 pi mod-freq time)))))
(declare (float asdr asdr-freq mod-freq sin-freq))
(sin (* adsr (sin (+ (* 2 pi freq time) sin-freq))))))
(defun make-gong (sample-rate freq)
(declare (float sample-rate freq))
(make-samples-array sample-rate
3.0
#'(lambda (time) (fm-gong time freq))))
(defun three-gongs ()
(let* ((note-exp (expt 2 (/ 1 12)))
(note-base 200)
(note-1 (float (* note-base (expt note-exp 7))))
(note-2 (float (* note-base (expt note-exp 4))))
(note-3 (float (* note-base (expt note-exp 0))))
(sample-rate 22050.0s0)
(samples (make-samples-array sample-rate 4.7))
(gong1 (make-gong sample-rate note-1))
(gong2 (make-gong sample-rate note-2))
(gong3 (make-gong sample-rate note-3)))
(mix samples gong1 0.0s0 sample-rate)
(mix samples gong2 0.8s0 sample-rate)
(mix samples gong3 1.6s0 sample-rate)
(normalize samples)
(write-wave sample-rate samples))) From: Frank Buss
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 09:25:23 +0000
Message-ID: <co6sq3$1om$1@newsreader2.netcologne.de> Wade Humeniuk <····································@telus.net> wrote:
> Here is the corrected file. Not sure what I did wrong.
> Changes to write-wave and added declarations.
the declarations and using short float helped, now it is much faster:
CLISP 7.80 s and LispWorks 1.0 s. With LispWorks now a GUI should be
possible, to adjust the values of the FM oscillators and ADSR envelope
interactively.
> This is great!
Thanks.
PS: my code is freeware, use it for whatever you want.
--
Frank Bu�, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de From: Wade Humeniuk
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 17:31:50 +0000
Message-ID: <aMJpd.8679$VL6.1070@clgrps13> Frank Buss wrote:
> Wade Humeniuk <····································@telus.net> wrote:
>
>
>>Here is the corrected file. Not sure what I did wrong.
>>Changes to write-wave and added declarations.
>
>
> the declarations and using short float helped, now it is much faster:
> CLISP 7.80 s and LispWorks 1.0 s. With LispWorks now a GUI should be
> possible, to adjust the values of the FM oscillators and ADSR envelope
> interactively.
>
As an exercise for myself I have massaged the code some more. I got
another increase in speed. LW does not have a very good dotimes, so
I replaced that and a few other mods.
Wade
Before:
WAVE 4 > (time (three-gongs))
Timing the evaluation of (THREE-GONGS)
user time = 0.941
system time = 0.000
Elapsed time = 0:00:01
Allocation = 45042080 bytes standard / 6743 bytes conses
0 Page faults
Calls to %EVAL 33
NIL
After:
WAVE 27 > (time (three-gongs))
Timing the evaluation of (THREE-GONGS)
user time = 0.450
system time = 0.000
Elapsed time = 0:00:01
Allocation = 24174736 bytes standard / 3476 bytes conses
0 Page faults
Calls to %EVAL 33
NIL
(in-package :wave)
(defmacro fdotimes ((i limit) &body body)
(let ((block (gensym "block"))
(iterate (gensym "iterate"))
(below (gensym "below")))
`(block ,block
(prog ((,i 0) (,below ,limit))
(declare (fixnum ,i ,below))
,iterate
(unless (< ,i ,below) (return-from ,block nil))
,@body
(incf ,i)
(go ,iterate)))))
(defun write-wave (sample-rate samples)
(declare (type (simple-array float (*)) samples)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(with-open-file (s "c:/tmp/test.wav"
:direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(flet ((write-uint-16 (uint-16)
(write-byte (ldb (byte 8 0) uint-16) s)
(write-byte (ldb (byte 8 8) uint-16) s))
(write-uint-32 (uint-32)
(write-byte (ldb (byte 8 0) uint-32) s)
(write-byte (ldb (byte 8 8) uint-32) s)
(write-byte (ldb (byte 8 16) uint-32) s)
(write-byte (ldb (byte 8 24) uint-32) s)))
(write-uint-32 #x46464952)
(write-uint-32 (+ (* 2 (length samples)) 36))
(write-uint-32 #x45564157)
(write-uint-32 #x20746d66)
(write-uint-32 16)
(write-uint-16 1)
(write-uint-16 1)
(write-uint-32 (round sample-rate))
(write-uint-32 (round (* 2.0 sample-rate)))
(write-uint-16 2)
(write-uint-16 16)
(write-uint-32 #x61746164)
(write-uint-32 (* 2 (length samples)))
(map nil (lambda (elt)
(declare (float elt) (inline write-unit-16))
(write-uint-16 (round (* 32767 elt))))
samples))))
(defun mix (target-samples source-samples start sample-rate)
(declare (type (simple-array float (*)) target-samples source-samples)
(float start sample-rate)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let ((ofs (round (* sample-rate start))))
(fdotimes (i (length source-samples))
(incf (aref target-samples (+ ofs i))
(aref source-samples i)))))
(defun normalize (samples)
(declare (type (simple-array float (*)) samples)
(optimize (speed 3) #+lispworks(float 0) (safety 0)))
(let ((max-sample 0.0s0)
(min-sample 0.0s0))
(declare (float max-sample min-sample))
(fdotimes (i (length samples))
(let ((sample (aref samples i)))
(declare (float sample))
(when (< sample min-sample) (setf min-sample sample))
(when (> sample max-sample) (setf max-sample sample))))
(setf max-sample (max (- min-sample) max-sample))
(fdotimes (i (length samples))
(setf (aref samples i) (/ (aref samples i) max-sample)))))
(defparameter *WARN-ON-FLOATING-POINT-CONTAGION* nil)
(declaim (inline adsr-generator)
(ftype (function (float float float float float float) float) adsr-generator))
(defun adsr-generator (time
sustain-time
attack-time
decay-time
sustain-factor
release-time)
(declare (float time sustain-time
attack-time decay-time sustain-factor release-time)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(cond ((< time 0.0s0) 0.0s0)
((<= time attack-time) (/ time attack-time))
(t
(let* ((t1 attack-time)
(t2 (+ t1 decay-time))
(t3 (+ t2 sustain-time))
(t4 (+ t3 release-time)))
(declare (float t2 t3 t4))
(cond ((<= time t2) (+ 1.0s0
(* (/ (- 1.0s0 sustain-factor) decay-time)
(- t1 time))))
((<= time t3) sustain-factor)
((<= time t4) (+ sustain-factor
(* (/ sustain-factor release-time)
(- t3 time))))
(t 0.0s0))))))
(defun make-samples-array (sample-rate seconds &optional function)
(declare (float sample-rate seconds)
(optimize (speed 3) #+lispworks(float 0) (safety 0)))
(let* ((sample-count (round (* sample-rate seconds)))
(samples (make-array sample-count
:element-type 'float
:initial-element 0.0s0)))
(when function
(fdotimes (i sample-count)
(setf (aref samples i)
(funcall function (float (* (/ seconds sample-count) (float i)))))))
samples))
(defun fm-gong (time freq)
(declare (float time freq) (inline adsr-generator)
(optimize (speed 3) (safety 0) #+lispworks(float 0)))
(let* ((adsr (adsr-generator time 1.0s0 0.01s0 0.1s0 0.8s0 1.0s0))
(adsr-freq (adsr-generator time .3s0 0.001s0 0.3s0 0.3s0 1.0s0))
(mod-freq (* 1.98s0 freq))
(sin-freq (* 5.0s0 adsr-freq (sin (* 2.0s0 pi mod-freq time)))))
(declare (float asdr asdr-freq mod-freq sin-freq))
(sin (* adsr (sin (+ (* 2 pi freq time) sin-freq))))))
(defun make-gong (sample-rate freq)
(declare (float sample-rate freq)
(optimize (speed 3) #+lispworks(float 0) (safety 0)))
(let* ((samples (make-samples-array sample-rate 3.0s0))
(sample-count (length samples))
(fsample-count (float sample-count)))
(declare (float fsample-count)
(type (simple-array float (*)) samples))
(fdotimes (i sample-count)
(setf (aref samples i)
(fm-gong (* (/ 3.0s0 fsample-count) (float i)) freq)))
samples))
(defun three-gongs ()
(let* ((note-exp (expt 2 (/ 1 12)))
(note-base 200)
(note-1 (float (* note-base (expt note-exp 7))))
(note-2 (float (* note-base (expt note-exp 4))))
(note-3 (float (* note-base (expt note-exp 0))))
(sample-rate 22050.0s0)
(samples (make-samples-array sample-rate 4.7))
(gong1 (make-gong sample-rate note-1))
(gong2 (make-gong sample-rate note-2))
(gong3 (make-gong sample-rate note-3)))
(mix samples gong1 0.0s0 sample-rate)
(mix samples gong2 0.8s0 sample-rate)
(mix samples gong3 1.6s0 sample-rate)
(normalize samples)
(write-wave sample-rate samples))) From: Frank Buss
Subject: Re: sound synthesis
Date: Fri, 26 Nov 2004 17:48:13 +0000
Message-ID: <co7q8t$2bj$2@newsreader2.netcologne.de> Wade Humeniuk <····································@telus.net> wrote:
> As an exercise for myself I have massaged the code some more. I got
> another increase in speed. LW does not have a very good dotimes, so
> I replaced that and a few other mods.
I've tried it with this macro:
(defmacro fdotimes ((i limit) &body body)
`(dotimes (,i ,limit) ,@body))
and there is no difference in the time, but the "inline" and other
optimizations helps, now it runs in 0.68 seconds on my computer.
--
Frank Bu�, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de