foo-cvs

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

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

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

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

;
;;      General & Unix
;
(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 (open file)
    (system (string-append "open " file)))

(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)))))

;
;;	Numbers & functions
;
(define pi (* 4 (atan 1)))

(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)))))

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

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

;
;;      Psychoacoustics & Frq related other
;
(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)))))

;
;;
;
(provide 'util)