;********************************************************************* ; OM-SoX, (c) 2011-2014 Marlon Schumacher (CIRMMT/McGill University) * ; http://sourceforge.net/projects/omsox/ * ; * ; Multichannel Audio Manipulation and Functional Batch Processing. * ; DSP based on SoX - (c) C.Bagwell and Contributors * ; http://sox.sourceforge.net/ * ;********************************************************************* ; ;This program is free software; you can redistribute it and/or ;modify it under the terms of the GNU General Public License ;as published by the Free Software Foundation; either version 2 ;of the License, or (at your option) any later version. ; ;See file LICENSE for further informations on licensing terms. ; ;This program is distributed in the hope that it will be useful, ;but WITHOUT ANY WARRANTY; without even the implied warranty of ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;GNU General Public License for more details. ; ;You should have received a copy of the GNU General Public License ;along with this program; if not, write to the Free Software ;Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,10 USA. ; ;Authors: M. Schumacher (in-package :om) ;; sox-units -------------- (defun sox-units (thestring unit) (cond ((equal unit "Hz") (setf thestring (concatenate 'string thestring (format nil "h")))) ((equal unit "kHz") (setf thestring (concatenate 'string thestring (format nil "k")))) ((equal unit "Octaves") (setf thestring (concatenate 'string thestring (format nil "o")))) ((equal unit "Q-factor") (setf thestring (concatenate 'string thestring (format nil "q")))) ((equal unit "Slope") (setf thestring (concatenate 'string thestring (format nil "s")))) ((equal unit "samples") (setf thestring (concatenate 'string thestring (format nil "s ")))) ((equal unit "seconds") (setf thestring (concatenate 'string thestring (format nil " ")))) ((equal unit nil) (setf thestring (concatenate 'string thestring (format nil "h")))) ) thestring) ;this should be easier with sox-concat or string+ ;; sox-out ------------------ ;; returns: outfile or string (in case of pipe) ; the normalization should be kept separate from these other setting. ; E.g. if one doesn't want to use the om-audio-prefs for the format, but still normalize files.. ; therefore it's in "sox-out" ; (unless (equal output "realtime") -> do the normalization ; OR ; (when (and *use-om-audio-prefs-in-sox* *normalize*) ; (setf str (string+ str " --norm "))) (defun sox-out (str input output outfile recursive) ;(when *normalize* (setf str (string+ str " norm " (makestring *normalize-level*)))) (when (and *use-om-audio-prefs-in-sox* *normalize*) (setf str (string+ str " norm " (makestring *normalize-level*)))) (if (eql recursive 'on) (progn (setf str (string+ str " : newfile : restart ")) (om-cmd-line str *sys-console*)) (if (equal output "pipe") (process-to-pipe str) (progn (om-cmd-line str *sys-console*) (if (equal output "replace file") (if (and (pathnamep input) (pathnamep outfile)) (progn (gc-all) ;consider whether this is always needed (also for 'new file') (delete-file input) (om-rename-file outfile input) (setf outfile input)) (om-beep-msg (format nil "No filename to replace! Assigning date/time-based filename ~s." (pathname-name outfile)))) ) (probe-file outfile)))) ) ;; sox-samplebits ---------------- (defun sox-samplebits (str bitdepth samplerate outfile) (if bitdepth (setf str (string+ str (format nil " -b~d " bitdepth))) (when *use-om-audio-prefs-in-sox* (setf str (string+ str (format nil " -b~d " *audio-res*))))) #+linux(setf str (string+ str (format nil " ~a " (if (symbolp outfile) outfile (namestring outfile))))) #+macosx(setf str (string+ str (format nil " ~s " (if (symbolp outfile) outfile (namestring outfile))))) (if samplerate (setf str (string+ str (format nil " rate -v -s ~d " samplerate))) (when *use-om-audio-prefs-in-sox* (setf str (string+ str (format nil " rate -v -s ~d " *audio-sr*))))) str) ;; process-to-pipe (defmethod! process-to-pipe ((command-string string)) (format nil "|~a" (substitute #\' #\" command-string))) ;=========== FILE/PATH FUNCTIONS ================================================= (defmethod! in-directory (&key (unix nil) (recursive nil)) :icon '(250) :indoc '("unix format") :doc "Returns a directory pathname. Opens a dialog window to choose the directory. If is T then the output files is formatted for Unix and system commands." (let ((path (if recursive (recurse-dirs (om-choose-directory-dialog)) (om-choose-directory-dialog)))) (if unix (namestring path) path))) (defmethod! out-directory (&key (unix nil)) :icon '(250) :indoc '("unix format") :doc "Returns a directory pathname. Opens a dialog window to enter a directory. If is T then the output files are formatted for Unix and system commands." (let ((path (om-choose-new-directory-dialog))) (om-create-directory path) (if unix (namestring path) path))) (defmethod! in-file (&key (unix nil)) :icon '(250) :indoc '("unix format") :doc "Returns a file pathname. Opens a dialog window to choose a file. If is T then the output files is formatted for Unix and system commands." (let ((path (om-choose-file-dialog))) (if unix (namestring path) path))) (defmethod! out-file (&key (unix nil)) :icon '(250) :indoc '("unix format") :doc "Returns a file pathname. Opens a dialog window to specify the directory. If is T then the output files is formatted for Unix and system commands." (let ((path (om-choose-new-file-dialog))) (if unix (namestring path) path))) ; consider adding an optional / keyword for recursive file-loading (defmethod! in-files (&key (unix nil) (type nil) (directories nil) (files t) (resolve-aliases nil) (hidden-files nil) (path nil)) :icon '(250) :doc "Returns a list of file pathnames. Opens a dialog window to choose the input-directory. If is T then the output files is formatted for Unix and system commands." (let* ((thepath (or path (in-directory :unix unix))) (thefilelist (om-directory thepath :type type :directories directories :files files :resolve-aliases resolve-aliases :hidden-files hidden-files))) thefilelist)) ; recursive function... (defmethod! recurse-dirs (thepath &key (unix nil) (type nil) (directories t) (files nil) (resolve-aliases nil) (hidden-files nil)) :icon '(250) :doc "Returns a list of file pathnames. Opens a dialog window to choose the input-directory. If is T then the output files is formatted for Unix and system commands." (let* ((thedirs (om-directory thepath :type type :directories directories :files files :resolve-aliases resolve-aliases :hidden-files hidden-files)) (thedirlist (x-append thepath (loop for dir in thedirs collect (recurse-dirs dir :unix unix :type type :directories directories :files files :resolve-aliases resolve-aliases :hidden-files hidden-files) )))) (sox-print (format nil "the directories: ~a" thedirs)) (remove nil (flat thedirlist)))) (defun om-rename-file (old-path new-path) (rename-file old-path new-path)) (defun om-rename-filelist (old-path new-path) (mapcar (lambda (source target) (om-rename-file source target)) old-path new-path) ) ; create path (defmethod! create-path (inpath outpath filetype &optional date) (if (equal outpath "replace file") (if inpath (setf outfile (unique-pathname (om-make-pathname :directory inpath) (pathname-name inpath) (or (pathname-type inpath) (format-to-extension *def-snd-format*)))) (setf outfile (unique-pathname *om-outfiles-folder* (format nil "~a_omsox" (substitute #\_ #\SPACE (substitute #\- #\/ (substitute #\- #\: (sys::date-string nil nil))))) (format-to-extension *def-snd-format*)))) (let* ((input (if (and inpath (pathnamep inpath)) (pathname-name inpath) (substitute #\_ #\SPACE (substitute #\- #\/ (substitute #\- #\: (sys::date-string nil nil)))))) (name (or (and outpath (pathname-name outpath)) (format nil "~a_omsox" input))) (outdir (or (and outpath (pathname-directory outpath) (om-make-pathname :directory outpath)) (and (and inpath (pathnamep inpath)) (om-make-pathname :directory inpath)) *om-outfiles-folder*)) (type (or filetype (and outpath (pathname-type outpath)) (and (pathnamep inpath) (pathname-type inpath)) (format-to-extension *def-snd-format*))) (out (om-make-pathname :directory outdir :name (format nil "~a" name) :type type))) (setf outfile (handle-new-file-exists out)))) ;handle-new-file-exists-out contains a (gc-all) (om-create-directory outfile) outfile) (defmethod! create-path (inpath (outpath function) filetype &optional date) (om-create-directory (apply outpath (list inpath)))) ; small add-on for automatic locking of the functions on instantiation (defclass LockedBoxCall (OMBoxCall) ()) (defmethod get-boxcallclass-fun ((self (eql 'in-file))) 'LockedBoxCall) (defmethod get-boxcallclass-fun ((self (eql 'out-file))) 'LockedBoxCall) (defmethod get-boxcallclass-fun ((self (eql 'in-directory))) 'LockedBoxCall) (defmethod get-boxcallclass-fun ((self (eql 'out-directory))) 'LockedBoxCall) (defmethod get-boxcallclass-fun ((self (eql 'in-files))) 'LockedBoxCall) (defmethod initialize-instance :before ((self LockedBoxCall) &rest args) (setf (om::allow-lock self) "x")) ; for eval-once-mode replace the "x" with a "&", for lambda "l" ; format-to-extension (defun format-to-extension (format) (cond ((equal format 'aiff) "aiff") ((equal format 'wav) "wav") ((equal format 'flac) "flac") ((equal format 'ogg) "ogg") (t nil))) (defun sleep&clean (time) (sleep time) (clean-tmp-files) ) (defun sox-not-found () ;(om-message-abort (format nil "SoX exectuable not found. Path set in preferences?") (om-beep-msg (format nil "SoX exectuable not found. Path set in preferences?")) ) ; %%%%%%%%% STRING MANIPULATION / NAMING FUNCTIONS %%%%%%%%%%%%%% ; split string splits a string at first occurence of 'char' (reading from left) (defmethod! split-string ((string string) (char string)) :numouts 2 (let ((index (search char string))) (if index (values (subseq string 0 index) (subseq string (+ index 1))) (values string nil)))) ; makestring converts an item into a string (defun makestring (anything) (format nil "~s" anything) ) (defun sox-concat (new-string ex-string) (if new-string (setf ex-string (concatenate 'string ex-string (format nil " ~a" new-string))) ex-string) ) ; doesn't bind persistently! (sox-concat "this thing" str) ; the variable scope seems to be limited to the function. ; Could also make a global variable instead which always 'contains' the string. #| old (setf *sox-append-with-quotes* nil) (defun sox-concat (new-string ex-string) (if new-string (if *sox-append-with-quotes* ; append with quotes or not (for sox-multiplot) ;(setf ex-string (format nil " ~s \"~a\" " ex-string new-string)) ;(setf ex-string (format nil " ~a ~s " ex-string new-string)) (sox-reduce-effects (list ex-string new-string)) ;(setf ex-string (concatenate 'string ex-string (format nil " ~s " new-string))) ;(setf ex-string (concatenate 'string ex-string (format nil " \"~a\" " new-string))) (setf ex-string (concatenate 'string ex-string (format nil " ~a" new-string)))) ex-string) ) |# ;Note, there's a problem with LISP printing scientific notation (which sox doesn't interpret properly) need to find a workaround (defun sox-float-to-string (float) (format nil "~f" float)) (defun symbol-to-string (symbol) (format nil "~a" symbol) ) ;;; for sox-remix and sox-panning ;%%%%%%%%%% sox-remixconc %%%%%%%%%% ;(sox-remixconc-no-norm '((0 0 0) (-6 -4)) '((1 2 3) (2 3))) ;(sox-remixconc '((-2 -3 -6) (-6 -4)) '((1 2 3) (2 3)) nil) ;(sox-remixconc '((-4 -4 -4) (-2 -2)) '((1 2 3) (2 3)) '(t nil)) ; remixconc functions (Note: perhaps doesn't require db->lin if the "p" option is used. (defun sox-remixconc (gainlist channellist 1/n) (let* ((outstr) (substr)) (loop for subgainlist in gainlist for subchannellist in channellist do for 1/nitem in 1/n do (if 1/nitem (progn (setf substr (format nil "~dp~d" (first subchannellist) (float (/ (first subgainlist) (length subgainlist))))) (setf outstr (string+ outstr (format nil "~a " (loop for channelitem in (cdr subchannellist) for gainitem in (cdr subgainlist) do (unless (< gainitem -150) (setf substr (string+ substr (format nil ",~dp~d" channelitem (float (/ gainitem (length subchannellist))))))) finally return substr) )))) (progn (setf substr (format nil "~dp~d" (first subchannellist) (float (first subgainlist)))) (setf outstr (string+ outstr (format nil "~a " (loop for channelitem in (cdr subchannellist) for gainitem in (cdr subgainlist) do (unless (< gainitem -150) (setf substr (string+ substr (format nil ",~dp~d" channelitem (float gainitem))))) finally return substr) ))))) ) outstr)) ;(sox-remixconc-no-norm '((-160 -160) (-3 -160)) '((1 2) (3 4))) (defun sox-remixconc-no-norm (gainlist channellist) (let* ((outstr) (substr)) (loop for subgainlist in gainlist for subchannellist in channellist do (progn (setf substr (format nil "~dp~d" (first subchannellist) (first subgainlist))) ; this should maybe also go here: (unless (< gain (first subgainlist) -150) (setf outstr (string+ outstr (format nil "~a " (loop for channelitem in (cdr subchannellist) for gainitem in (cdr subgainlist) do (unless (< gainitem -150) ;it would be better to catch 'nil' instead of a very small value (depends on float precision) (setf substr (string+ substr (format nil ",~dp~d" channelitem gainitem)))) finally (return substr)) ))))) outstr)) ;%%%%%%%%%% relpan->remix %%%%%%%%%% (defmethod! relpan->remix ((relpan number) (numchannels integer)) (let* ((relpan (max 1 (min numchannels relpan))) ;maybe I could later introduce wrap-around (for circular LS setups). For now: clipping (lower-channel (multiple-value-list (floor relpan))) (upper-channel (multiple-value-list (ceiling relpan))) (factor (if (equal (float (second lower-channel)) 0.0) 1.0 (second lower-channel))) (thelist (make-list numchannels :initial-element '0)) ; (thelowerlist (replace-in-list thelist (power-law factor) (- (first lower-channel) 1))) (theupperlist (replace-in-list thelowerlist (power-law (- 1 factor)) (- (first upper-channel) 1)))) (sox-print theupperlist) (lin->db theupperlist))) (defmethod! relpan->remix ((pan list) (numchannels integer)) (mapcar (lambda (panlist) (relpan->remix panlist numchannels)) pan) ) (defmethod! pan->remix ((pan number) (numchannels integer) (offset integer)) :initvals '(0 2 0) :doc "this function takes a pan value between -100 and 100 and scales it from 1 to numchannels" (let ((thelist (rotate-list (relpan->remix (om-scale pan 1.0 numchannels -100 100) numchannels) offset))) thelist) ) ;%%%%%%%%%%%% sox-pan->sox-remix %%%%%%%%%% (defmethod sox-pan->sox-remix ((sound t) (gain number) (pan number) &optional numchannels) (let* ((sound-channels (sox-sound-channels sound)) (compensation-factor-db (lin->db (/ 1 sound-channels))) ; 1/n gain compensation (maxchannel (or numchannels (+ (floor pan) 1))) (gainval (or gain 0.0)) (gainlist (om-round (om+ (om+ (relpan->remix pan maxchannel) gainval) compensation-factor-db) 5)) (channellist (repeat-n (arithm-ser 1 sound-channels 1) maxchannel))) ;without 'in-channel' at the moment... could replace the (arithm-ser 1 sound-channels 1) with it though... (make-instance 'sox-remix :sound sound :gain-matrix (mapcar (lambda (thegains) (repeat-n thegains sound-channels)) gainlist) :channel-matrix channellist ) )) (defmethod sox-pan->sox-remix ((sound sound) (gain number) (pan number) &optional numchannels) (sox-pan->sox-remix (sound-path sound) gain pan)) (defmethod sox-pan->sox-remix ((sound list) (gain list) (pan list) &optional numchannels) (mapcar (lambda (thesound thegain thepan) (sox-pan->sox-remix thesound thegain thepan)) sound gain pan) ) ; %%%%%%%%%%%%%% debugging functions %%%%%%%%%%%%% (defun sox-play-print (self) (when *sox-debug* (print (string+ "OM-SoX: Playing " (makestring (class-of self))))) ; (upstring "fifo") ) (defun sox-print (&rest strings) (when *sox-debug* (print (concat-strings "OM-SoX debug:" strings))) ) ; this is roughly equivalent to 'string+' (defmethod concat-strings (&rest others) (reduce 'sox-concat (reverse others))) ; args shouldn't need to be strings! Could put a 'makestring' in there... ; %%%%%%%%%%%%%%%%%% predicates %%%%%%%%%%%%%%%%%%%% (defun soundp (arg) (if (subtypep (type-of arg) 'sound) t nil)) ;checks whether the elements of a list are the same and returns element if true (defun same-elements-p (list) (reduce #'(lambda (item1 item2) (if (equal item1 item2) item1)) list)) (defun listbeep (item label) (if (and (listp item) (first item)) (om-beep-msg (format nil "Please specify a single ~a instead of a list of ~as!" label label)) item) ) ; this should really be an object, not a specific string starting wit "|" (defun pipe-p (string) (if (equal 0 (search "|" string)) t nil) ) ; ################################################################### ; these functions are for 'initialize instance' of sox-input classes ; could be typed to 't' as to allow for pipes, etc. (defmethod sox-init-sound ((self sox-input) (mode symbol)) (cond ((and (equal mode 'list) (not (consp (sound self)))) (om-beep-msg (string+ (makestring (class-of self)) ": Please specify a list of input sources."))) ((and (equal mode 'atom) (consp (sound self))) (om-beep-msg (string+ (makestring (class-of self)) ": Please specify a single input source."))) ) (setf (sound self) (sox-sound-path (sound self))) ;might conceivably remove this and have sox-process do it ) ; could also have two versions here (for 'atom or 'list) ; should be called sox-init-gain with an additional argument for 'gains or 'gain (defmethod sox-init-gains ((self sox-input)) (setf (gains self) (list! (or (gains self) (sox-vol-convert (sound self))))) ) ; this could have have a check whether gain is an atom or list. If an atom then (repeat-n (length sound) gain) ; sox-init-gain-matrix? ; sox-init-gain? (defun sox-gain-matcher (gains channels) (let ((gainlist (if (consp (car channels)) (loop for subchannellist in channels for i from 0 to (length channels) collect (loop for item in subchannellist for j from 0 to (length subchannellist) collect (if (integerp item) (or ;(nth j (list! (nth i (print gains)))) ;isn't "gains" always a list because of sox-gain-matcher? (nth j (list! (nth i gains))) ; this is the case if there is a sublist of gains (nth i gains) ; this is only the case if there is list of gains (first (flat gains))) ; this is the case if there's an atom for gains (om-beep-msg "Channels must be integers.")) )) (om-beep-msg "Channels must be a matrix (list of lists)")))) gainlist)) (defmethod sox-init-panning ((self sox-input)) (setf (panning self) (or (panning self) (if (soundp (sound self)) (if (equal (tracknum (sound self)) 0) (+ 1 (* 0.5 (- (numchannels self) 1))) (+ (tracknum (sound self)) (* 0.01 (pan (sound self)))) ) ) )) ) #| (defmethod sox-init-panning ((self sox-mix-console)) (setf (panning self) (or (panning self) (if (equal (tracknum (sound self)) 0) (+ 1 (* 0.5 (- (numchannels self) 1))) (+ (tracknum (sound self)) (* 0.01 (pan (sound self)))) ) ) ) ) |# (defmethod sox-sound-path ((self t)) self) (defmethod sox-sound-path ((self sound)) (sound-path self)) (defmethod sox-sound-path ((self list)) (mapcar #'(lambda (thesound) (sox-sound-path thesound)) self)) (defmethod sox-vol-convert ((self t)) 0.0) (defmethod sox-vol-convert ((self number)) (lin->db self)) (defmethod sox-vol-convert ((self sound)) (lin->db (vol self)) ) (defmethod sox-vol-convert ((self list)) (mapcar #'(lambda (thesound) (sox-vol-convert thesound)) self)) (defmethod sox-convert-vol ((self number)) (om-round (db->lin self) 5) ) (defmethod sox-pan-convert ((pan number) (track number)) (+ track (* 0.01 pan)) ) (defmethod sox-convert-pan ((pan number)) (if (< pan 1) (list 0 (* 100 pan)) (let* ((track-and-pan-temp (multiple-value-list (floor pan))) (track-and-pan (if (> (second track-and-pan-temp) 0.5) (list (+ (first track-and-pan-temp) 1) (* -1 (- 1 (second track-and-pan-temp)))) track-and-pan-temp))) (list (first track-and-pan) (om-round (* 100 (second track-and-pan)) 4))) )) ; Miscellaneous functions (defun power-law (number) (cos (* number (* 2 pi) 0.25))) (defun rotate-list (list offset) (let ((first-part (first-n list offset)) (second-part (last-n list (- (length list) offset)))) (x-append second-part first-part) )) (defmethod sum-list ((numbers list)) (reduce '+ numbers) ) (defmethod squared-sum-list ((numbers list)) (sum-list (om^ numbers 2)) ) (defmethod abs-sum-list ((numbers list)) (sum-list (om-abs numbers)) ) (defmethod compensate-fir-gain ((numbers list)) (lin->db (sox-rms numbers)) ;(/ 1 (squared-sum-list numbers))) ) (defmethod sox-rms ((numbers list)) (sqrt (/ (squared-sum-list numbers) (length numbers))) ) (defun get-markers (sound-or-path) (loop for elem in (list! sound-or-path) collect (if (soundp elem) (markers elem) nil) )) (defmethod! sox-1/n-db ((input list) &optional (number-or-list 'number)) :icon 23 :menuins '((1 (("number" 'number) ("list" 'list)))) :initvals '(nil 'number) (cond ((eql number-or-list 'number) (lin->db (/ 1 (length input)))) ((eql number-or-list 'list) (repeat-n (lin->db (/ 1 (length input))) (length input))) (t (print "number-or-list must be 'number' or 'list' [symbol]"))) ) (defun 1/n-db (list) (repeat-n (lin->db (/ 1 (length list))) (length list)) )