foo-cvs

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

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

Added Files:
	pitch.foo 
Log Message:
moved pitch.foo into util dir

--- NEW FILE: pitch.foo ---
(define (kw sbdv)
    (if (<= sbdv 0) 1.
		    (exp (/ (log 2) sbdv))))
;
(define (nwnt frq intv sbdv)
   (let ((n) (frq (pitch frq)))
    (if (= intv 0) frq
    		   (set! n (pow  (kw sbdv) (abs intv)))
		   (if (> intv 0) (* frq n)
			    	  (/ frq n)))))
;
(define (xpose frq intv sbdv)
   (let ((frq (pitch frq)))
      (* frq (exp (* (/ intv sbdv) (log 2))))))
;
(define (decodepitch note)
   (let ((note (if (symbol? note) (symbol->string note) note))
   	 (pitchclass) (octvsign) (octv) (accidental)
	 (xst) (xsy) (xnu) (i) (num))
    (for-each
    	(lambda (x)
	    (set! xst (make-string 1 x))
	    (set! xsy (string->symbol xst))
	    (set! xnu (string->number xst))
	    (if (not (or (equal? '- xsy)
			 (equal? '+ xsy)
			  xnu))
		(if (or (equal? "b" xst)
			(equal? "h" xst)
			(equal? "q" xst)
			(equal? "#" xst)
			(equal? "z" xst)
			(equal? "x" xst))
		    (set! accidental (cons xst accidental))
		    (set! pitchclass (cons x pitchclass)))
		    (if (null? octvsign)
		  	(if xnu (begin (set! octv (cons xnu octv))
				       (set!  octvsign 1))
		      		(set! octvsign (if (equal? '- xsy) -1 +1)))
			(set! octv (cons xnu octv))))) (string->list note))
    (set! pitchclass (string->symbol (list->string (reverse pitchclass))))
    (set! accidental
      		(map (lambda (x) (string->symbol x)) (reverse accidental)))
    (set! i -1)
    (set! num 0)
    (if (not (null? octv))
      (begin
        (for-each
    	   (lambda (x) (set! i (1+ i))
		       (set! num (+ num (* x (pow 10 i))))) octv)
      (list pitchclass accidental (* num octvsign)))
      (list pitchclass accidental))))

(define (decodepitchclass symb)

   (cond
     ((string? symb)	#t)
     ((symbol? symb)	(set! symb (symbol->string symb)))
     (#t		(error 'decodepitchclass "Not a pitch-class ~s"symb)))

   (cond
     ((equal? symb "do")	0)
     ((equal? symb "re")	8)
     ((equal? symb "mi")	16)
     ((equal? symb "fa")	20)
     ((equal? symb "sol")	28)
     ((equal? symb "la")	36)
     ((equal? symb "si")	44)
     (#t			symb)))

(define (decodeaccidental acc)
  (if (list? acc) 
     (map (lambda (x) (decodeaccidental x)) acc)
     (cond
	((string? acc)	#t)
	((symbol? acc)	(set! acc (symbol->string acc)))
	((char?   acc)	(set! acc (make-string 1 acc)))
	(#t		(error 'decodeaccidental "Not an accidental ~s"acc)))
     (cond
	((equal? acc "b")	-4)

	((equal? acc "")	0)

	((equal? acc "h")	1)
	((equal? acc "q")	2)

	((equal? acc "#")	4)
	((equal? acc "z")	4)

	((equal? acc "x")	8)
	
	(#t 		(error 'decodeaccidental "Not an accidental ~s"acc)))))

(define foo:pitchreference (list 'la 4 440.))

(define (Relativefrequency intv octave . Reference)
   (let* ((Reference (if (not (null? Reference)) (clean Reference)))
   	  (Reference (if (and (pair? Reference)
			      (symbol? (car Reference))
			      (number? (cadr Reference))
			      (number? (caddr Reference))) Reference
			      				   foo:pitchreference))
	 (frqreference  (caddr Reference))
	 (octvreference (cadr Reference))
	 (intvreference (decodepitchclass (car Reference)))
	 (frq) (nwintv))

	    (set! frq (* frqreference (pow 2 (- octave octvreference))))
	    (set! nwintv (- intv intvreference))
	    (xpose frq nwintv 48)))

(define (pitch->frq note)
   (cond
      ((or (symbol? note)
      	   (string? note))
      	  (let* ((auxy (decodepitch note))
      		 (pit (decodepitchclass (car auxy)))
      		 (accs (decodeaccidental (cadr auxy)))
		 (octv))
	     (if (< (length auxy) 3)
	        note
		(set! octv (caddr auxy))
	        (if (and (number? octv)
	     	         (number? pit)
		         (or (numerical? accs)
		      	     (null? accs)))
		   (Relativefrequency (apply + (cons pit accs)) octv)
		   note))))
      ((and (pair? note)
      	    (or (stringed? note)
      	        (symbolic? note))) (map (lambda (x) (pitch->freq x)) note))
      (#t		note)))
;
(define pitch->freq pitch->frq)
(define pitch pitch->frq)
;
;;
;;;
;;
;
(define (decodepitnumb posit)
   (cond
      ((= posit 0 )	'do)
      ((= posit 1 )	'doh)
      ((= posit 2 )	'doq)
      ((= posit 3 )	'doqh)
      ((= posit 4 )	'doz)
      ((= posit 5 )	'dozh)
      ((= posit 6 )	'dozq)
      ((= posit 7 )	'dozqh)
      ((= posit 8 )	're)
      ((= posit 9 )	'reh)
      ((= posit 10)	'req)
      ((= posit 11)	'reqh)
      ((= posit 12)	'mib)
      ((= posit 13)	'rezh)
      ((= posit 14)	'rezq)
      ((= posit 15)	'rezqh)
      ((= posit 16)	'mi)
      ((= posit 17)	'mih)
      ((= posit 18)	'miq)
      ((= posit 19)	'miqh)
      ((= posit 20)	'fa)
      ((= posit 21)	'fah)
      ((= posit 22)	'faq)
      ((= posit 23)	'faqh)
      ((= posit 24)	'faz)
      ((= posit 25)	'fazh)
      ((= posit 26)	'fazq)
      ((= posit 27)	'fazqh)
      ((= posit 28)	'sol)
      ((= posit 29)	'solh)
      ((= posit 30)	'solq)
      ((= posit 31)	'solqh)
      ((= posit 32)	'lab)
      ((= posit 33)	'solzh)
      ((= posit 34)	'solzq)
      ((= posit 35)	'solzqh)
      ((= posit 36)	'la)
      ((= posit 37)	'lah)
      ((= posit 38)	'laq)
      ((= posit 39)	'laqh)
      ((= posit 40)	'sib)
      ((= posit 41)	'lazh)
      ((= posit 42)	'lazq)
      ((= posit 43)	'lazqh)
      ((= posit 44)	'si)
      ((= posit 45)	'sih)
      ((= posit 46)	'siq)
      ((= posit 47)	'siqh)
      ((= posit 48)	'do)))
;
(define (freq2pitch1 frq . Rfrnz)
  (let* ((Rfrnz (if (not (null? Rfrnz)) (flatten Rfrnz))) (Pitref) (Sbdvref)
  	 (frqref) (ocvref) (refpos) (sbdvfac) (factor) (steps)
	 (posit) (octav) (pitsym) (frq (abs frq)))

    (if (and (pair? Rfrnz)		
    	     (or (number? (car Rfrnz))
	     	 (and (symbol? (car Rfrnz))
		      (number? (decodepitchclass (car Rfrnz)))))
	     (number? (cadr Rfrnz))
	     (number? (caddr Rfrnz)))
       (begin
	 (set! Pitref (list-head Rfrnz 3))
	 (set! Sbdvref (cadddr Rfrnz))
	 (if (not (number? Sbdvref)) (set! Sbdvref 48)))
       (set! Pitref foo:pitchreference)
       (if (and (not (null? Rfrnz))
       		(number? (car Rfrnz)))	(set! Sbdvref (car Rfrnz))
					(set! Sbdvref 48)))
    (set! frqref (caddr Pitref))
    (set! ocvref (cadr Pitref))
    (if (number? (car Pitref))
    	(set! refpos (car Pitref))
	(set! refpos (* (decodepitchclass (car Pitref)) (/ Sbdvref 48))))
    (set! sbdvfac (kw Sbdvref))

    (while (> frqref frq)
    	(set! frqref (/ frqref 2))
	(set! ocvref (- ocvref 1)))
    (while (< (* frqref 2) frq)
    	(set! frqref (* frqref 2))
	(set! ocvref (+ ocvref 1)))
    
    (set! factor (/ frq frqref))
    (set! steps  (/ (log factor) (log sbdvfac)))
    (set! posit  (round (+ refpos steps)))
    (set! octav  ocvref)

    (if (>= posit Sbdvref)
    	(begin
	   (set! posit (- posit Sbdvref))
	   (set! octav (+ octav 1))))

    (if (not (number? Pitref))
       (begin
	  (set! pitsym (decodepitnumb (round (* posit (/ 48 Sbdvref)))))
	  (string->symbol (format #f "~a~a" pitsym octav)))
       (list posit octav))))
;
(define (frq->pitch frq . Rfrnz)
   (cond
      ((number? frq)		(freq2pitch1 frq Rfrnz))
      ((and (pair? frq)
      	    (numerical? frq))	(map (lambda (x) (freq2pitch1 x Rfrnz)) frq))
      (#t			frq)))
;
(define pitchsymbol frq->pitch)
(define freq->pitch frq->pitch)