[foo-cvs] foo/elkfoo/scripts foojoin,NONE,1.1 Makefile.am,1.2,1.3

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

Update of /cvsroot/foo/foo/elkfoo/scripts
In directory sc8-pr-cvs17.sourceforge.net:/tmp/cvs-serv11430

Modified Files:
	Makefile.am 
Added Files:
	foojoin 
Log Message:
added foojoin script

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scripts/Makefile.am,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Makefile.am	14 Dec 2007 19:55:42 -0000	1.2
--- Makefile.am	7 Jan 2008 21:20:02 -0000	1.3
***************
*** 17,19 ****
--- 17,20 ----
  	foofold \
  	foodiary \
+ 	foojoin \
  	$(NULL)

--- NEW FILE: foojoin ---
#!/usr/local/bin/foo -- --unload control

;; foojoin: make multichannel file out of mono files
;; (c) 2008 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 [number of input files]")
		    (("--duration" "-d") #f #t "output file duration [1st input file]")
		    (("--quality" "-q") #f #t "resampling quality (2...50) [16]")
		    (("--force" "-f") #f #f "overwrite output file if existing")
		    (("--zick" "-z") #f #f "check for equal samplerate, length and mono of input files [false]")))

     (help
      (lambda ()
	(format #t "~a: make multichannel file out of mono files~%" (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)
     (duration)
     (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)))
  
  ;; 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")
      (begin
	(set! channels (string->number (car (cmdline:get-option-param (foo:script-args) option-list "--channels"))))
	(if (< channels (length infiles))
	    ;; truncate infiles list to number of channels
	    (set! infiles (list-head infiles channels))))
      (set! channels (length 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))

  ;; 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 (soundfile-length (car infiles))))

  ;; zick
  (if (cmdline:option-given? (foo:script-args) option-list "--zick")
      (letrec ((length (soundfile-length (car infiles)))
	       (srate (soundfile-srate (car infiles)))
	       (check (lambda (files)
			(cond ((null? files) #f)
			      ((not (= 1 (soundfile-channels (car files))))
			       (error (string-append "input file not mono: " (car files))))
			      ((not (= length (soundfile-length (car files))))
			       (error (string-append "input file length mismatch: " (car files))))
			      ((not (= srate (soundfile-srate (car files))))
			       (error (string-append "input file samplerate mismatch: " (car files))))
			      (else
			       (check (cdr files)))))))
	(check infiles)))

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

  ;; process files
  (with-context c (lambda ()
		    (letrec
			((cat-file (lambda (files chan)
				     (if (not (null? files))
					 (begin
					   (output~ chan (read-snd~ (open-snd (car files))))
					   (cat-file (cdr files) (1+ chan)))))))
    (cat-file infiles 1))))

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

(quit)

;; EOF