|
From: Martin R. <ru...@us...> - 2007-12-14 19:58:16
|
Update of /cvsroot/foo/foo/elkfoo/scripts In directory sc8-pr-cvs17.sourceforge.net:/tmp/cvs-serv1235 Added Files: Makefile.am foocat foodiary foofold foosine Log Message: initial checkin! --- NEW FILE: foosine --- #!/usr/local/bin/foo -- --unload control ;; foo scripting example ;; (c) 2004-2005 rumori (require 'cmdline) ;; checking command line (let* ;; single-opt or equiv-opts-list | mandatory? | with-params? | help-string ((option-list '(("--help" #f #f "this help screen") (("--freq" "-f") #t #t "frequency (hz)") (("--amp" "-a") #t #t "amplitude (0...1)") (("--dur" "-d") #t #t "duration (s)"))) (help (lambda () (format #t "usage: ~a [options]\noptions understood:\n" (car (foo:script-args))) (format #t "~a\n" (cmdline:help-message option-list)) (exit))) (number-check (lambda (arg description) (if (not (number? arg)) (begin (format #t "~a has to be number!\n" description) (help))))) (freq) (amp) (dur)) ;; help needed? (if (cmdline:option-given? (foo:script-args) option-list "--help") (help)) ;; validate cmdline (if (not (cmdline:cmdline-valid? (cdr (foo:script-args)) option-list #t)) (help)) ;; get parameters (take in account just 1st param of each option) (set! freq (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--freq")))) (set! amp (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--amp")))) (set! dur (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--dur")))) ;; check parameters (number-check freq "frequency") (number-check amp "amplitude") (number-check dur "duration") (format #t "~a script example~%" (car (foo:script-args))) (format #t "creating, playing and removing a test-file.~%") (format #t "frequency: ~a amplitude: ~a duration: ~a~%" freq amp dur) (format #t "synthesizing...~%") ;; here we do the major work (syn 1 dur (output~ 1 (mul~ (~ amp) (sine~ (~ freq))))) (format #t "~%playing using '~a'~%" foo-default-play-command) (play) (format #t "exiting (will remove temporary file as well)~%")) (quit) ;; done --- NEW FILE: foodiary --- #!/usr/local/bin/foo -- --unload control ;; foodiary: make your sound diary ;; (c) 2007 plessas, rumori (require 'cmdline) (let* ;; check commandline ;; single-opt or equiv-opts-list | mandatory? | with-params? | help-string ((option-list '((("--help" "-h") #f #f "this help screen") (("--outfile" "-o") #t #t "output file") (("--type" "-t") #f #t "output file type [guessed]") (("--sformat" "-s") #f #t "output file sample format [1st input file]") (("--srate" "-r") #f #t "output file sample rate [1st input file]") (("--channels" "-c") #f #t "output file channels [1st input file]") (("--quality" "-q") #f #t "resampling quality (2...50) [16]") (("--force" "-f") #f #f "overwrite output file if existing") (("--period" "-p") #t #t "period interval in source (s)") (("--duration" "-d") #f #t "slice duration in source (s) [period interval]") (("--xfadelength" "-l") #f #t "cross fade length (s) [0]") (("--xfadetype" "-x") #f #t "cross fade type (log|expon|line) [log]") (("--begin" "-b") #f #t "begin position in source (s) [0]") (("--end" "-e") #f #t "end position (s) [file end]"))) (help (lambda () (format #t "~a: make diary out of soundfile(s)~%" (car (foo:script-args))) (format #t "usage: ~a [options] -o outfile infile [infile ...]~%options understood:~%" (car (foo:script-args))) (format #t "~a~%" (cmdline:help-message option-list)) (exit))) (error (lambda (error-msg . print-help) (display (format #t "~a: ~a~%" (car (foo:script-args)) error-msg)) (if (and (not (null? print-help)) (eq? (car print-help) #t)) (begin (newline) (help)) (exit)))) (infiles) (outfile) (type) (format) (srate) (channels) (period) (duration) (xfadelength) (xfadeinalpha) ; encodes xfadetype (xfadeoutalpha) ; encodes xfadetype (begint) ; start offset in infile (endt) ; end offset in infile (curinpos) ; current infile position (curoutpos) ; current outfile position (outinc) ; outputfile increment (normenv~) ; slice envelope (startenv~) ; slice env (first slice) (endenv~) ; slice env (last slice) (noenv~) ; slice env (only slice: no env) (overalldur 0) (c) ; context (t) ; task ) ;; help requested? (if (cmdline:option-given? (foo:script-args) option-list "--help") (help)) ;; validate cmdline (if (not (cmdline:cmdline-valid? (foo:script-args) option-list #t)) (help)) ;; get parameters (take in account just 1st param of each option) ;; input files (set! infiles (cmdline:get-arguments (cdr (foo:script-args)) option-list)) (if (null? infiles) (error "no input files given on commandline!") (letrec ((exists (lambda (files) (cond ((null? files) #f) ((file-exists? (car files)) (exists (cdr files))) (else (error (string-append "input file not found: " (car files)))))))) (exists infiles))) ;; FIXME (if (> (length infiles) 1) (error "multiple input files not yet supported.")) ;; outfile name (set! outfile (car (cmdline:get-option-param (foo:script-args) option-list "--outfile"))) ;; filetype (if (cmdline:option-given? (foo:script-args) option-list "--type") (set! type (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--type")))) (set! type ;; guess type from extension (let* ((rev (list->string (reverse! (string->list outfile)))) (guess (substring? "." rev)) (ext (if guess (foo:soundfile-extension-type (list->string (reverse! (string->list (substring rev 0 (1+ guess)))))) #f))) (if ext ext (soundfile-filetype (car infiles)))))) ;; sample format (if (cmdline:option-given? (foo:script-args) option-list "--sformat") (set! format (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--sformat")))) (set! format (soundfile-format (car infiles)))) ;; samplerate (if (cmdline:option-given? (foo:script-args) option-list "--srate") (set! srate (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--srate")))) (set! srate (soundfile-srate (car infiles)))) ;; channels (if (cmdline:option-given? (foo:script-args) option-list "--channels") (set! channels (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--channels")))) (set! channels (soundfile-channels (car infiles)))) ;; taps (if (cmdline:option-given? (foo:script-args) option-list "--quality") (let ((taps (* 2 (inexact->exact (/ (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--quality"))) 2))))) (cond ((< taps 4) (set! taps 4)) ((> taps 50) (set! taps 50))) (foo:set-default-taps! taps)) (foo:set-default-taps! 16)) ;; period (set! period (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--period")))) (if (< period 0) (error "negative period not allowed!")) ;; duration (if (cmdline:option-given? (foo:script-args) option-list "--duration") (begin (set! duration (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--duration")))) (if (< duration 0) (error "negative duration not allowed!"))) (set! duration period)) ;; xfadelength (if (cmdline:option-given? (foo:script-args) option-list "--xfadelength") (begin (set! xfadelength (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--xfadelength")))) (cond ((< xfadelength 0) (error "negative xfadelength not allowed!")) ((> (* 2 xfadelength) duration) (error "xfadelength longer than half of duration!")))) (set! xfadelength 0)) ;; xfadetype (if (cmdline:option-given? (foo:script-args) option-list "--xfadetype") (let ((xfadetype (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--xfadetype"))))) (cond ((eq? xfadetype 'log) (set! xfadeinalpha 0.1) ;; FIXME (set! xfadeoutalpha 9.9)) ;; FIXME ((eq? xfadetype 'expon) (set! xfadeinalpha 9.9) ;; FIXME (set! xfadeoutalpha 0.1) ;; FIXME ((eq? xfadetype 'line) (set! xfadeinalpha 1) (set! xfadeoutalpha 1)) (else (error "xfadetype not valid!" #t))))) (begin (set! xfadeinalpha 0.1) ;; FIXME (set! xfadeoutalpha 9.9))) ;; FIXME ;; begint (if (cmdline:option-given? (foo:script-args) option-list "--begin") (set! begint (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--begin")))) (set! begint 0)) ;; endt (if (cmdline:option-given? (foo:script-args) option-list "--end") (begin (set! endt (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--end")))) (if (> endt (soundfile-length (car infiles))) (error "end position beyond end of input file!"))) (set! endt (soundfile-length (car infiles)))) ;; needs further attention (if (< (- endt begint) duration) (error "interval between begin and end positions shorter than one slice!")) ;; outfile increment (set! outinc (- duration xfadelength)) ;; prepare context (set! c (context channels)) ;; make envelope signals (cond ;; make-bpf needs strictly ascending time values ;; this is a workaround for zero-length-crossfades: FIXME! ((= xfadelength 0) (with-context c (lambda () (set! normenv~ (lambda () (~ 1))) (set! startenv~ (lambda () (~ 1))) (set! endenv~ (lambda () (~ 1))) (set! noenv~ (lambda () (~ 1)))))) ;; make-bpf needs strictly ascending time values ;; this is a workaround for a corner-case: no sustain phase ((= (* 2 xfadelength) duration) (with-context c (lambda () (set! normenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,duration 0 ,xfadeoutalpha)))))) (set! startenv~ (lambda () (read-bpf~ (make-bpf `((0 1) (,outinc 1) (,duration 0 ,xfadeoutalpha)))))) (set! endenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,duration 1)))))) (set! noenv~ (lambda () (~ 1)))))) ;; in a better foo world, this should be sufficient for all cases (else (with-context c (lambda () ;; (set! normenv~ (lambda () (read-bpf~ (make-bpf (list '(0 0) (list xfadelength 1 xfadeinalpha) (list outinc 1) (list duration 0 xfadeoutalpha)))))) (set! normenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,outinc 1) (,duration 0 ,xfadeoutalpha)))))) (set! startenv~ (lambda () (read-bpf~ (make-bpf `((0 1) (,outinc 1) (,duration 0 ,xfadeoutalpha)))))) (set! endenv~ (lambda () (read-bpf~ (make-bpf `((0 0) (,xfadelength 1 ,xfadeinalpha) (,duration 1)))))) (set! noenv~ (lambda () (~ 1))))))) (letrec ;; process all channels for one slice ((cat-slice (lambda (slice chan off env~) (if (> chan 0) (begin (if (>= (snd-channels slice) chan) ;; do the actual work per channel (output~ chan (time off (gate~ (mul~ (env~) (read-snd~ (snd-extract slice chan))) (snd-length slice))))) (cat-slice slice (1- chan) off env~))))) ;; process all slices of input sound (cat-slices (lambda (snd curinpos curoutpos) (cond ;; corner case: first slice is the only slice ((and (= curoutpos 0) (>= (+ curinpos period) (snd-length snd))) (cat-slice (snd-region snd curinpos duration) channels curoutpos noenv~)) ;; first slice ((= curoutpos 0) ;; current slice (cat-slice (snd-region snd curinpos duration) channels curoutpos startenv~) ;; next slice(s) (cat-slices snd (+ curinpos period) (+ curoutpos outinc))) ;; last slice truncated ((>= (+ curinpos duration) (snd-length snd)) (cat-slice (snd-region snd curinpos (- (snd-length snd) curinpos)) channels curoutpos endenv~)) ;; last slice complete ((>= (+ curinpos period) (snd-length snd)) (cat-slice (snd-region snd curinpos duration) channels curoutpos endenv~)) ;; normal slice (else ;; current slice (cat-slice (snd-region snd curinpos duration) channels curoutpos normenv~) ;; next slice(s) (cat-slices snd (+ curinpos period) (+ curoutpos outinc))))))) ;; kick the ass off (with-context c (lambda () (let* ((snd (snd-region (open-snd (car infiles)) begint (- endt begint))) (numslices (/ (snd-length snd) period)) (lastslice (* (- numslices (trunc numslices)) (/ period duration))) (dur (+ (* (ceiling (1- numslices)) (- duration xfadelength)) ;; truc de malade (* (if (or (= lastslice 0) (>= lastslice 1)) duration (* lastslice duration)))))) (set! overalldur (+ overalldur dur)) (cat-slices snd 0 0))))) ;; soundfile (if (cmdline:option-given? (foo:script-args) option-list "--force") (create-soundfile outfile type format srate channels) (make-soundfile outfile type format srate channels)) ;; task (set! t (make-task 0 0 outfile c 'punch srate)) ;; do it (run-task t overalldur)) (quit) ;; EOF --- NEW FILE: foofold --- #!/usr/local/bin/foo -- --unload control ;; foofold: fold soundfiles ;; (c) 2006 rumori (require 'cmdline) (let* ;; check commandline ;; single-opt or equiv-opts-list | mandatory? | with-params? | help-string ((option-list '((("--help" "-h") #f #f "this help screen") (("--outfile" "-o") #t #t "output file") (("--type" "-t") #f #t "output file type [guessed]") (("--sformat" "-s") #f #t "output file sample format [input file]") (("--srate" "-r") #f #t "output file sample rate [input file]") (("--channels" "-c") #f #t "output file channels [input file]") (("--parts" "-p") #f #t "foldover factor [1]") (("--quality" "-q") #f #t "resampling quality (2...50) [16]") (("--force" "-f") #f #f "overwrite output file if existing"))) (help (lambda () (format #t "~a: fold soundfiles~%" (car (foo:script-args))) (format #t "usage: ~a [options] -o outfile infile~%options understood:~%" (car (foo:script-args))) (format #t "~a~%" (cmdline:help-message option-list)) (exit))) (infiles) (outfile) (type) (format) (srate) (channels) (numparts 1) (c) ; context (t) ; task (maxdur) ; overall duration ) ;; help requested? (if (cmdline:option-given? (foo:script-args) option-list "--help") (help)) ;; validate cmdline (if (not (cmdline:cmdline-valid? (foo:script-args) option-list #t)) (help)) ;; get parameters (take in account just 1st param of each option) ;; input files (set! infiles (cmdline:get-arguments (cdr (foo:script-args)) option-list)) (cond ((null? infiles) (begin (display "no input file given on commandline!") (newline) (help))) ((> (length infiles) 1) (begin (display "more than one input file given on commandline!") (newline) (help))) (else (letrec ((exists (lambda (files) (cond ((null? files) #f) ((file-exists? (car files)) (exists (cdr files))) (else (display (string-append "input file not found: " (car files))) (newline) (exit)))))) (exists infiles)))) ;; outfile name (set! outfile (car (cmdline:get-option-param (foo:script-args) option-list "--outfile"))) ;; filetype (if (cmdline:option-given? (foo:script-args) option-list "--type") (set! type (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--type")))) (set! type ;; guess type from extension (let* ((rev (list->string (reverse! (string->list outfile)))) (guess (substring? "." rev)) (ext (if guess (foo:soundfile-extension-type (list->string (reverse! (string->list (substring rev 0 (1+ guess)))))) #f))) (if ext ext (soundfile-filetype (car infiles)))))) ;; sample format (if (cmdline:option-given? (foo:script-args) option-list "--sformat") (set! format (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--sformat")))) (set! format (soundfile-format (car infiles)))) ;; samplerate (if (cmdline:option-given? (foo:script-args) option-list "--srate") (set! srate (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--srate")))) (set! srate (soundfile-srate (car infiles)))) ;; channels (if (cmdline:option-given? (foo:script-args) option-list "--channels") (set! channels (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--channels")))) (set! channels (soundfile-channels (car infiles)))) ;; taps (if (cmdline:option-given? (foo:script-args) option-list "--quality") (let ((taps (* 2 (inexact->exact (/ (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--quality"))) 2))))) (cond ((< taps 4) (set! taps 4)) ((> taps 50) (set! taps 50))) (foo:set-default-taps! taps)) (foo:set-default-taps! 16)) ;; numparts (if (cmdline:option-given? (foo:script-args) option-list "--parts") (set! numparts (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--parts"))))) ;; prepare context (set! c (context channels)) ;; part length (set! maxdur (/ (soundfile-length (car infiles)) numparts)) ;; parts (with-context c (lambda () (let loop ((i numparts) (c 0)) (if (> i 0) (let* ((snd (snd-region (open-snd (car infiles)) (* (1- i) maxdur) maxdur)) ;; (normfact (* (/ (/ 1 (cdr (snd-absolute-maximum snd))) numparts) channels))) (normfact (* (/ 1 numparts) channels))) (output~ (1+ c) (mul~ (~ normfact) (read-snd~ snd))) (loop (1- i) (modulo (1+ c) channels))))))) ;; soundfile (if (cmdline:option-given? (foo:script-args) option-list "--force") (create-soundfile outfile type format srate channels) (make-soundfile outfile type format srate channels)) ;; task (set! t (make-task 0 0 outfile c 'punch srate)) ;; do it (run-task t maxdur) (quit)) ;; EOF --- NEW FILE: Makefile.am --- # foo/elkfoo/scripts/Makefile.am # 2007 rumori # $Id: Makefile.am,v 1.1 2007/12/14 19:36:39 rumori Exp $ NULL = EXTRA_DIST = $(SCRIPTS_FILES) noinst_DATA = $(SCRIPTS_FILES) SCRIPTS_FILES = \ foosine \ foocat \ foofold \ foodiary \ $(NULL) --- NEW FILE: foocat --- #!/usr/local/bin/foo -- --unload control ;; foocat: concatenate soundfiles ;; (c) 2004-2005 rumori (require 'cmdline) (let* ;; check commandline ;; single-opt or equiv-opts-list | mandatory? | with-params? | help-string ((option-list '((("--help" "-h") #f #f "this help screen") (("--outfile" "-o") #t #t "output file") (("--type" "-t") #f #t "output file type [guessed]") (("--sformat" "-s") #f #t "output file sample format [1st input file]") (("--srate" "-r") #f #t "output file sample rate [1st input file]") (("--channels" "-c") #f #t "output file channels [1st input file]") (("--quality" "-q") #f #t "resampling quality (2...50) [16]") (("--gap" "-g") #f #t "gap between concatenated soundfiles [0s]") (("--force" "-f") #f #f "overwrite output file if existing"))) (help (lambda () (format #t "~a: concatenate soundfiles~%" (car (foo:script-args))) (format #t "usage: ~a [options] -o outfile infile [infile ...]~%options understood:~%" (car (foo:script-args))) (format #t "~a~%" (cmdline:help-message option-list)) (exit))) (infiles) (outfile) (type) (format) (srate) (channels) (gap 0) (c) ; context (t) ; task (maxdur) ; overall duration ) ;; help requested? (if (cmdline:option-given? (foo:script-args) option-list "--help") (help)) ;; validate cmdline (if (not (cmdline:cmdline-valid? (foo:script-args) option-list #t)) (help)) ;; get parameters (take in account just 1st param of each option) ;; input files (set! infiles (cmdline:get-arguments (cdr (foo:script-args)) option-list)) (if (null? infiles) (begin (display "no input files given on commandline!") (newline) (help)) (letrec ((exists (lambda (files) (cond ((null? files) #f) ((file-exists? (car files)) (exists (cdr files))) (else (display (string-append "input file not found: " (car files))) (newline) (exit)))))) (exists infiles))) ;; outfile name (set! outfile (car (cmdline:get-option-param (foo:script-args) option-list "--outfile"))) ;; filetype (if (cmdline:option-given? (foo:script-args) option-list "--type") (set! type (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--type")))) (set! type ;; guess type from extension (let* ((rev (list->string (reverse! (string->list outfile)))) (guess (substring? "." rev)) (ext (if guess (foo:soundfile-extension-type (list->string (reverse! (string->list (substring rev 0 (1+ guess)))))) #f))) (if ext ext (soundfile-filetype (car infiles)))))) ;; sample format (if (cmdline:option-given? (foo:script-args) option-list "--sformat") (set! format (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--sformat")))) (set! format (soundfile-format (car infiles)))) ;; samplerate (if (cmdline:option-given? (foo:script-args) option-list "--srate") (set! srate (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--srate")))) (set! srate (soundfile-srate (car infiles)))) ;; channels (if (cmdline:option-given? (foo:script-args) option-list "--channels") (set! channels (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--channels")))) (set! channels (soundfile-channels (car infiles)))) ;; taps (if (cmdline:option-given? (foo:script-args) option-list "--quality") (let ((taps (* 2 (inexact->exact (/ (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--quality"))) 2))))) (cond ((< taps 4) (set! taps 4)) ((> taps 50) (set! taps 50))) (foo:set-default-taps! taps)) (foo:set-default-taps! 16)) ;; gap (if (cmdline:option-given? (foo:script-args) option-list "--gap") (set! gap (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--gap"))))) (set! maxdur (- gap)) ;; gap gets added once more ;; prepare context (set! c (context channels)) (letrec ((cat-channel (lambda (snd chan off dur) (if (> chan 0) (begin (if (>= (snd-channels snd) chan) ;; do the actual work per channel (output~ chan (time off (gate~ (read-snd~ (snd-extract snd chan)) dur)))) (cat-channel snd (1- chan) off dur))))) (cat-file (lambda (files lastoff) (if (not (null? files)) (let* ((snd (open-snd (car files))) (dur (snd-length snd))) (set! maxdur (+ maxdur dur gap)) (cat-channel snd channels lastoff dur) (cat-file (cdr files) (+ lastoff dur gap))))))) (with-context c (lambda () (cat-file infiles 0)))) ;; soundfile (if (cmdline:option-given? (foo:script-args) option-list "--force") (create-soundfile outfile type format srate channels) (make-soundfile outfile type format srate channels)) ;; task (set! t (make-task 0 0 outfile c 'punch srate)) ;; do it (run-task t maxdur) (quit)) ;; EOF |