[foo-cvs] foo/elkfoo/examples/scripts fscat.foo, NONE, 1.1 fsdiary.foo, NONE, 1.1 fsfold.foo, NONE, 1.1 sndcat.foo, 1.2, NONE

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/examples/scripts
In directory sc8-pr-cvs17:/tmp/cvs-serv16089

Added Files:
	fscat.foo fsdiary.foo fsfold.foo 
Removed Files:
	sndcat.foo 
Log Message:
added some scripting examples

--- NEW FILE: fscat.foo ---
#!/usr/local/bin/foo --

;; fscat: 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

--- sndcat.foo DELETED ---

--- NEW FILE: fsfold.foo ---
#!/usr/local/bin/foo --

;; fsfold: 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: fsdiary.foo ---
#!/usr/local/bin/foo --

;; fsdiary: 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)))
     (infiles)
     (outfile)
     (type)
     (format)
     (srate)
     (channels)
     (period)
     (duration)
     (xfadelength)
     (xfadetype)
     (begint)
     (endt)
     (curinpos) ;; current infile position
     (curoutpos) ;; current outfile position
     (outinc) ;; outputfile increment
     (normbpf)
     (startbpf)
     (endbpf)
     (overalldur)
     (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))

  ;; period
  (set! period (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--period"))))

  ;; duration
  (if (cmdline:option-given? (foo:script-args) option-list "--duration")
      (set! duration (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--duration"))))
      (set! duration period))
  
 ;; xfadelength
  (if (cmdline:option-given? (foo:script-args) option-list "--xfadelength")
      (set! xfadelength (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--xfadelength"))))
      (set! xfadelength 0))
  
 ;; xfadetype
  (if (cmdline:option-given? (foo:script-args) option-list "--xfadetype")
      (begin
	(set! xfadetype (string->symbol (car (cmdline:get-option-param (foo:script-args) option-list "--xfadetype"))))
	(if (not (or (equal? xfadetype 'log)
		     (equal? xfadetype 'expon)
		     (equal? xfadetype 'line)))
	    (begin
	      (display "xfadetype not valid!")
	      (newline)
	      (help))))
      (set! xfadetype 'log))
  
 ;; 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")
      (set! endt (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--end"))))
      (set! endt (soundfile-length (car infiles)))) ;; needs further attention

  ;; outfile increment
  (set! outinc (- duration xfadelength))

  ;; overall duration
  (set! overalldur
	(let
	    ((numslices (/ (soundfile-length (car infiles)) period)))
	  (+ (* (- duration xfadelength)
		(trunc numslices))
	     (* duration (- numslices (trunc numslices))))))

  ;; prepare context
  (set! c (context channels))

  ;; make bpfs
  (with-context c (lambda ()
		    (set! normbpf (make-bpf (list '(0 0) (list xfadelength 1) (list outinc 1) (list duration 0))))
		    (set! startbpf (make-bpf (list '(0 1) (list outinc 1) (list duration 0))))
		    (set! endbpf (make-bpf (list '(0 0) (list xfadelength 1) (list duration 1))))))

  (letrec
      ;; write single slice per channels
      ((cat-slice (lambda (slice chan off bpf)
		    (if (> chan 0)
			(begin
			  (if (>= (snd-channels slice) chan)
			      ;; do the actual work per channel
			      (output~ chan (time off (gate~ (mul~ (read-bpf~ bpf) (read-snd~ (snd-extract slice chan))) (snd-length slice)))))
;;			      (output~ chan (time off (gate~ (read-snd~ (snd-extract slice chan)) (snd-length slice))))
			  (cat-slice slice (1- chan) off bpf)))))
		      
       ;; write input file per slice
       (cat-slices (lambda (file curoutpos curinpos)
		     (let*
			 ((snd (open-snd file)))
		       (cond
			;; first slice
			((= curoutpos 0)
			 (begin
			   (cat-slice (snd-region snd curinpos duration) channels curoutpos startbpf)
			   (cat-slices file (+ curoutpos outinc) (+ curinpos period))))
			;; last slice truncated
			((>= (+ curinpos duration) (snd-length snd))
			 (cat-slice (snd-region snd curinpos (- (snd-length snd) curinpos)) channels curoutpos endbpf))
			;; last slice complete
			((>= (+ curinpos period) (snd-length snd))
			 (cat-slice (snd-region snd curinpos duration) channels curoutpos endbpf))
			;; normal slice
			(else
			 (begin
			   (cat-slice (snd-region snd curinpos duration) channels curoutpos normbpf)
			   (cat-slices file (+ curoutpos outinc) (+ curinpos period)))))))))

    (with-context c (lambda () (cat-slices (car infiles) 0 begint))))

  ;; 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