[foo-cvs] foo/elkfoo/scm/tools/util Makefile.am,NONE,1.1 misc-funs.foo,NONE,1.1 sound-funs.foo,NONE,1.1

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

Update of /cvsroot/foo/foo/elkfoo/scm/tools/util
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6585/tools/util

Added Files:
	Makefile.am misc-funs.foo sound-funs.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: sound-funs.foo ---
(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 paz))

(define (make-sndname naam . flg)
  (let* ((naam (if (symbol? naam) (symbol->string naam) naam))
  	 (aux (string->list naam)) (flg (if (not (null? flg)) #t #f)))
    (if (and (not (equal? (string (car aux)) "/"))
	     (not (equal? (string (car aux)) "."))
	     (not (equal? (string (car aux)) ".."))
	     (not (equal? (string (car aux)) "~"))
	     (not (equal? (string (car aux)) "^")))
    	(set! naam (format #f "~a/~a" (get-SFDIR) naam)))

    ;; don't look after extension
    naam))

;; original stuff
;     (set! aux (list->string (list-tail aux (- (length aux) 3))))
;     (if (or flg (equal? aux "snd") (equal? aux "imx"))
; 	naam
; 	(format #f "~a.snd" naam))))


(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
		    'short
		    (soundfile-channels input)
		    (soundfile-srate input)
		    (soundfile-filetype 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 sndinfo (lambda args (unix-command 'sndinfo 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 "Size      :    ~a~%" (soundfile-length file))
     (format #t "FileType  :    ~a~%" (soundfile-filetype 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 "~%")))))

;
(define (blay sf) (system (string-append "quadplay -b " sf)))
;




--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/tools/util/Makefile.am
# 2004 rumori

# $Id: Makefile.am,v 1.1 2004/08/07 22:53:02 rumori Exp $

NULL = 

pkgutilities_DATA = $(ELKFOO_UTILITIES_FILES)

pkgutilitiesdir = $(pkgdatadir)/tools/util

ELKFOO_UTILITIES_FILES = \
	misc-funs.foo \
	sound-funs.foo \
	$(NULL)

--- NEW FILE: misc-funs.foo ---
(define comment (macro l #v))

(define (identity x) x)

(define sh
    (macro list
	`(let ((port (open-output-string)))
	    (write '(,@list) port)
	    (let ((line (get-output-string port)))
		(system (substring line 1 (- (string-length line) 1))) #v))))

(define pi (* 4 (atan 1)))

;(define (pow a b)
;  (exp (* b (log a))))

(define log10
  (let ((log-of-10 (log 10)))
    (lambda (x)
      (/ (log x) log-of-10))))

(define log2
  (let ((log-of-2 (log 2)))
    (lambda (x)
      (/ (log x) log-of-2))))

(define (Hz->Midics f)
    (+ 6900 (* 1200 (log2 (/ f 440)))))

(define (Midics->Hz f)
    (* 440 (pow 2 (/ (- f 6900) 1200))))

;;
;; center frequency (Hz) to f1 parameter for state variable filter (fve~)
;; fc = center frequency in Hz, fs = sampling frequency in Hz
;;

(define (fc->f1 fc fs)
    (sin (/ (* 2 pi fc) fs)))

;;
;; bandwidth to q1 parameter for state variable filter (fve~)
;; bw = bandwidth in Hz, fs = center frequency in Hz
;;

(define (bw->q1 bw cf)
    (/ bw cf 2))

;;
;; critical band width in Hz at frequency f in Hz
;; from: Zwicker, Psychoakustik, Springer 1982, p. 67
;;

(define (critical-band-width f)
    (+ 25 (* 75 (pow (+ 1 (* .0000014 f f)) .69))))

;; frequency depending damping in dB of uniformly exciting noise (f in Hz)
;; from: Feldkellter & Zwicker, Das Ohr als Nachrichtenempfaenger,
;; Hirzel 1967, p. 107

(define (agar f)
    (- (* 10 (log10 (critical-band-width f))) 20))

;; converts a frequency f in Hertz to the corresponding value in Bark
;; from: Zwicker, Psychoakustik, Springer 1982, p. 67

(define (Hz->Bark f)
    (+ (* 13. (atan (* 0.00076 f))) (* 3.5 (atan (/ (* f f) 56250000.)))))

;; iterative approximation of ferquency in Hz corresponding to value in Bark
;; uses Hz->Bark

(define (Bark->Hz z)
    (let ((hz 1) (zz) (dh) (dx 10))
	(if (> z 25) (set! z 25))
	(if (< z 0) (set! z 0))
	(define (helper)
	    (set! zz (- (Hz->Bark hz) z))
	    (if (= 0 zz)
	    hz
		(set! dh (/ dx (- 1 (/ (- (Hz->Bark (+ hz dx)) z) zz))))
		(set! hz (+ hz dh))
		(if (> dh dx)
		    (helper)
		    hz)))
	(helper)))
  
;; absolute threshold in dB SPL depending in frequency in Hz

(define (absolute-threshold f)
    (let* ((ff (/ f 1000)) (f4 (* ff ff ff ff)) (f3 (- ff 3.3)))
	(if (<= ff 0)
	    0
	    (+ (- (* 3.64 (pow ff -.8))
	          (* 6.5 (exp (* -.6 f3 f3)))) (* .001 f4)))))

(define (dodeca f n)
  (* f (exp (* (/ n 12) (log 2)))))

(define (linear x y0 y1) ; x: 0 -> 1
    (+ y0 (* x (- y1 y0))))

(define (expon x y0 y1 b) ; x: 0 -> 1
  (when (<= b 0)
	(error 'expon "base (~a) must be greater that zero" b))
  (+ y0 (if (equal? b 1)
	    (* x (- y1 y0))
	    (* (- y1 y0) (/ (- (pow b x) 1) (- b 1))))))

;;;;;	    (/ (* (- (pow b (+ x 1)) b) (- y1 y0)) (- (* b b) b)))))

(define (power x y0 y1 e) ; x: 0 -> 1
  (+ y0 (* (pow x e) (- y1 y0))))

(define (lin->dB x)
  (* 20 (log10 x)))

(define (dB->lin x)
  (pow 10 (/ x 20)))

(define (fun->env fun x0 x1 dx)
  (define (loop x)
    (if (< x x1)
	(cons (list x (fun x)) (loop (+ x dx)))
	(list (list x1 (fun x1)))))
  (loop x0))

(define (x->dx l)
    (define (helper s x)
	(if (null? x)
	    '()
	    (cons (- (car x) s) (helper (car x) (cdr x)))))
    (helper (car l) (cdr l)))

(define (dx->x f l)
    (define (helper s x)
	(if (null? x)
	    '()
	    (cons (+ (car x) s) (helper (+ (car x) s) (cdr x)))))
    (cons f (helper f l)))

(define (dx->dy fun x dx)
    (- (fun (+ x dx)) (fun x)))

(define (dy->dx fun inv x dy)
    (inv (/ (+ (fun x) dy) (fun x))))

(define (open file)
    (system (string-append "open " file)))

(define (within a b)
    (+ a (* (/ (random) 2147483647) (- b a))))

(define (make-brownian a b c)
    (let* ((range (- b a))
	   (last (+ a (/ range 2)))
           (factor (* c (/ range 2147483647)))
	   (offset (* c (/ range -2))))
	(lambda ()
	    (set! last (+ last (* (random) factor) offset))
		(if (> last b)
		    (set! last (+ a (- (* range 2) last)))
		    (if (< last a)
			(set! last (- a last))))
	    last)))

(define-macro (repeat number . expressions)
    `(do ((_i_ 0 (1+ _i_))) ((= ,number _i_) #t) ,@expressions))

(define (iterate count thunk)
    (let ((result '()))
	(repeat count (set! result (cons (thunk) result)))
	(reverse result)))

(define (unix-command command args)
    (define (helper x)
	(string-append (if (symbol? x) (symbol->string x) x) " "))
    (system (apply string-append (map helper (cons command args)))))

;
;;
;;;	Printing functions
;;
;

(define prn
    (lambda l (for-each (lambda (x) (format #t "~a " x)) l) (newline) #v))

(define prin
    (lambda l (for-each (lambda (x) (format #t "~a " x)) l) #v))

(define sprintf foo:num-sprintf)

;
;;
;;;	Predicates
;;
;

(define (bpflike-pair? arg)
  (let ((flg #t))
      (if (pair? arg)
	(for-each
	  (lambda (x)
	     (if (and (pair? x)
		      (or (= (length x) 2)
			  (= (length x) 3)))
		 (for-each (lambda (y) (if (not (number? y)) (set! flg #f))) x)
		 (set! flg #f))) arg)
	(set! flg #f))
      flg))

(define (numerical? el)
  (let ((flg #t))
      (if (pair? el)
	(for-each (lambda (x) (if (not (numerical? x)) (set! flg #f))) el)
	(if (not (number? el)) (set! flg #f)))
      flg))

(define (symbolic? el)
  (let ((flg #t))
      (if (pair? el)
	(for-each (lambda (x) (if (not (symbolic? x)) (set! flg #f))) el)
	(if (not (symbol? el)) (set! flg #f)))
      flg))

(define (stringed? el)
  (let ((flg #t))
      (if (pair? el)
	(for-each (lambda (x) (if (not (stringed? x)) (set! flg #f))) el)
	(if (not (string? el)) (set! flg #f)))
      flg))

;
;;
;;;	Lists and Pairs
;;
;

(define (list? x)
  (let loop ((fast x) (slow x))
    (or (null? fast)
	(and (pair? fast)
	     (let ((fast (cdr fast)))
	       (or (null? fast)
		   (and (pair? fast)
			(let ((fast (cdr fast))
			      (slow (cdr slow)))
			  (and (not (eq? fast slow))
			       (loop fast slow))))))))))

(define (flatten l)
    (if (null? l)
	'()
	(if (pair? (car l))
	    (append (flatten (car l)) (flatten (cdr l)))
	    (cons (car l) (flatten (cdr l))))))

(define (clean Lst) 
   (while (and (pair? Lst)
               (= (length Lst) 1)
               (list? (car Lst))) (set! Lst (car Lst))) Lst)

(define (flatout l) (clean (flatten l)))

(define (cleanlist l)
    (if (null? l)
	'()
	(if (list? (car l))
	    (append (cleanlist (car l)) (cleanlist (cdr l)))
	    (cons (car l) (cleanlist (cdr l))))))

(define nth list-ref)

(define (list-head Lst num)
  (let* ((lnz (length Lst)) (num (- lnz num)))
      (reverse (list-tail (reverse Lst) num))))
     
(define (first-symbol Lst)
  (let ((val #f))
     (for-each (lambda (x) (if (and (not val)
     				    (symbol? x)) (set! val x))) (flatten Lst))
     val))
;
;;
;;;	Numbers
;;
;

(define (trunc num) (inexact->exact (truncate num)))
(define (rund num)  (inexact->exact (round num)))

(define (fmod val1 val2 . aproxval)
  (let ((aproxval (if (null? aproxval) #f (trunc (pow 10 (car aproxval)))))
  	(coef))
     (if aproxval (begin (set! val1 (round (* val1 aproxval)))
     			 (set! val2 (round (* val2 aproxval)))))
     (set! coef (truncate (/ val1 val2)))
     (if aproxval (/ (- val1 (* coef val2)) aproxval)
		  (- val1 (* coef val2)))))

;
;;
;;;	Object Functionalities
;;
;
(define (get-Name f) (class-name f))

(define (get-SuperName f) 
    (cond
    	((instance? f)	(vector-ref (eval (get-Name f)) 4))
	((class? f)	(vector-ref f 4))))

;
;;
;

(provide 'util)