?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Convert Russian language Texinfo files from CP1251 to UTF-8.
[maxima.git] / share / sound / sound.lisp
blob54b48d8cc7901b73191cf2977b47b7542d8d639a
1 ;;; COPYRIGHT NOTICE
2 ;;;
3 ;;; Copyright (C) 2009-2015 Mario Rodriguez Riotorto
4 ;;;
5 ;;; This program is free software; you can redistribute
6 ;;; it and/or modify it under the terms of the
7 ;;; GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 2
9 ;;; of the License, or (at your option) any later version.
10 ;;;
11 ;;; This program is distributed in the hope that it
12 ;;; will be useful, but WITHOUT ANY WARRANTY;
13 ;;; without even the implied warranty of MERCHANTABILITY
14 ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details at
16 ;;; http://www.gnu.org/copyleft/gpl.html
17
18 ;;; This is a Maxima sound package.
19
20 ;;; For questions, suggestions, bugs and the like, feel free
21 ;;; to contact me at
22 ;;; mario @@@ edu DOT xunta DOT es
23
24
25 ($put '$sound 0.0 '$version)
26
27
28 ;; load package 'draw'
29 (when (null ($get '$draw '$version))
30 ($load "draw"))
31
32 ;; load package 'distrib'
33 (when (null ($get '$distrib '$version))
34 ($load "distrib"))
35
36 ;; load package 'numericalio'
37 ($load "numericalio")
38
39 ;; load package 'stringproc'
40 ($load "stringproc")
41
42
43
44 (defvar $sound_sample_rate 16384)
45 (defvar $sound_sample nil)
46
47 (defun $sound_sample_size ()
48 (when (arrayp $sound_sample)
49 (second (array-dimensions $sound_sample))))
50
51 (defun $sound_sample_channels ()
52 (when (arrayp $sound_sample)
53 (first (array-dimensions $sound_sample))))
54
55 (defun $sound_sample_list (chn)
56 (when (or (not (integerp chn))
57 (< chn 0)
58 (> chn ($sound_sample_channels)))
59 (merror "sound: incorrect number of channels"))
60 (let* ((n ($sound_sample_size))
61 (arr (make-array n
62 :element-type 'flonum
63 :initial-element 0.0)))
64 (declare (type fixnum n)
65 (type (simple-array flonum (*)) arr))
66 (dotimes (s n)
67 (setf (aref arr s) (aref $sound_sample 0 s)))
68 ($listarray arr)))
69
70
71
72 ;; This variable stores actual sound options
73 (defvar *sound-options* (make-hash-table))
74
75 (defstruct a-wave
76 sample ; an array to store the samples of this wave
77 channel ; channel number
78 att-coef ; attenuation coefficients for the main wave and its delays
79 repeat-at) ; when must the wave be repeated
80
81
82
83 ;; This variable stores user defaults
84 (defvar *user-sound-default-options* '())
85
86 (defun $set_sound_defaults (&rest opts)
87 (setf *user-sound-default-options* opts)
88 (cons '(mlist) opts))
89
90
91
92 ;; Sets default values of sound options
93 (defun ini-sound-options ()
94 (setf
95 (gethash '$channel *sound-options*) 1
96 (gethash '$file_name *sound-options*) "maxout"
97 (gethash '$file_format *sound-options*) '$wav
98 (gethash '$oscillator *sound-options*) '(($sine) 1.0)
99 (gethash '$envelope *sound-options*) '$none
100 (gethash '$noise_generator *sound-options*) '$none
101 (gethash '$attenuation_coef *sound-options*) '((mlist) 1.0)
102 (gethash '$normalize *sound-options*) '$auto
103 (gethash '$player *sound-options*) '$none
104 (gethash '$player_options *sound-options*) '$none
105 (gethash '$draw_wave_options *sound-options*) '((mlist))
106 (gethash '$draw_wave *sound-options*) nil
107 ))
108
109
110
111 (ini-sound-options)
112
113
114
115 ;; Gives value of option
116 (defun get-sound-option (opt) (gethash opt *sound-options*))
117
118
119
120 (defun update-sound-option (opt val)
121 (case opt
122
123 ($channel ; defined as a non negative integer
124 (if (and (integerp val)
125 (plusp val))
126 (setf (gethash opt *sound-options*) val)
127 (merror "sound: illegal channel: ~M " val)))
128
129 ($file_name
130 (setf (gethash opt *sound-options*) ($sconcat val)))
131
132 ($file_format ; defined as a wav or txt
133 (setf val ($concat val))
134 (if (member val '($wav $txt))
135 (setf (gethash opt *sound-options*) val)
136 (merror "sound: illegal file_format option: ~M " val)))
137
138 ($oscillator
139 (when ($atom val)
140 (merror "sound: oscillator must be an expression"))
141 (cond
142 ((equal ($op val) '$sine)
143 (let ((param (rest ($float ($args val)))))
144 (unless (every #'(lambda (z) (or (floatp z)
145 (and ($listp z)
146 (= ($length z) 2)
147 (floatp (cadr z))
148 (> (cadr z) 0)
149 (floatp (caddr z))
150 (<= 0.0 (caddr z))
151 (<= (caddr z) 1.0))))
152 param)
153 (merror "sound: incorrect argument(s) in sine oscillator"))
154 (setf (gethash opt *sound-options*)
155 (cons (list '$sine 'simp) param))) )
156 ((member ($op val) '($rectangle $triangle))
157 (let ((param ($float (cadr val))))
158 (unless (and (floatp param )
159 (> param 0.0)
160 (< param 1.0))
161 (merror "sound: incorrect argument in ~M oscillator" ($op val)))
162 (setf (gethash opt *sound-options*) val)))
163 (t
164 (merror "sound: oscillator not recognized"))))
165
166 ($envelope
167 (cond
168 ((and ($atom val)
169 (equal val '$none))
170 (setf (gethash opt *sound-options*) val))
171 (($atom val)
172 (merror "sound: unknown envelope"))
173 ((equal ($op val) '$pairs)
174 (let ((param (rest ($float ($args val)))))
175 (when (some #'(lambda (z) (or (not ($listp z))
176 (/= ($length z) 2)
177 (not (floatp (cadr z)))
178 (not (floatp (caddr z))) ))
179 param)
180 (merror "sound: incorrect arguments to pairs envelope"))
181 (setf (gethash opt *sound-options*) (cons (list '$pairs 'simp)
182 (map 'list #'rest param))) ))
183
184 ((equal ($op val) '$adsr)
185 (let ((param (rest ($float ($args val)))))
186 (when (or (/= (length param) 4)
187 (some #'(lambda (z) (or (not (floatp z)) (< z 0.0)))
188 param))
189 (merror "sound: adsr envelope needs four non negative arguments") )
190 (let ((attack (car param))
191 (decay (cadr param))
192 (sustain-level (caddr param))
193 (release (cadddr param)))
194 (when (or (> (+ attack decay release) 1.0)
195 (> sustain-level 1.0))
196 (merror "sound: incorrect arguments to adsr envelope"))
197 (setf (gethash opt *sound-options*) (list '($pairs simp)
198 (list 0.0 0.0)
199 (list attack 1.0)
200 (list (+ attack decay) sustain-level)
201 (list (- 1.0 release) sustain-level)
202 (list 1.0 0.0) )))))
203
204 ((equal ($op val) '$function)
205 (let ((param (rest ($float ($args val)))))
206 (when (or (/= ($length param) 3)
207 (not (floatp (nth 2 param)))
208 (not (floatp (nth 3 param)))
209 (not (< (nth 2 param) (nth 3 param))))
210 (merror "sound: incorrect arguments to function envelope"))
211 (setf (gethash opt *sound-options*) (cons (list '$function 'simp) param))))
212 (t
213 (merror "sound: unknown envelope type"))))
214
215 ($noise_generator
216 (cond
217 ((and ($atom val)
218 (equal val '$none))
219 (setf (gethash opt *sound-options*) val))
220 (($atom val)
221 (merror "sound: unknown noise generator"))
222 ((equal ($op val) '$gaussian)
223 (let ((param (rest ($float ($args val)))))
224 (when (or (/= (length param) 2)
225 (not (floatp (car param)))
226 (not (floatp (cadr param)))
227 (<= (cadr param) 0.0))
228 (merror "sound: gaussian noise generator is not correctly defined"))
229 (setf (gethash opt *sound-options*) (cons '($gaussian simp) param))))
230 ((equal ($op val) '$uniform)
231 (let ((param (rest ($float ($args val)))))
232 (when (or (/= (length param) 2)
233 (not (floatp (car param)))
234 (not (floatp (cadr param)))
235 (< (cadr param) (car param)))
236 (merror "sound: uniform noise generator is not correctly defined"))
237 (setf (gethash opt *sound-options*) (cons '($uniform simp) param))))
238 (t
239 (merror "sound: unknown noise generator"))))
240
241 ($attenuation_coef
242 (let ((coefs ($float val)))
243 (cond
244 ((and ($listp val)
245 (every #'floatp (rest coefs)))
246 (setf (gethash opt *sound-options*) coefs))
247 (t
248 (merror "sound: illegal attenuation coefficients specification")))))
249
250 ($player
251 (setf (gethash opt *sound-options*) val))
252
253 ($player_options
254 (setf (gethash opt *sound-options*) val))
255
256 ($draw_wave_options
257 (if ($listp val)
258 (setf (gethash opt *sound-options*) val)
259 (merror "sound: draw_wave_options must be a list of draw options")))
260
261 ($normalize
262 (cond
263 ((or (equal val '$auto)
264 (equal val '$none)
265 (and (integerp val)
266 (plusp val)
267 (<= val 32767)))
268 (setf (gethash opt *sound-options*) val))
269 (t
270 (merror "sound: illegal normalize option: ~M " val))))
271
272 ($draw_wave ; defined as true or false
273 (if (or (equal val t)
274 (null val))
275 (setf (gethash opt *sound-options*) val)
276 (merror "sound: non boolean value: ~M " val)))
277 ))
278
279
280
281 ;; Sets user default values of sound options
282 (defun sound-user-defaults ()
283 (dolist (x *user-sound-default-options*)
284 (if (equal ($op x) "=")
285 (update-sound-option ($lhs x) ($rhs x))
286 (merror "sound: item ~M is not recognized as an option assignment" x))))
287
288
289
290 ;;;;;;;;;;;;;;;;;;;;;;;;
291 ;; ;;
292 ;; File functions ;;
293 ;; ;;
294 ;;;;;;;;;;;;;;;;;;;;;;;;
295
296
297
298 ;; Saves sound sample in plain text file, with one row per channel,
299 ;; and as many columns as samples.
300 (defun $save_sound_txt ()
301 ($write_data
302 $sound_sample
303 ($sconcat
304 (get-sound-option '$file_name)
305 ".txt")))
306
307
308
309 ;; wav format info : http://www.sonicspot.com/guide/wavefiles.html
310 (defun $save_sound_wav ()
311 (let ((num-chn (array-dimension $sound_sample 0))
312 (num-sam (array-dimension $sound_sample 1))
313 fname)
314 (declare (type fixnum num-chn num-sam))
315 (setf fname (get-sound-option '$file_name))
316 (with-open-file (out (plot-temp-file ($sconcat fname ".wav") t)
317 :direction :output
318 :if-exists :supersede
319 :element-type '(unsigned-byte 8))
320 (flet ((write16 (i)
321 (write-byte (logand #xff i) out)
322 (write-byte (logand #xff (ash i -8)) out))
323 (write32 (i)
324 (write-byte (logand #xff i) out)
325 (write-byte (logand #xff (ash i -8)) out)
326 (write-byte (logand #xff (ash i -16)) out)
327 (write-byte (logand #xff (ash i -24)) out)))
328 (write32 #x46464952) ; string "RIFF"
329 (write32 (+ (* 2 num-chn num-sam) 36)) ; filesize-8
330 (write32 #x45564157) ; string "WAVE"
331 (write32 #x20746d66) ; string "fmt "
332 (write32 16) ; format bytes
333 (write16 1) ; compression code
334 (write16 num-chn) ; number of channels
335 (write32 (round $sound_sample_rate)) ; sample rate
336 (write32 (round (* 2.0 $sound_sample_rate num-chn))) ; average bytes per second
337 (write16 (* 2 num-chn)) ; block align
338 (write16 16) ; significant bits per sample
339 (write32 #x61746164) ; string "data"
340 (write32 (* 2 num-chn num-sam))
341 (dotimes (s num-sam)
342 (dotimes (c num-chn)
343 (write16 (round (coerce (aref $sound_sample c s) 'single-float)))))))))
344
345
346
347 (defun $load_sound_wav (fname &optional (verbose t))
348 (declare (type simple-string fname))
349 (let ((file-size 0)
350 (compression-code 0)
351 (num-channels 0)
352 (n-samples-per-sec 0)
353 (average-bytes-per-second 0)
354 (block-align 0)
355 (n-bits-per-sample 0) ; bits for one sample
356 (total-bytes 0) ; bytes occupied by the wave
357 (n-bits-header 0) ; sample data position
358 (total-num-samples 0)
359 (num-samples 0))
360 (declare (type (unsigned-byte 16) compression-code num-channels
361 block-align n-bits-per-sample num-samples)
362 (type (unsigned-byte 32) file-size n-samples-per-sec
363 average-bytes-per-second total-bytes)
364 (type fixnum n-bits-header total-num-samples num-samples))
365 (with-open-file (in fname
366 :direction :input
367 :element-type '(unsigned-byte 8))
368 (flet ((read16 ()
369 (let ((dat1 (read-byte in))
370 (dat2 (read-byte in)))
371 (setf (ldb (byte 8 8) dat1) dat2)
372 dat1))
373 (read32 ()
374 (let ((dat1 (read-byte in))
375 (dat2 (read-byte in))
376 (dat3 (read-byte in))
377 (dat4 (read-byte in)))
378 (setf (ldb (byte 8 8) dat1) dat2)
379 (setf (ldb (byte 8 16) dat1) dat3)
380 (setf (ldb (byte 8 24) dat1) dat4)
381 dat1)) )
382 (unless (= (read32) #x46464952)
383 (merror "sound: file to read is not of RIFF structure"))
384 (setf file-size (read32))
385 (unless (= (read32) #x45564157)
386 (merror "sound: file to read is not of WAVE format"))
387
388 ; look for format specification and sample length
389 (loop
390 (let* ((next-header (read32))
391 (bytes (read32)))
392 (cond ((= next-header #x20746d66)
393 (setf compression-code (read16))
394 (setf num-channels (read16))
395 (setf n-samples-per-sec (read32))
396 (setf average-bytes-per-second (read32))
397 (setf block-align (read16))
398 (setf n-bits-per-sample (read16))
399 ;; possible extra (ignored) format bytes
400 (dotimes (i (- bytes 16)) (read-byte in)))
401 ((= next-header #x61746164)
402 (setf total-bytes bytes)
403 (return))
404 (t
405 (dotimes (i bytes) (read-byte in))))))
406 (setf n-bits-header (* 8 (file-position in)))))
407
408 ; with available parameters, let's read the file
409 (setf total-num-samples (/ (* 8 total-bytes) n-bits-per-sample))
410 (setf num-samples (/ total-num-samples num-channels))
411
412 (when verbose
413 (print (format nil "Number of channels.: ~a" num-channels))
414 (print (format nil "Samples per second.: ~a" n-samples-per-sec))
415 (print (format nil "Bits per sample....: ~a" n-bits-per-sample))
416 (print (format nil "Number of samples..: ~a" total-num-samples)))
417
418 (let ((sample-sequence (make-array total-num-samples
419 :element-type 'fixnum
420 :initial-element 0)))
421 (declare (type (simple-array fixnum *) sample-sequence))
422 (with-open-file (in fname
423 :direction :input
424 :element-type (if (= n-bits-per-sample 8)
425 `(unsigned-byte ,n-bits-per-sample)
426 `(signed-byte ,n-bits-per-sample)))
427 (file-position in (/ n-bits-header n-bits-per-sample))
428 (read-sequence sample-sequence in))
429 (list
430 '(mlist simp)
431 n-samples-per-sec
432 (cons
433 '(mlist simp)
434 (loop for k below num-samples collect
435 (cons
436 '(mlist simp)
437 (loop for j below num-channels collect
438 (aref sample-sequence (+ j (* k num-channels)))))))))))
439
440
441
442 (defun save-sound ()
443 (case (get-sound-option '$file_format)
444 ($wav ($save_sound_wav))
445 ($txt ($save_sound_txt))))
446
447
448
449 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
450 ;; ;;
451 ;; Draw & play functions ;;
452 ;; ;;
453 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
454
455
456
457 (defun $draw_sound ()
458 (let* ((num-chn (array-dimension $sound_sample 0))
459 (num-sam (array-dimension $sound_sample 1))
460 (time (coerce (/ num-sam $sound_sample_rate) 'flonum))
461 (array1d (make-array num-sam :element-type 'flonum)))
462 (declare (type fixnum num-chn num-sam)
463 (type flonum time)
464 (type (simple-array flonum *) array1d))
465 (sound-user-defaults)
466 ($apply
467 '$draw
468 (cons '(mlist simp)
469 (loop for c from 0 below num-chn
470 do (loop for s from 0 below num-sam
471 do (setf (aref array1d s) (aref $sound_sample c s)))
472 collect ($apply
473 '$gr2d
474 ($append
475 `((mlist)
476 ((mequal) $points_joined t)
477 ((mequal) $point_size 0)
478 ((mequal) $xrange_secondary ((mlist) 0 ,time))
479 ((mequal) $xtics_secondary $auto)
480 ((mequal) $color $blue)
481 ((mequal) $title ,($sconcat
482 "Sound wave. Channel-"
483 (1+ c))) )
484 (get-sound-option '$draw_wave_options)
485 (list
486 '(mlist simp)
487 (list '($points) ($listarray array1d))))))))))
488
489
490
491 ;; draw_sound for wxMaxima
492 (defun $wxdraw_sound ()
493 (let* ((num-chn (array-dimension $sound_sample 0))
494 (num-sam (array-dimension $sound_sample 1))
495 (time (coerce (/ num-sam $sound_sample_rate) 'flonum))
496 (array1d (make-array num-sam :element-type 'flonum)))
497 (declare (type fixnum num-chn num-sam)
498 (type flonum time)
499 (type (simple-array flonum *) array1d))
500 (sound-user-defaults)
501 ($apply
502 '$wxdraw
503 (cons '(mlist simp)
504 (loop for c from 0 below num-chn
505 do (loop for s from 0 below num-sam
506 do (setf (aref array1d s) (aref $sound_sample c s)))
507 collect ($apply
508 '$gr2d
509 ($append
510 `((mlist)
511 ((mequal) $points_joined t)
512 ((mequal) $point_size 0)
513 ((mequal) $xrange_secondary ((mlist) 0 ,time))
514 ((mequal) $xtics_secondary $auto)
515 ((mequal) $color $blue)
516 ((mequal) $title ,($sconcat
517 "Sound wave. Channel-"
518 (1+ c))) )
519 (loop for x in (get-sound-option '$draw_wave_options)
520 unless (or (equal '$terminal (nth 1 x))
521 (equal '$file_name (nth 1 x)))
522 collect x)
523 (list
524 '(mlist simp)
525 (list '($points) ($listarray array1d))))))))))
526
527
528
529
530 (defun $play_sound ()
531 (when (and (equal (get-sound-option '$file_format) '$wav)
532 (not (equal (get-sound-option '$player) '$none)))
533 (let
534 ((str (get-sound-option '$player))
535 (res1 nil)
536 (res2 nil))
537 (cond
538 ((string= *autoconf-windows* "true")
539 (setf res1 ($ssearch ":" str))
540 (setf res2 ($ssearch "\\" str))
541 (if (and res2 (>= res2 1) (not (and res1 (= res1 2))))
542 (setf res1 1)
543 (setf res1 nil)))
544 (t
545 (setf res1 ($ssearch "/" str))
546 (if (and res1 (> res1 1) (not (= res1 1)))
547 (setf res1 1)
548 (setf res1 nil))))
549 (setf res2 (get-sound-option '$player_options))
550 (if (equal res2 '$none)
551 (setf res2 ""))
552 (if res1
553 ($system (format nil "\"~a~a\" ~a \"~a.wav\""
554 ($first ($directory ($pathname_directory str)))
555 ($sconcat ($pathname_name str)
556 (if (null ($pathname_type str))
557 ""
558 ($sconcat "." ($pathname_type str))))
559 res2
560 (plot-temp-file (get-sound-option '$file_name) t)))
561 ($system (format nil "\"~a\" ~a \"~a.wav\""
562 str
563 res2
564 (plot-temp-file (get-sound-option '$file_name) t)))))))
565
566
567
568 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
569 ;; ;;
570 ;; Envelope functions ;;
571 ;; ;;
572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
573
574
575
576 (defun pairs-envelope (samp)
577 (let* ((n (length samp))
578 (args (rest ($args (get-sound-option '$envelope))))
579 (d (/ 1.0 n))
580 (np 0)
581 (counter 0)
582 (x 0.0)
583 (x1 0.0)
584 (x2 0.0)
585 (y 0.0)
586 (y1 0.0)
587 (y2 0.0)
588 (m 0.0))
589 (declare (type flonum d x x1 x2 y y1 y2 m)
590 (type fixnum n np counter))
591 ; order with respect to 1st coordinate
592 (setf args
593 (sort args
594 #'(lambda (p1 p2) (<= (first p1) (first p2)))))
595
596 ; is args a list of pairs in [0, 1]^2 ?
597 (when (some #'(lambda (z) (or (< (car z) 0.0)
598 (> (car z) 1.0)
599 (< (cadr z) 0.0)
600 (> (cadr z) 1.0) ))
601 args)
602 (merror "sound: arguments in pairs envelope must be in [0, 1]^2"))
603
604 ; add extremes x=0 and y=0 if not already present
605 (setf args
606 (append (if (= (caar args) 0.0)
607 nil
608 '((0.0 0.0)))
609 args
610 (if (= (caar (last args)) 1.0)
611 nil
612 '((1.0 0.0)) )))
613
614 ; apply envelope joining pairs with linear segments
615 (setf np (length args))
616 (setf counter 1)
617 (dotimes (k n)
618 (loop
619 (setf x1 (car (nth (1- counter) args)))
620 (setf x2 (car (nth counter args)))
621
622 (when (and (<= x1 x)
623 (< x x2))
624 (setf y1 (cadr (nth (1- counter) args)))
625 (setf y2 (cadr (nth counter args)))
626 (setf m (/ (- y2 y1) (- x2 x1)))
627 (setf y (+ y1 (* m (- x x1))))
628 (setf (aref samp k) (* (aref samp k) y))
629 (return))
630 (incf counter))
631 (setf x (+ x d)))))
632
633
634
635 (defun function-envelope (samp)
636 (let* ((n (length samp))
637 (args (rest ($args (get-sound-option '$envelope))))
638 (fcn (car args))
639 (var (cadr args))
640 (lim1 (caddr args))
641 (lim2 (cadddr args))
642 (d (/ (- lim2 lim1) n))
643 (xx lim1)
644 (y 0.0))
645 (declare (type fixnum n)
646 (type flonum lim1 lim2 d xx y))
647 (setq fcn (coerce-float-fun (meval `($float ,fcn)) `((mlist) ,var)))
648 (flet ((fun (x) (funcall fcn x)))
649 (dotimes (k n)
650 (setf y (fun xx))
651 (setf (aref samp k) (* (aref samp k) y))
652 (setf xx (+ xx d))))))
653
654
655
656 (defun apply-envelope (samp)
657 (unless (equal (get-sound-option '$envelope) '$none)
658 (let* ((env (get-sound-option '$envelope)))
659 (case ($op env)
660 ($pairs (pairs-envelope samp))
661 ($function (function-envelope samp)) ))))
662
663
664
665 ;;;;;;;;;;;;;;;;;;;;;;;;;
666 ;; ;;
667 ;; Noise functions ;;
668 ;; ;;
669 ;;;;;;;;;;;;;;;;;;;;;;;;;
670
671
672
673 (defun gaussian-noise (samp)
674 (let* ((n (length samp))
675 (param (rest (get-sound-option '$noise_generator)))
676 (gaussian-sample (rest (mfunction-call $random_normal (first param) (second param) n))) )
677 (dotimes (k n)
678 (setf (aref samp k) (+ (aref samp k) (nth k gaussian-sample))))))
679
680
681
682 (defun uniform-noise (samp)
683 (let* ((n (length samp))
684 (param (rest (get-sound-option '$noise_generator)))
685 (uniform-sample (rest (mfunction-call
686 $random_continuous_uniform
687 (first param)
688 (second param)
689 n))) )
690 (dotimes (k n)
691 (setf (aref samp k) (+ (aref samp k) (nth k uniform-sample))))))
692
693
694
695 (defun apply-noise (samp)
696 (unless (equal (get-sound-option '$noise_generator) '$none)
697 (let* ((noise (get-sound-option '$noise_generator)))
698 (case ($op noise)
699 ($gaussian (gaussian-noise samp))
700 ($uniform (uniform-noise samp))))))
701
702
703
704 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
705 ;; ;;
706 ;; Oscillator functions ;;
707 ;; ;;
708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
709
710
711
712 (defun apply-oscillator-model (samp per1-samp ampl)
713 (let ((xx 0.0))
714 (declare (type flonum xx))
715 (case ($op (get-sound-option '$oscillator))
716 ($sine
717 (let ((harmonics (cdr ($args (get-sound-option '$oscillator))))
718 (d (/ (* 2 pi) per1-samp))
719 (rampl 0.0)
720 (s 0.0)
721 harm)
722 (declare (type flonum d rampl s))
723 (dotimes (k per1-samp)
724 (setf s 0.0)
725 (dolist (h harmonics)
726 (cond
727 ((floatp h) ; user gives only the harmonic number
728 (setf harm h
729 rampl 1.0))
730 (t ; user gives a list with harmonic number and amplitude fraction
731 (setf harm (cadr h)
732 rampl (caddr h))))
733 (setf s (+ s (* rampl (sin (* harm xx))))))
734 (setf (aref samp k) (coerce (* ampl s) 'flonum))
735 (setf xx (+ xx d)))))
736
737 ($rectangle
738 (let ((param ($float (cadr ($args (get-sound-option '$oscillator)))))
739 (d (/ 1.0 per1-samp)))
740 (declare (type flonum d param))
741 (dotimes (k per1-samp)
742 (setf (aref samp k)
743 (coerce (if (< xx param) (- ampl) ampl) 'flonum))
744 (setf xx (+ xx d))) ))
745
746 ($triangle
747 (let ((param ($float (cadr ($args (get-sound-option '$oscillator)))))
748 (d (/ 1.0 per1-samp)))
749 (declare (type flonum d param))
750 (dotimes (k per1-samp)
751 (setf (aref samp k)
752 (coerce
753 (if (< xx param)
754 (- (/ (* 2.0 ampl xx) param) ampl)
755 (- (* 2.0 ampl (- xx 1.0) (/ 1.0 (- param 1.0))) ampl))
756 'flonum))
757 (setf xx (+ xx d))))))))
758
759
760
761 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
762 ;; ;;
763 ;; Auxiliary functions ;;
764 ;; ;;
765 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
766
767
768
769 ;; Calculates the frequency associated to a note, according
770 ;; to the equal tempered scale:
771 ;;
772 ;; note - 10
773 ;; oct + --------- - 1
774 ;; 12
775 ;; 55 2
776 ;;
777 ;; freq:
778 ;; 1 = DO = C
779 ;; 2 = DO# = C#
780 ;; 3 = RE = D
781 ;; 4 = RE# = D#
782 ;; 5 = MI = E
783 ;; 6 = FA = F
784 ;; 7 = FA# = F#
785 ;; 8 = SOL = G
786 ;; 9 = SOL# = G#
787 ;; 10 = LA = A
788 ;; 11 = LA# = A#
789 ;; 12 = SI = B
790 (defun $note_freq (note oct)
791 (when (or (not (integerp oct))
792 (< oct 1)
793 (> oct 8))
794 (merror "sound (note_freq): octave is not correct"))
795 (when (not (stringp note))
796 (merror "sound (note_freq): note must be a string"))
797 (let ((tone (string-upcase note))
798 (freq 13))
799 (setf freq (- 13 (length (member tone
800 '("C" "C#" "D" "D#" "E" "F" "F#" "G" "G#" "A" "A#" "B")
801 :test #'string= ))))
802 (when (= freq 13)
803 (setf freq (- 13 (length (member tone
804 '("DO" "DO#" "RE" "RE#" "MI" "FA" "FA#"
805 "SOL" "SOL#" "LA" "LA#" "SI")
806 :test #'string= )))))
807 (when (= freq 13)
808 (merror "sound (note_freq): illegal note"))
809 `((mtimes) 55
810 ((mexpt) 2
811 ((mplus) -1
812 ((mtimes) ((rat) 1 12)
813 ((mplus) -10 ,freq))
814 ,oct)))))
815
816
817
818 ;;;;;;;;;;;;;;;;;;;;;;;
819 ;; ;;
820 ;; Sound objects ;;
821 ;; ;;
822 ;;;;;;;;;;;;;;;;;;;;;;;
823
824
825
826 (defun wave (fcn var ini end &rest sample-positions)
827 (let* (($numer t)
828 ($%enumer t)
829 (nsec (- ($float end) ($float ini)))
830 (xx ($float ini))
831 (d (/ 1.0 $sound_sample_rate))
832 (num-samples (round (* nsec $sound_sample_rate)))
833 (samples (make-array num-samples
834 :element-type 'flonum))
835 (funxx 0.0)
836 wave-initials)
837 (declare (type flonum nsec xx d)
838 (type fixnum num-samples)
839 (type (simple-array flonum *) samples))
840 (when (null sample-positions)
841 (setf sample-positions '(0)))
842 (setf wave-initials
843 (map 'list
844 #'(lambda (z) (ceiling (* z $sound_sample_rate)))
845 (sort (map 'list #'$float sample-positions) #'<)))
846
847 (setq fcn (coerce-float-fun (meval `($float ,fcn)) `((mlist) ,var)))
848 (flet ((fun (x) (funcall fcn x)))
849 (dotimes (k num-samples)
850 (setf funxx (fun xx))
851 (setf (aref samples k) (coerce funxx 'flonum))
852 (setf xx (+ xx d))))
853 (apply-noise samples)
854 (apply-envelope samples)
855 (make-a-wave
856 :sample samples
857 :channel (get-sound-option '$channel)
858 :att-coef (rest (get-sound-option '$attenuation_coef))
859 :repeat-at wave-initials)))
860
861
862
863 (defun note (freq ampl dur &rest sample-positions)
864 (let* (($numer t)
865 ($%enumer t)
866 (fdur ($float dur))
867 (ffreq ($float freq))
868 (per1-samples (round (/ $sound_sample_rate ffreq))) ; sample size for one period
869 (tot-samples (round (* $sound_sample_rate fdur))) ; total samples for dur seconds
870 (samples (make-array tot-samples
871 :initial-element 0.0
872 :element-type 'flonum))
873 wave-initials)
874 (declare (type boolean $numer $%enumer)
875 (type flonum fdur ffreq)
876 (type fixnum per1-samples tot-samples)
877 (type (simple-array flonum *) samples))
878 (when (< (* ffreq fdur) 1)
879 (merror "sound (note): frequence times duration must be greater than 1"))
880 (when (null sample-positions)
881 (setf sample-positions '(0)))
882 (setf wave-initials
883 (map 'list
884 #'(lambda (z) (ceiling (* z $sound_sample_rate)))
885 (sort (map 'list #'$float sample-positions) #'<)))
886 (apply-oscillator-model samples per1-samples ampl)
887 ; fill the complete sample repeating the basic period
888 (do ((k 0 (1+ k))
889 (m per1-samples (1+ m)))
890 ((= m tot-samples) 'done)
891 (setf (aref samples m)
892 (aref samples (mod k per1-samples))))
893 (apply-noise samples)
894 (apply-envelope samples)
895 (make-a-wave
896 :sample samples
897 :channel (get-sound-option '$channel)
898 :att-coef (rest (get-sound-option '$attenuation_coef))
899 :repeat-at wave-initials)))
900
901
902
903 (defun sample-from-list (dat pos)
904 (let* ((tot-samples ($length dat))
905 (samples (make-array tot-samples
906 :initial-element 0.0
907 :element-type 'flonum))
908 wave-initials)
909 (declare (type fixnum tot-samples)
910 (type (simple-array flonum *) samples))
911 ($fillarray samples ($float dat))
912 (when (null pos) (setf pos '(0)))
913 (setf wave-initials
914 (map 'list
915 #'(lambda (z) (ceiling (* z $sound_sample_rate)))
916 (sort (map 'list #'$float pos) #'<)))
917 (apply-noise samples)
918 (apply-envelope samples)
919 (make-a-wave
920 :sample samples
921 :channel (get-sound-option '$channel)
922 :att-coef (rest (get-sound-option '$attenuation_coef))
923 :repeat-at wave-initials)))
924
925
926
927 (defun sample-from-array (dat pos)
928 (let ((tot-samples (array-dimension dat 0))
929 samples
930 wave-initials)
931 (declare (type fixnum tot-samples))
932 (setf samples (adjust-array (make-array tot-samples :displaced-to dat) tot-samples))
933 (when (null pos) (setf pos '(0)))
934 (setf wave-initials
935 (map 'list
936 #'(lambda (z) (ceiling (* z $sound_sample_rate)))
937 (sort (map 'list #'$float pos) #'<)))
938 (apply-noise samples)
939 (apply-envelope samples)
940 (make-a-wave
941 :sample samples
942 :channel (get-sound-option '$channel)
943 :att-coef (rest (get-sound-option '$attenuation_coef))
944 :repeat-at wave-initials)))
945
946
947
948 (defun sample (data &rest sample-positions)
949 (cond
950 (($listp data)
951 (sample-from-list data sample-positions))
952 ((arrayp data)
953 (sample-from-array data sample-positions))
954 (t
955 (merror "sound: unknown format for sampled data"))))
956
957
958
959 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
960 ;; ;;
961 ;; Play and its auxiliary functions ;;
962 ;; ;;
963 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
964
965
966
967 ;; Adds another wave to the complete sample.
968 ;; guest: data array
969 ;; chn: channel number
970 ;; att: attenuation coefficient
971 ;; ini: starting point
972 (defun add-wave (guest chn att ini)
973 (declare (type fixnum chn ini)
974 (type flonum att))
975 (let ((chn-1 (1- chn))
976 (indx 0))
977 (declare (type fixnum chn-1 indx))
978 (dotimes (n (length guest))
979 (setf indx (+ n ini))
980 (setf (aref $sound_sample chn-1 indx)
981 (+ (aref $sound_sample chn-1 indx)
982 (* att (aref guest n)))))))
983
984
985
986 (defun sound-normalize ()
987 (let ((fa ($float (get-sound-option '$normalize)))
988 (max-abs-sample 0.0)
989 (num-chn (array-dimension $sound_sample 0))
990 (num-sam (array-dimension $sound_sample 1)))
991 (declare (type flonum max-abs-sample)
992 (type fixnum num-chn num-sam))
993 (unless (equal fa '$none)
994 (when (equal fa '$auto) (setf fa 32767.0))
995 (dotimes (c num-chn)
996 (dotimes (s num-sam)
997 (let ((value (abs (aref $sound_sample c s))))
998 (when (> value max-abs-sample)
999 (setf max-abs-sample value)))))
1000 (dotimes (c num-chn)
1001 (dotimes (s num-sam)
1002 (setf (aref $sound_sample c s)
1003 (coerce (* fa (/ (aref $sound_sample c s) max-abs-sample)) 'flonum)))))))
1004
1005
1006
1007 (defun $play (&rest args)
1008 (ini-sound-options)
1009 (sound-user-defaults)
1010 (let ((wave-storage nil)
1011 (total-samples 0)
1012 (num-channels 1)
1013 (latest-wave-sample 0))
1014 (declare (type fixnum total-samples num-channels latest-wave-sample))
1015
1016 ; see what we have to play
1017 (dolist (x args)
1018 (cond
1019 ((equal ($op x) "=") ; update play option
1020 (update-sound-option ($lhs x) ($rhs x)))
1021 (t ; create sound
1022 (case (caar x)
1023 ($wave
1024 (setf wave-storage
1025 (cons (apply #'wave (rest x)) wave-storage)))
1026
1027 ($note
1028 (setf wave-storage
1029 (cons (apply #'note (rest x)) wave-storage)))
1030
1031 ($sample
1032 (setf wave-storage
1033 (cons (apply #'sample (rest x)) wave-storage)))
1034
1035 (otherwise
1036 (merror "sound: sound object ~M is not recognized" x)))
1037 ; adjust total number of samples
1038 (setf latest-wave-sample
1039 (+ (car (last (a-wave-repeat-at (first wave-storage))))
1040 (length (a-wave-sample (first wave-storage)))))
1041 (when (< total-samples latest-wave-sample)
1042 (setf total-samples latest-wave-sample))
1043 ; update number of channels
1044 (setf num-channels
1045 (max num-channels
1046 (a-wave-channel (first wave-storage)))))))
1047
1048 ; now compose the complete wave
1049 (setf $sound_sample
1050 (make-array (list num-channels total-samples)
1051 :element-type 'flonum
1052 :initial-element 0.0))
1053 (dolist (awave wave-storage)
1054 (dotimes (k (length (a-wave-repeat-at awave)))
1055 (let* ((att (a-wave-att-coef awave))
1056 (len-1 (1- (length att))))
1057 (add-wave
1058 (a-wave-sample awave)
1059 (a-wave-channel awave)
1060 (nth (min k len-1) att)
1061 (nth k (a-wave-repeat-at awave))))))
1062
1063 ; normalize sample
1064 (sound-normalize)
1065
1066 ; save sound sample
1067 (save-sound)
1068
1069 ; draw the wave in case we want to see the waveform
1070 (when (get-sound-option '$draw_wave)
1071 ($draw_sound))
1072
1073 ; call the player in case we want to hear the sound
1074 ($play_sound)
1075
1076 '$done))
1077
1078
1079
1080 ;; get $draw_wave from user defaults
1081 (defun get-draw-wave-from-user-defaults ()
1082 (loop for x in *user-sound-default-options*
1083 unless (not (equal '$draw_wave (nth 1 x))) collect x))
1084
1085 ;; get other options from user defaults
1086 (defun get-others-from-user-defaults ()
1087 (loop for x in *user-sound-default-options*
1088 unless (equal '$draw_wave (nth 1 x)) collect x))
1089
1090 ;; play & draw_sound for wxMaxima
1091 (defun $wxplay (&rest args)
1092 (cond
1093 ((nth 2 (nth 0 (get-draw-wave-from-user-defaults)))
1094 (setf *user-sound-default-options*
1095 (append
1096 '(((mequal simp) $draw_wave nil))
1097 (get-others-from-user-defaults)))
1098 (apply #'$play (nth 0 (list args)))
1099 (setf *user-sound-default-options*
1100 (append
1101 '(((mequal simp) $draw_wave t))
1102 (get-others-from-user-defaults))))
1103 (t
1104 (apply #'$play (nth 0 (list args)))))
1105 ; always draw the waveform
1106 ($wxdraw_sound))
Maxima, a Computer Algebra System