| commit | author | age | ||
| 92c40d | 1 | ;********************************************************************* |
| AN | 2 | ; OM-SoX, (c) 2011-2014 Marlon Schumacher (CIRMMT/McGill University) * |
| 3 | ; http://sourceforge.net/projects/omsox/ * | |
| 4 | ; * | |
| 5 | ; Multichannel Audio Manipulation and Functional Batch Processing. * | |
| 6 | ; DSP based on SoX - (c) C.Bagwell and Contributors * | |
| 7 | ; http://sox.sourceforge.net/ * | |
| 8 | ;********************************************************************* | |
| 9 | ; | |
| 10 | ;This program is free software; you can redistribute it and/or | |
| 11 | ;modify it under the terms of the GNU General Public License | |
| 12 | ;as published by the Free Software Foundation; either version 2 | |
| 13 | ;of the License, or (at your option) any later version. | |
| 14 | ; | |
| 15 | ;See file LICENSE for further informations on licensing terms. | |
| 16 | ; | |
| 17 | ;This program is distributed in the hope that it will be useful, | |
| 18 | ;but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 | ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 20 | ;GNU General Public License for more details. | |
| 21 | ; | |
| 22 | ;You should have received a copy of the GNU General Public License | |
| 23 | ;along with this program; if not, write to the Free Software | |
| 24 | ;Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,10 USA. | |
| 25 | ; | |
| 26 | ;Authors: M. Schumacher | |
| 27 | ||
| 28 | (in-package :om) | |
| 29 | ||
| 30 | ||
| 31 | ;; sox-units -------------- | |
| 32 | (defun sox-units (thestring unit) | |
| 33 | (cond ((equal unit "Hz") | |
| 34 | (setf thestring (concatenate 'string thestring | |
| 35 | (format nil "h")))) | |
| 36 | ((equal unit "kHz") | |
| 37 | (setf thestring (concatenate 'string thestring | |
| 38 | (format nil "k")))) | |
| 39 | ((equal unit "Octaves") | |
| 40 | (setf thestring (concatenate 'string thestring | |
| 41 | (format nil "o")))) | |
| 42 | ((equal unit "Q-factor") | |
| 43 | (setf thestring (concatenate 'string thestring | |
| 44 | (format nil "q")))) | |
| 45 | ((equal unit "Slope") | |
| 46 | (setf thestring (concatenate 'string thestring | |
| 47 | (format nil "s")))) | |
| 48 | ((equal unit "samples") | |
| 49 | (setf thestring (concatenate 'string thestring | |
| 50 | (format nil "s ")))) | |
| 51 | ((equal unit "seconds") | |
| 52 | (setf thestring (concatenate 'string thestring | |
| 53 | (format nil " ")))) | |
| 54 | ((equal unit nil) | |
| 55 | (setf thestring (concatenate 'string thestring | |
| 56 | (format nil "h")))) | |
| 57 | ) | |
| 58 | thestring) | |
| 59 | ||
| 60 | ;this should be easier with sox-concat or string+ | |
| 61 | ||
| 62 | ;; sox-out ------------------ | |
| 63 | ;; returns: outfile or string (in case of pipe) | |
| 64 | ||
| 65 | ; the normalization should be kept separate from these other setting. | |
| 66 | ; E.g. if one doesn't want to use the om-audio-prefs for the format, but still normalize files.. | |
| 67 | ; therefore it's in "sox-out" | |
| 68 | ; (unless (equal output "realtime") -> do the normalization | |
| 69 | ; OR | |
| 70 | ; (when (and *use-om-audio-prefs-in-sox* *normalize*) | |
| 71 | ; (setf str (string+ str " --norm "))) | |
| 72 | ||
| 73 | (defun sox-out (str input output outfile recursive) | |
| 74 | ;(when *normalize* (setf str (string+ str " norm " (makestring *normalize-level*)))) | |
| 75 | (when (and *use-om-audio-prefs-in-sox* *normalize*) | |
| 76 | (setf str (string+ str " norm " (makestring *normalize-level*)))) | |
| 77 | (if (eql recursive 'on) | |
| 78 | (progn | |
| 79 | (setf str (string+ str " : newfile : restart ")) | |
| 80 | (om-cmd-line str *sys-console*)) | |
| 81 | (if (equal output "pipe") | |
| 82 | (process-to-pipe str) | |
| 83 | (progn | |
| 84 | (om-cmd-line str *sys-console*) | |
| 85 | (if (equal output "replace file") | |
| 86 | (if (and (pathnamep input) (pathnamep outfile)) | |
| 87 | (progn | |
| 88 | (gc-all) ;consider whether this is always needed (also for 'new file') | |
| 89 | (delete-file input) | |
| 90 | (om-rename-file outfile input) | |
| 91 | (setf outfile input)) | |
| 92 | (om-beep-msg (format nil "No filename to replace! Assigning date/time-based filename ~s." (pathname-name outfile)))) | |
| 93 | ) | |
| 94 | (probe-file outfile)))) | |
| 95 | ) | |
| 96 | ||
| 97 | ||
| 98 | ||
| 99 | ;; sox-samplebits ---------------- | |
| 100 | (defun sox-samplebits (str bitdepth samplerate outfile) | |
| 101 | (if bitdepth | |
| 102 | (setf str (string+ str (format nil " -b~d " bitdepth))) | |
| 103 | (when *use-om-audio-prefs-in-sox* (setf str (string+ str (format nil " -b~d " *audio-res*))))) | |
| 104 | #+linux(setf str (string+ str (format nil " ~a " (if (symbolp outfile) outfile (namestring outfile))))) | |
| 105 | #+macosx(setf str (string+ str (format nil " ~s " (if (symbolp outfile) outfile (namestring outfile))))) | |
| 106 | (if samplerate | |
| 107 | (setf str (string+ str (format nil " rate -v -s ~d " samplerate))) | |
| 108 | (when *use-om-audio-prefs-in-sox* (setf str (string+ str (format nil " rate -v -s ~d " *audio-sr*))))) | |
| 109 | str) | |
| 110 | ||
| 111 | ;; process-to-pipe | |
| 112 | (defmethod! process-to-pipe ((command-string string)) | |
| 113 | (format nil "|~a" (substitute #\' #\" command-string))) | |
| 114 | ||
| 115 | ||
| 116 | ||
| 117 | ;=========== FILE/PATH FUNCTIONS ================================================= | |
| 118 | (defmethod! in-directory (&key (unix nil) (recursive nil)) | |
| 119 | :icon '(250) | |
| 120 | :indoc '("unix format") | |
| 121 | :doc "Returns a directory pathname. | |
| 122 | Opens a dialog window to choose the directory. | |
| 123 | If <unix> is T then the output files is formatted for Unix and system commands." | |
| 124 | (let ((path | |
| 125 | (if recursive | |
| 126 | (recurse-dirs (om-choose-directory-dialog)) | |
| 127 | (om-choose-directory-dialog)))) | |
| 128 | (if unix | |
| 129 | (namestring path) | |
| 130 | path))) | |
| 131 | ||
| 132 | (defmethod! out-directory (&key (unix nil)) | |
| 133 | :icon '(250) | |
| 134 | :indoc '("unix format") | |
| 135 | :doc "Returns a directory pathname. | |
| 136 | Opens a dialog window to enter a directory. | |
| 137 | If <unix> is T then the output files are formatted for Unix and system commands." | |
| 138 | (let ((path (om-choose-new-directory-dialog))) | |
| 139 | (om-create-directory path) | |
| 140 | (if unix | |
| 141 | (namestring path) | |
| 142 | path))) | |
| 143 | ||
| 144 | (defmethod! in-file (&key (unix nil)) | |
| 145 | :icon '(250) | |
| 146 | :indoc '("unix format") | |
| 147 | :doc "Returns a file pathname. | |
| 148 | Opens a dialog window to choose a file. | |
| 149 | If <unix> is T then the output files is formatted for Unix and system commands." | |
| 150 | (let ((path (om-choose-file-dialog))) | |
| 151 | (if unix | |
| 152 | (namestring path) | |
| 153 | path))) | |
| 154 | ||
| 155 | (defmethod! out-file (&key (unix nil)) | |
| 156 | :icon '(250) | |
| 157 | :indoc '("unix format") | |
| 158 | :doc "Returns a file pathname. | |
| 159 | Opens a dialog window to specify the directory. | |
| 160 | If <unix> is T then the output files is formatted for Unix and system commands." | |
| 161 | (let ((path (om-choose-new-file-dialog))) | |
| 162 | (if unix | |
| 163 | (namestring path) | |
| 164 | path))) | |
| 165 | ||
| 166 | ||
| 167 | ; consider adding an optional / keyword for recursive file-loading | |
| 168 | (defmethod! in-files (&key (unix nil) (type nil) (directories nil) (files t) (resolve-aliases nil) (hidden-files nil) (path nil)) | |
| 169 | :icon '(250) | |
| 170 | :doc "Returns a list of file pathnames. | |
| 171 | Opens a dialog window to choose the input-directory. | |
| 172 | If <unix> is T then the output files is formatted for Unix and system commands." | |
| 173 | ||
| 174 | (let* ((thepath (or path (in-directory :unix unix))) | |
| 175 | (thefilelist (om-directory thepath | |
| 176 | :type type :directories directories :files files | |
| 177 | :resolve-aliases resolve-aliases :hidden-files hidden-files))) | |
| 178 | thefilelist)) | |
| 179 | ||
| 180 | ||
| 181 | ; recursive function... | |
| 182 | (defmethod! recurse-dirs (thepath &key (unix nil) (type nil) (directories t) (files nil) (resolve-aliases nil) (hidden-files nil)) | |
| 183 | :icon '(250) | |
| 184 | :doc "Returns a list of file pathnames. | |
| 185 | Opens a dialog window to choose the input-directory. | |
| 186 | If <unix> is T then the output files is formatted for Unix and system commands." | |
| 187 | ||
| 188 | (let* ((thedirs (om-directory thepath | |
| 189 | :type type :directories directories :files files | |
| 190 | :resolve-aliases resolve-aliases :hidden-files hidden-files)) | |
| 191 | (thedirlist (x-append thepath (loop for dir in thedirs collect | |
| 192 | (recurse-dirs dir :unix unix :type type :directories directories | |
| 193 | :files files :resolve-aliases resolve-aliases :hidden-files hidden-files) | |
| 194 | )))) | |
| 195 | (sox-print (format nil "the directories: ~a" thedirs)) | |
| 196 | (remove nil (flat thedirlist)))) | |
| 197 | ||
| 198 | ||
| 199 | (defun om-rename-file (old-path new-path) | |
| 200 | (rename-file old-path new-path)) | |
| 201 | ||
| 202 | (defun om-rename-filelist (old-path new-path) | |
| 203 | (mapcar (lambda (source target) | |
| 204 | (om-rename-file source target)) old-path new-path) | |
| 205 | ) | |
| 206 | ||
| 207 | ; create path | |
| 208 | (defmethod! create-path (inpath outpath filetype &optional date) | |
| 209 | (if (equal outpath "replace file") | |
| 210 | (if inpath | |
| 211 | (setf outfile (unique-pathname (om-make-pathname :directory inpath) (pathname-name inpath) | |
| 212 | (or (pathname-type inpath) (format-to-extension *def-snd-format*)))) | |
| 213 | (setf outfile (unique-pathname *om-outfiles-folder* (format nil "~a_omsox" | |
| 214 | (substitute #\_ #\SPACE (substitute #\- #\/ (substitute #\- #\: (sys::date-string nil nil))))) | |
| 215 | (format-to-extension *def-snd-format*)))) | |
| 216 | ||
| 217 | (let* ((input (if (and inpath (pathnamep inpath)) | |
| 218 | (pathname-name inpath) | |
| 219 | (substitute #\_ #\SPACE (substitute #\- #\/ (substitute #\- #\: (sys::date-string nil nil)))))) | |
| 220 | (name (or (and outpath (pathname-name outpath)) (format nil "~a_omsox" input))) | |
| 221 | (outdir (or (and outpath (pathname-directory outpath) (om-make-pathname :directory outpath)) | |
| 222 | (and (and inpath (pathnamep inpath)) (om-make-pathname :directory inpath)) | |
| 223 | *om-outfiles-folder*)) | |
| 224 | (type (or filetype (and outpath (pathname-type outpath)) (and (pathnamep inpath) (pathname-type inpath)) (format-to-extension *def-snd-format*))) | |
| 225 | (out (om-make-pathname :directory outdir :name (format nil "~a" name) :type type))) | |
| 226 | (setf outfile (handle-new-file-exists out)))) ;handle-new-file-exists-out contains a (gc-all) | |
| 227 | (om-create-directory outfile) | |
| 228 | outfile) | |
| 229 | ||
| 230 | (defmethod! create-path (inpath (outpath function) filetype &optional date) | |
| 231 | (om-create-directory (apply outpath (list inpath)))) | |
| 232 | ||
| 233 | ||
| 234 | ; small add-on for automatic locking of the functions on instantiation | |
| 235 | (defclass LockedBoxCall (OMBoxCall) ()) | |
| 236 | (defmethod get-boxcallclass-fun ((self (eql 'in-file))) 'LockedBoxCall) | |
| 237 | (defmethod get-boxcallclass-fun ((self (eql 'out-file))) 'LockedBoxCall) | |
| 238 | (defmethod get-boxcallclass-fun ((self (eql 'in-directory))) 'LockedBoxCall) | |
| 239 | (defmethod get-boxcallclass-fun ((self (eql 'out-directory))) 'LockedBoxCall) | |
| 240 | (defmethod get-boxcallclass-fun ((self (eql 'in-files))) 'LockedBoxCall) | |
| 241 | (defmethod initialize-instance :before ((self LockedBoxCall) &rest args) | |
| 242 | (setf (om::allow-lock self) "x")) ; for eval-once-mode replace the "x" with a "&", for lambda "l" | |
| 243 | ||
| 244 | ||
| 245 | ; format-to-extension | |
| 246 | (defun format-to-extension (format) | |
| 247 | (cond ((equal format 'aiff) "aiff") | |
| 248 | ((equal format 'wav) "wav") | |
| 249 | ((equal format 'flac) "flac") | |
| 250 | ((equal format 'ogg) "ogg") | |
| 251 | (t nil))) | |
| 252 | ||
| 253 | (defun sleep&clean (time) | |
| 254 | (sleep time) | |
| 255 | (clean-tmp-files) | |
| 256 | ) | |
| 257 | ||
| 258 | (defun sox-not-found () | |
| 259 | ;(om-message-abort (format nil "SoX exectuable not found. Path set in preferences?") | |
| 260 | (om-beep-msg (format nil "SoX exectuable not found. Path set in preferences?")) | |
| 261 | ) | |
| 262 | ||
| 263 | ||
| 264 | ; %%%%%%%%% STRING MANIPULATION / NAMING FUNCTIONS %%%%%%%%%%%%%% | |
| 265 | ||
| 266 | ; split string splits a string at first occurence of 'char' (reading from left) | |
| 267 | (defmethod! split-string ((string string) (char string)) | |
| 268 | :numouts 2 | |
| 269 | (let ((index (search char string))) | |
| 270 | (if index (values (subseq string 0 index) (subseq string (+ index 1))) | |
| 271 | (values string nil)))) | |
| 272 | ||
| 273 | ||
| 274 | ; makestring converts an item into a string | |
| 275 | (defun makestring (anything) | |
| 276 | (format nil "~s" anything) | |
| 277 | ) | |
| 278 | ||
| 279 | (defun sox-concat (new-string ex-string) | |
| 280 | (if new-string | |
| 281 | (setf ex-string (concatenate 'string ex-string (format nil " ~a" new-string))) | |
| 282 | ex-string) | |
| 283 | ) | |
| 284 | ||
| 285 | ; doesn't bind persistently! (sox-concat "this thing" str) | |
| 286 | ; the variable scope seems to be limited to the function. | |
| 287 | ; Could also make a global variable instead which always 'contains' the string. | |
| 288 | ||
| 289 | #| old | |
| 290 | (setf *sox-append-with-quotes* nil) | |
| 291 | (defun sox-concat (new-string ex-string) | |
| 292 | (if new-string | |
| 293 | (if *sox-append-with-quotes* ; append with quotes or not (for sox-multiplot) | |
| 294 | ;(setf ex-string (format nil " ~s \"~a\" " ex-string new-string)) | |
| 295 | ;(setf ex-string (format nil " ~a ~s " ex-string new-string)) | |
| 296 | (sox-reduce-effects (list ex-string new-string)) | |
| 297 | ;(setf ex-string (concatenate 'string ex-string (format nil " ~s " new-string))) | |
| 298 | ;(setf ex-string (concatenate 'string ex-string (format nil " \"~a\" " new-string))) | |
| 299 | (setf ex-string (concatenate 'string ex-string (format nil " ~a" new-string)))) | |
| 300 | ex-string) | |
| 301 | ) | |
| 302 | |# | |
| 303 | ||
| 304 | ||
| 305 | ||
| 306 | ||
| 307 | ;Note, there's a problem with LISP printing scientific notation (which sox doesn't interpret properly) need to find a workaround | |
| 308 | (defun sox-float-to-string (float) | |
| 309 | (format nil "~f" float)) | |
| 310 | ||
| 311 | (defun symbol-to-string (symbol) | |
| 312 | (format nil "~a" symbol) | |
| 313 | ) | |
| 314 | ||
| 315 | ||
| 316 | ||
| 317 | ;;; for sox-remix and sox-panning | |
| 318 | ||
| 319 | ;%%%%%%%%%% sox-remixconc %%%%%%%%%% | |
| 320 | ||
| 321 | ;(sox-remixconc-no-norm '((0 0 0) (-6 -4)) '((1 2 3) (2 3))) | |
| 322 | ;(sox-remixconc '((-2 -3 -6) (-6 -4)) '((1 2 3) (2 3)) nil) | |
| 323 | ;(sox-remixconc '((-4 -4 -4) (-2 -2)) '((1 2 3) (2 3)) '(t nil)) | |
| 324 | ; remixconc functions (Note: perhaps doesn't require db->lin if the "p" option is used. | |
| 325 | ||
| 326 | (defun sox-remixconc (gainlist channellist 1/n) | |
| 327 | (let* ((outstr) | |
| 328 | (substr)) | |
| 329 | (loop for subgainlist in gainlist | |
| 330 | for subchannellist in channellist do | |
| 331 | for 1/nitem in 1/n do | |
| 332 | (if 1/nitem | |
| 333 | (progn (setf substr (format nil "~dp~d" (first subchannellist) (float (/ (first subgainlist) (length subgainlist))))) | |
| 334 | (setf outstr | |
| 335 | (string+ outstr (format nil "~a " | |
| 336 | (loop for channelitem in (cdr subchannellist) | |
| 337 | for gainitem in (cdr subgainlist) do | |
| 338 | (unless (< gainitem -150) | |
| 339 | (setf substr (string+ substr (format nil ",~dp~d" channelitem (float (/ gainitem (length subchannellist))))))) | |
| 340 | finally return substr) | |
| 341 | )))) | |
| 342 | (progn (setf substr (format nil "~dp~d" (first subchannellist) (float (first subgainlist)))) | |
| 343 | (setf outstr | |
| 344 | (string+ outstr (format nil "~a " | |
| 345 | (loop for channelitem in (cdr subchannellist) | |
| 346 | for gainitem in (cdr subgainlist) do | |
| 347 | (unless (< gainitem -150) | |
| 348 | (setf substr (string+ substr (format nil ",~dp~d" channelitem (float gainitem))))) | |
| 349 | finally return substr) | |
| 350 | ))))) | |
| 351 | ) | |
| 352 | outstr)) | |
| 353 | ||
| 354 | ||
| 355 | ;(sox-remixconc-no-norm '((-160 -160) (-3 -160)) '((1 2) (3 4))) | |
| 356 | (defun sox-remixconc-no-norm (gainlist channellist) | |
| 357 | (let* ((outstr) | |
| 358 | (substr)) | |
| 359 | (loop for subgainlist in gainlist | |
| 360 | for subchannellist in channellist do | |
| 361 | (progn | |
| 362 | (setf substr (format nil "~dp~d" (first subchannellist) (first subgainlist))) ; this should maybe also go here: (unless (< gain (first subgainlist) -150) | |
| 363 | (setf outstr | |
| 364 | (string+ outstr (format nil "~a " | |
| 365 | (loop for channelitem in (cdr subchannellist) | |
| 366 | for gainitem in (cdr subgainlist) do | |
| 367 | (unless (< gainitem -150) ;it would be better to catch 'nil' instead of a very small value (depends on float precision) | |
| 368 | (setf substr (string+ substr (format nil ",~dp~d" channelitem gainitem)))) | |
| 369 | finally return substr) | |
| 370 | ))))) | |
| 371 | outstr)) | |
| 372 | ||
| 373 | ||
| 374 | ;%%%%%%%%%% relpan->remix %%%%%%%%%% | |
| 375 | ||
| 376 | (defmethod! relpan->remix ((relpan number) (numchannels integer)) | |
| 377 | (let* ((relpan (max 1 (min numchannels relpan))) ;maybe I could later introduce wrap-around (for circular LS setups). For now: clipping | |
| 378 | (lower-channel (multiple-value-list (floor relpan))) | |
| 379 | (upper-channel (multiple-value-list (ceiling relpan))) | |
| 380 | (factor (if (equal (float (second lower-channel)) 0.0) 1.0 (second lower-channel))) | |
| 381 | (thelist (make-list numchannels :initial-element '0)) ; | |
| 382 | (thelowerlist (replace-in-list thelist (power-law factor) (- (first lower-channel) 1))) | |
| 383 | (theupperlist (replace-in-list thelowerlist (power-law (- 1 factor)) (- (first upper-channel) 1)))) | |
| 384 | (sox-print theupperlist) | |
| 385 | (lin->db theupperlist))) | |
| 386 | ||
| 387 | (defmethod! relpan->remix ((pan list) (numchannels integer)) | |
| 388 | (mapcar (lambda (panlist) (relpan->remix panlist numchannels)) pan) | |
| 389 | ) | |
| 390 | ||
| 391 | (defmethod! pan->remix ((pan number) (numchannels integer) (offset integer)) | |
| 392 | :initvals '(0 2 0) | |
| 393 | :doc "this function takes a pan value between -100 and 100 and scales it from 1 to numchannels" | |
| 394 | (let ((thelist (rotate-list (relpan->remix (om-scale pan 1.0 numchannels -100 100) numchannels) offset))) | |
| 395 | thelist) | |
| 396 | ) | |
| 397 | ||
| 398 | ||
| 399 | ;%%%%%%%%%%%% sox-pan->sox-remix %%%%%%%%%% | |
| 400 | ||
| 401 | (defmethod sox-pan->sox-remix ((sound t) (gain number) (pan number) &optional numchannels) | |
| 402 | (let* ((sound-channels (sox-sound-channels sound)) | |
| 403 | (compensation-factor-db (lin->db (/ 1 sound-channels))) ; 1/n gain compensation | |
| 404 | (maxchannel (or numchannels (+ (floor pan) 1))) | |
| 405 | (gainval (or gain 0.0)) | |
| 406 | (gainlist (om-round (om+ (om+ (relpan->remix pan maxchannel) gainval) compensation-factor-db) 5)) | |
| 407 | (channellist (repeat-n (arithm-ser 1 sound-channels 1) maxchannel))) | |
| 408 | ;without 'in-channel' at the moment... could replace the (arithm-ser 1 sound-channels 1) with it though... | |
| 409 | ||
| 410 | (make-instance 'sox-remix | |
| 411 | :sound sound | |
| 412 | :gain-matrix (mapcar (lambda (thegains) | |
| 413 | (repeat-n thegains sound-channels)) gainlist) | |
| 414 | :channel-matrix channellist | |
| 415 | ) | |
| 416 | )) | |
| 417 | ||
| 418 | (defmethod sox-pan->sox-remix ((sound sound) (gain number) (pan number) &optional numchannels) | |
| 419 | (sox-pan->sox-remix (sound-path sound) gain pan)) | |
| 420 | ||
| 421 | (defmethod sox-pan->sox-remix ((sound list) (gain list) (pan list) &optional numchannels) | |
| 422 | (mapcar (lambda (thesound thegain thepan) | |
| 423 | (sox-pan->sox-remix thesound thegain thepan)) sound gain pan) | |
| 424 | ) | |
| 425 | ||
| 426 | ; %%%%%%%%%%%%%% debugging functions %%%%%%%%%%%%% | |
| 427 | ||
| 428 | (defun sox-play-print (self) | |
| 429 | (when *sox-debug* | |
| 430 | (print (string+ "OM-SoX: Playing " (makestring (class-of self))))) ; (upstring "fifo") | |
| 431 | ) | |
| 432 | ||
| 433 | ||
| 434 | (defun sox-print (&rest strings) | |
| 435 | (when *sox-debug* | |
| 436 | (print (concat-strings "OM-SoX debug:" strings))) | |
| 437 | ) | |
| 438 | ||
| 439 | ; this is roughly equivalent to 'string+' | |
| 440 | (defmethod concat-strings (&rest others) | |
| 441 | (reduce 'sox-concat (reverse others))) | |
| 442 | ; args shouldn't need to be strings! Could put a 'makestring' in there... | |
| 443 | ||
| 444 | ||
| 445 | ; %%%%%%%%%%%%%%%%%% predicates %%%%%%%%%%%%%%%%%%%% | |
| 446 | ||
| 447 | (defun soundp (arg) | |
| 448 | (if (subtypep (type-of arg) 'sound) t nil)) | |
| 449 | ||
| 450 | ;checks whether the elements of a list are the same and returns element if true | |
| 451 | (defun same-elements-p (list) | |
| 452 | (reduce #'(lambda (item1 item2) | |
| 453 | (if (equal item1 item2) | |
| 454 | item1)) list)) | |
| 455 | ||
| 456 | (defun listbeep (item label) | |
| 457 | (if (and (listp item) (first item)) | |
| 458 | (om-beep-msg (format nil "Please specify a single ~a instead of a list of ~as!" label label)) | |
| 459 | item) | |
| 460 | ) | |
| 461 | ||
| 462 | ; this should really be an object, not a specific string starting wit "|" | |
| 463 | (defun pipe-p (string) | |
| 464 | (if (equal 0 (search "|" string)) t nil) | |
| 465 | ) | |
| 466 | ||
| 467 | ; ################################################################### | |
| 468 | ; these functions are for 'initialize instance' of sox-input classes | |
| 469 | ||
| 470 | ; could be typed to 't' as to allow for pipes, etc. | |
| 471 | (defmethod sox-init-sound ((self sox-input) (mode symbol)) | |
| 472 | (cond ((and (equal mode 'list) (not (consp (sound self)))) | |
| 473 | (om-beep-msg (string+ (makestring (class-of self)) ": Please specify a list of input sources."))) | |
| 474 | ((and (equal mode 'atom) (consp (sound self))) | |
| 475 | (om-beep-msg (string+ (makestring (class-of self)) ": Please specify a single input source."))) | |
| 476 | ) | |
| 477 | (setf (sound self) (sox-sound-path (sound self))) ;might conceivably remove this and have sox-process do it | |
| 478 | ) | |
| 479 | ||
| 480 | ; could also have two versions here (for 'atom or 'list) | |
| 481 | ; should be called sox-init-gain with an additional argument for 'gains or 'gain | |
| 482 | (defmethod sox-init-gains ((self sox-input)) | |
| 483 | (setf (gains self) (list! (or (gains self) (sox-vol-convert (sound self))))) | |
| 484 | ) | |
| 485 | ; this could have have a check whether gain is an atom or list. If an atom then (repeat-n (length sound) gain) | |
| 486 | ||
| 487 | ||
| 488 | ; sox-init-gain-matrix? | |
| 489 | ; sox-init-gain? | |
| 490 | ||
| 491 | (defun sox-gain-matcher (gains channels) | |
| 492 | (let ((gainlist | |
| 493 | (if (consp (car channels)) | |
| 494 | (loop for subchannellist in channels | |
| 495 | for i from 0 to (length channels) collect | |
| 496 | (loop for item in subchannellist | |
| 497 | for j from 0 to (length subchannellist) collect | |
| 498 | (if (integerp item) | |
| 499 | (or ;(nth j (list! (nth i (print gains)))) ;isn't "gains" always a list because of sox-gain-matcher? | |
| 500 | (nth j (list! (nth i gains))) ; this is the case if there is a sublist of gains | |
| 501 | (nth i gains) ; this is only the case if there is list of gains | |
| 502 | (first (flat gains))) ; this is the case if there's an atom for gains | |
| 503 | (om-beep-msg "Channels must be integers.")) | |
| 504 | )) | |
| 505 | (om-beep-msg "Channels must be a matrix (list of lists)")))) | |
| 506 | gainlist)) | |
| 507 | ||
| 508 | ||
| 509 | (defmethod sox-init-panning ((self sox-input)) | |
| 510 | (setf (panning self) | |
| 511 | (or (panning self) | |
| 512 | (if (soundp (sound self)) | |
| 513 | (if (equal (tracknum (sound self)) 0) | |
| 514 | (+ 1 (* 0.5 (- (numchannels self) 1))) | |
| 515 | (+ (tracknum (sound self)) (* 0.01 (pan (sound self)))) | |
| 516 | ) | |
| 517 | ) | |
| 518 | )) | |
| 519 | ) | |
| 520 | ||
| 521 | ||
| 522 | #| | |
| 523 | (defmethod sox-init-panning ((self sox-mix-console)) | |
| 524 | (setf (panning self) | |
| 525 | (or (panning self) | |
| 526 | (if (equal (tracknum (sound self)) 0) | |
| 527 | (+ 1 (* 0.5 (- (numchannels self) 1))) | |
| 528 | (+ (tracknum (sound self)) (* 0.01 (pan (sound self)))) | |
| 529 | ) | |
| 530 | ) | |
| 531 | ) | |
| 532 | ) | |
| 533 | |# | |
| 534 | ||
| 535 | (defmethod sox-sound-path ((self t)) self) | |
| 536 | (defmethod sox-sound-path ((self sound)) (sound-path self)) | |
| 537 | (defmethod sox-sound-path ((self list)) (mapcar #'(lambda (thesound) (sox-sound-path thesound)) self)) | |
| 538 | ||
| 539 | (defmethod sox-vol-convert ((self t)) 0.0) | |
| 540 | (defmethod sox-vol-convert ((self number)) | |
| 541 | (lin->db self)) | |
| 542 | ||
| 543 | ||
| 544 | (defmethod sox-vol-convert ((self sound)) | |
| 545 | (lin->db (vol self)) | |
| 546 | ) | |
| 547 | ||
| 548 | (defmethod sox-vol-convert ((self list)) (mapcar #'(lambda (thesound) (sox-vol-convert thesound)) self)) | |
| 549 | ||
| 550 | (defmethod sox-convert-vol ((self number)) | |
| 551 | (om-round (db->lin self) 5) | |
| 552 | ) | |
| 553 | ||
| 554 | (defmethod sox-pan-convert ((pan number) (track number)) | |
| 555 | (+ track (* 0.01 pan)) | |
| 556 | ) | |
| 557 | ||
| 558 | (defmethod sox-convert-pan ((pan number)) | |
| 559 | (if (< pan 1) | |
| 560 | (list 0 (* 100 pan)) | |
| 561 | (let* ((track-and-pan-temp (multiple-value-list (floor pan))) | |
| 562 | (track-and-pan (if (> (second track-and-pan-temp) 0.5) | |
| 563 | (list (+ (first track-and-pan-temp) 1) | |
| 564 | (* -1 (- 1 (second track-and-pan-temp)))) | |
| 565 | track-and-pan-temp))) | |
| 566 | (list (first track-and-pan) (om-round (* 100 (second track-and-pan)) 4))) | |
| 567 | )) | |
| 568 | ||
| 569 | ; Miscellaneous functions | |
| 570 | ||
| 571 | (defun power-law (number) | |
| 572 | (cos (* number (* 2 pi) 0.25))) | |
| 573 | ||
| 574 | ||
| 575 | (defun rotate-list (list offset) | |
| 576 | (let ((first-part (first-n list offset)) | |
| 577 | (second-part (last-n list (- (length list) offset)))) | |
| 578 | (x-append second-part first-part) | |
| 579 | )) | |
| 580 | ||
| 581 | (defmethod sum-list ((numbers list)) | |
| 582 | (reduce '+ numbers) | |
| 583 | ) | |
| 584 | ||
| 585 | (defmethod squared-sum-list ((numbers list)) | |
| 586 | (sum-list (om^ numbers 2)) | |
| 587 | ) | |
| 588 | ||
| 589 | (defmethod abs-sum-list ((numbers list)) | |
| 590 | (sum-list (om-abs numbers)) | |
| 591 | ) | |
| 592 | ||
| 593 | (defmethod compensate-fir-gain ((numbers list)) | |
| 594 | (lin->db (sox-rms numbers)) | |
| 595 | ;(/ 1 (squared-sum-list numbers))) | |
| 596 | ) | |
| 597 | ||
| 598 | (defmethod sox-rms ((numbers list)) | |
| 599 | (sqrt (/ (squared-sum-list numbers) (length numbers))) | |
| 600 | ) | |
| 601 | ||
| 602 | (defun get-markers (sound-or-path) | |
| 603 | (loop for elem in (list! sound-or-path) collect | |
| 604 | (if (soundp elem) (markers elem) nil) | |
| 605 | )) | |
| 606 | ||
| 607 | (defmethod! sox-1/n-db ((input list) &optional (number-or-list 'number)) | |
| 608 | :icon 23 | |
| 609 | :menuins '((1 (("number" 'number) ("list" 'list)))) | |
| 610 | :initvals '(nil 'number) | |
| 611 | (cond ((eql number-or-list 'number) (lin->db (/ 1 (length input)))) | |
| 612 | ((eql number-or-list 'list) (repeat-n (lin->db (/ 1 (length input))) (length input))) | |
| 613 | (t (print "number-or-list must be 'number' or 'list' [symbol]"))) | |
| 614 | ) | |
| 615 | ||
| 616 | (defun 1/n-db (list) | |
| 617 | (repeat-n (lin->db (/ 1 (length list))) (length list)) | |
| 618 | ) | |
