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")) 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)))) 561 ($system (format nil "\"~a\" ~a \"~a.wav\"" 562 str 563 res2 564 (plot-temp-file (get-sound-option '$file_name)))))))) 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)) 1107