Re: sound synthesis
From: Wade Humeniuk (whumeniu-delete-this-antispam-device_at_telus.net)
Date: 11/26/04
- Next message: Pascal Costanza: "Re: What do Users really want?"
- Previous message: William Bland: "Re: What do Users really want?"
- In reply to: Frank Buss: "Re: sound synthesis"
- Next in thread: Frank Buss: "Re: sound synthesis"
- Reply: Frank Buss: "Re: sound synthesis"
- Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
Date: Fri, 26 Nov 2004 17:31:50 GMT
Frank Buss wrote:
> Wade Humeniuk <whumeniu-delete-this-antispam-device@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)))
- Next message: Pascal Costanza: "Re: What do Users really want?"
- Previous message: William Bland: "Re: What do Users really want?"
- In reply to: Frank Buss: "Re: sound synthesis"
- Next in thread: Frank Buss: "Re: sound synthesis"
- Reply: Frank Buss: "Re: sound synthesis"
- Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]
Relevant Pages
|
