foo-cvs

[Ramon Gonzalez-A. <rg...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/util
In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv21250/util

Added Files:
	soundfile-funs.foo 
Log Message:
new branch with utility functions formerly at control/tools/util

--- NEW FILE: soundfile-funs.foo ---
;
;;
;;;
;;;;                         soundfile-funs.foo
;;;
;;
;

;
;;
;;;  foo:SFDIR
;;
;
(define foo:SFDIR (foo:test-file-dir))

(define (get-SFDIR) foo:SFDIR)

(define (set-SFDIR paz)
   (if (symbol? paz) (set! paz (symbol->string paz)))
   (set! foo:SFDIR (tilde-expand paz)))

;
;;
;;;  soundfile extensions and types
;;
;

;
;; boolean for automatic extension mechanism
;
(define foo:default-soundfile-extension? #t)
(define (foo:soundfile-extension?) foo:default-soundfile-extension?)
(define (foo:set-soundfile-extension?! bul)
   (if (boolean? bul)
      (set!  foo:default-soundfile-extension? bul)
      (error 'foo:set-soundfile-extension?! "Not a boolean: ~a" bul)))

;
;;default & user database of type-extensions
;
(define foo:default-soundfile-extension-database
    (list
	(list 'aiff	(list ".aiff" ".aif"))
	(list 'snd	(list ".snd" ".au"))
	(list 'wav	(list ".wav"))
	(list 'pdf	(list ".pdf"))
	(list 'svx	(list ".svx"))
	(list 'nist	(list ".nist"))
	(list 'voc	(list ".voc"))
	(list 'ircam	(list ".sf" ".ircam"))
	(list 'wav64	(list ".wav64"))
	(list 'mat4	(list ".mat4"))
	(list 'mat5	(list ".mat5"))
	(list 'pvf	(list ".pvf"))
	(list 'xi	(list ".xi"))
	(list 'flac     (list ".flac"))
	(list 'imx      (list ".imx"))))
(define foo:user-soundfile-extension-database 
	foo:default-soundfile-extension-database)

;
;;default type (probably to be changed). Leaning on the definition in elkfoo.scm
;
(define (foo:default-soundfile-type) foo-default-soundfile-filetype)
(define (foo:set-default-soundfile-type! type)
    (if (symbol? type) (set! type (symbol->string type)))
    (set! foo-default-soundfile-filetype type))

;
;;get extension from type (see all database or see defaultdatabase)
;
(define (foo:soundfile-type-extension . type)
  (let ((xtn))
   (set! type (if (null? type) type (car type)))
   (if (string? type) (set! type (string->symbol type)))
   (cond
      ((eq? type 'default)    foo:default-soundfile-extension-database)
      ((or (null? type)
	   (eq? type 'all)) foo:user-soundfile-extension-database)
      (#t  (set! xtn (assq type foo:user-soundfile-extension-database))
	   (if xtn (caadr xtn) #f)))))

;
;;get type from extension
;
(define (foo:soundfile-extension-type extension)
   (let ((type #f))
       (if (symbol? extension) (set! extension (symbol->string extension)))
       (for-each
	   (lambda (x) (if (member extension (cadr x)) (set! type (car x))))
	   foo:user-soundfile-extension-database)
       type))

;
;; get type and extension from name of soundfile
;
(define (foo:find-name-type-extension name)
   (let ((aux) (k 0) (el 0) (nameext) (nametyp)
	)
     (if (symbol? name) (set! name (symbol->string name)))
     (set! aux (string->list name))
     (for-each
	 (lambda (x) (set! k (+ 1 k))
		     (if (equal? (string x) ".") (set! el k))) 
	 (cdr aux))
     (if (= el 0) #f
		  (begin
		     (set! nameext (list->string (list-tail aux el)))
		     (set! nametyp (foo:soundfile-extension-type nameext))
		     (if nametyp (list nametyp nameext) #f)))))

;
;;set extension from type (or recover default settings)
;
(define (foo:set-soundfile-type-extension! type extension)
  (if (string? type) (set! type (string->symbol type)))
  (if (symbol? extension) (set! extension (symbol->string extension)))
  (if (equal? extension "default") 
     (foo:set-default-soundfile-type-extension! type)
     (let ((aux) (flg #t) (flg2 #f))
         (if (pair? extension)
            (set! extension (map 
				(lambda (x) 
				    (if (symbol? x) (symbol->string x) x))
				extension))
            (set! flg #f))
         (set! aux 
		(map 
		  (lambda (x) 
		      (if (eq? type (car x))
			 (begin
			   (set! flg2 #t)
			   (list (car x) (if flg extension (list extension))))
			 x)) 
	        foo:user-soundfile-extension-database))
         (if flg2 (set! foo:user-soundfile-extension-database aux)
		  (error 'foo:set-soundfile-type-extension! "Unknown type : ~a~%" type)))))

(define (foo:set-default-soundfile-type-extension! type)
  (let ((aux) (flg #f))
    (if (eq? type 'all)
       (set! foo:user-soundfile-extension-database 
		foo:default-soundfile-extension-database)
       (begin
	  (set! aux
	          (map 
		     (lambda (x y) 
			(if (eq? type (car x)) (begin (set! flg #t) y) x)) 
		     foo:user-soundfile-extension-database
		     foo:default-soundfile-extension-database))
	  (if flg (set! foo:user-soundfile-extension-database aux)
	         (error 'foo:set-soundfile-type-extension! "Unknown type : ~a~%" type))))))


;
;;
;;; path-expand (tilde-expand + hat expand)
;;
;

;
;;hat-expand -> environment SFDIR or foo:SFDIR {not sure about this one}
;
(define (hat-expand naam)
  (if (symbol? naam) (set! naam (symbol->string naam)))
  (if (equal? (string (string-ref naam 0)) "^")
     (let ((dir (getenv "SFDIR"))
  	   (aux (list->string (cdr (string->list naam)))))
	 (if (not dir) (set! dir (get-SFDIR)))
	 (format #f "~a~a" dir aux))
     naam))

(define (path-expand naam) (hat-expand (tilde-expand naam)))

;
;;
;;; make-sndname (new definition)
;;
;
(define (make-sndname name . type)
  (let ((elem) (aux) (k 0) (el 0)
	(typeext) (nametyp #f) (nameext #f))

;backwards compatibility ->
    (if (and (not (null? type))
	     (boolean? (car type)))
       (begin
 	  (foo:set-soundfile-extension?! (car type))
	  (set! type '())))
;until here <-

    (if (not (null? type))
       (begin
	  (set! type (car type))
	  (if (string? type) (set! type (string->symbol type)))
          (set! typeext (foo:soundfile-type-extension type))
	  (if (not typeext) 
	     (error 'make-sndname "Second argument is not a soundfile-type: ~a~%" type)))
       (set! typeext (foo:soundfile-type-extension (foo:default-soundfile-type))))

    (if (symbol? name) (set! name (symbol->string name)))
    (set! elem (string (string-ref name 0)))
    (set! name (if (and (not (equal? elem "/"))
			(not (equal? elem "."))
			(not (equal? elem ".."))
			(not (equal? elem "~"))
			(not (equal? elem "^"))) (format #f "~a/~a" (get-SFDIR) name)
						 (path-expand name)))

    (if (not (foo:soundfile-extension?)) 
       name
       (begin
	  (set! nameext (foo:find-name-type-extension name))
	  (if (not nameext)
	     (format #f "~a~a" name typeext)
	     (begin 
		(set! nametyp (car nameext))
		(set! nameext (cadr nameext))
		(if (and (not (null? type))
			 (not (equal? nametyp type))) 
		   (begin 
	               (format #t "~%WARNING << make-sndname >> 1st arg's extension and 2nd arg (type) do not coincide : ~a ~a~%" nameext type) 
	               (format #f "~a~a" name typeext))
		   name)))))
     ))

;
;;
;;; sndnorm & fsndnorm {float->short / maximum is kept}
;;
;
(define (sndnorm input output . maximum)
    (set! input (make-sndname input))
    (set! output (make-sndname output))

    (set! maximum (if (null? maximum) 1 (car maximum)))
    (create-soundfile output
	(soundfile-filetype input)
	'short
	(soundfile-srate input)
	(soundfile-channels input))
    (run-task
	(make-task 0 0 output
	    (context (soundfile-channels input)
		(let* ((s (open-snd input))
		       (f (~ (/ maximum (cdr (snd-absolute-maximum s))))))
		    (do ((c 1 (+ c 1)))
			((> c (snd-channels s)) #t)
			(output~ c
			    (mul~ f (read-snd~ (snd-extract s c))))))))
	(soundfile-length input)) #v)

(define (fsndnorm input output)
  (let ((maxy (min 1.0 (soundfile-maximum (make-sndname input)))))
     (prn "Maximum is :"maxy)
     (sndnorm input output maxy)))

;
;;
;;; sndinfo & soundinfo
;;
;
(define sndinfo (lambda args (unix-command 'sndfile-info args)))

(define (soundinfo file)
  (let* ((s) (file (make-sndname file))
  	 (srate (soundfile-srate file)) (maxi) (sampi) (timi) (comm))
     (format #t "Filename  :	~a~%" file)
     (format #t "Type      :	~a~%" (soundfile-filetype file))
     (format #t "Size      :	~a~%" (soundfile-length file))
     (format #t "Format    :	~a~%" (soundfile-format file))
     (format #t "Sam. Rate :	~a~%" srate)
     (format #t "Channels  :	~a~%" (soundfile-channels file))
     (context (soundfile-channels file) (set! s (open-snd file)))
     (set! maxi (cdr (snd-absolute-maximum  s)))
     (set! sampi (car (snd-absolute-maximum  s)))
     (set! timi (sprintf "%.3f" (/ sampi srate)))
     (format #t "Abs. Max. :	~a,	at : ~a,	~a secs.~%"
     		 maxi sampi timi)
     (if (> (soundfile-channels file) 1)
       (begin
        (format #t "~%")
	(do ((c 1 (+ c 1))) ((> c (snd-channels s)) #t)
	    (if (> (abs (cdr (snd-minimum s c))) (cdr (snd-maximum s c)))
	       (begin
	       	  (set! maxi (abs (cdr (snd-minimum s c))))
		  (set! sampi (car (snd-minimum s c))))
	       (set! maxi (cdr (snd-maximum s c)))
	       (set! sampi (car (snd-maximum s c))))
	    (set! timi (sprintf "%.3f" (/ sampi srate)))
	    (format #t "Ch~a  Max. :	~a,	at : ~a,	~a secs.~%"
	    		c maxi sampi timi))
	(format #t "~%")))
;     (set! comm (soundfile-comment file))
;     (if (not (equal? comm ""))
;	(format #t  "Comment   :	~a~%" (soundfile-comment file))
	(format #t "~%")))

;
;;
;;; unix operations with soundfiles
;;
;
(define (unix-sndcp a b)
   (system (string-append "/bin/cp "(make-sndname a)" "(make-sndname b))))

(define (unix-sndmv a b)
   (system (string-append "/bin/mv -f "(make-sndname a)" "(make-sndname b))))

(define (unix-sndrm a)
   (system (string-append "/bin/rm -f "(make-sndname a))))