foo-cvs — mailing list for CVS commit messages.

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

[foo-cvs] foo/elkfoo/scm/tools Makefile.am,NONE,1.1 init-tools.foo,NONE,1.1 pitch.foo,NONE,1.1

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

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

Added Files:
	Makefile.am init-tools.foo pitch.foo 
Log Message:
initial checkin of scheme files, control, tools

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

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

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

NULL = 

SUBDIRS = mixsnd util

pkgtools_DATA = $(ELKFOO_TOOLS_FILES)

pkgtoolsdir = $(pkgdatadir)/tools

ELKFOO_TOOLS_FILES = \
	init-tools.foo \
	pitch.foo \
	$(NULL)

--- NEW FILE: init-tools.foo ---
;;; -*-Scheme-*-
;;;

;; init-tools.foo

(define (global-load file)
  (load file (global-environment)))

(autoload 'mixsnd "tools/mixsnd/mixsnd.foo")
(autoload 'pitch "tools/pitch.foo")
(autoload 'pitch->frq "tools/pitch.foo")
(autoload 'frq->pitch "tools/pitch.foo")

(global-load "tools/util/misc-funs.foo")
(global-load "tools/util/sound-funs.foo")

(provide 'foo-tools)

;; EOF

[foo-cvs] foo/elkfoo/scm/control/node Makefile.am,NONE,1.1 node-function-database.foo,NONE,1.1 node-functionalities.foo,NONE,1.1 node.foo,NONE,1.1

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

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

Added Files:
	Makefile.am node-function-database.foo 
	node-functionalities.foo node.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: node-functionalities.foo ---
(define (node? obj)
  (let ((name))
    (if (instance? obj)
	  (begin
		(set! name (class-name obj))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Node)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Node) #t #f)) #f)))

(define (node-class? obj)
  (let ((name))
    (if (class? obj)
	  (begin
		(set! name (class-name obj))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Node)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Node) #t #f)) #f)))

(define (make-node . args)
  (let ((nody))
    (if (and (not (null? args))
     	     (node-class? (car args)))
	(begin
	   (set! nody (make-an-instance (car args)))
	   (set! args (cdr args)))
	(set! nody (make-instance Node)))
    (if (not (null? args)) (apply send (append (list nody 'set-fields) args)))
     nody))

(define (compute-node obj . args)
   (if (node? obj) (apply send (append (list obj 'compute) args))
   		   (error 'compute-node "Not a Node : ~a"obj)))
(define (node . args)
   (compute-node (apply make-node args)))

(define (describe-node obj)
   (if (node? obj) (send obj 'get-Description)
		   (prn "This Object is not a Node")))

(define add-Node-Function
  (macro (name body . argms)
    (send (make-instance Node) 'set-Function-db name)
    (if (not (null? argms))
       (if (and (equal? 'lambda (car body))
       		(symbol? (cadr body)))
       `(define-method Node (,name . ARGUMENTS)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body ARGUMENTS))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux)))
       `(define-method Node (,name ,@argms)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body (list ,@argms)))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))

       `(define-method Node (,name . garbage)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list ,body)))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))))

(define add-Function
    (macro (Classname name body . argms)
	(if (not (eval `(node-class? ,Classname)))
	     (error 'add-Node-Function "Not a Node subclass (~s)" Classname))
	(send (eval `(make-an-instance ,Classname)) 'set-Function-db name)
     (if (not (null? argms))
       (if (and (equal? 'lambda (car body))
       		(symbol? (cadr body)))
       `(define-method ,Classname (,name . ARGUMENTS)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body ARGUMENTS))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux)))
       `(define-method ,Classname (,name ,@argms)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list (apply ,body (list ,@argms)))))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))

       `(define-method ,Classname (,name)
	   (let* ((aux) (Numb (send self 'get-NumResults)) (Args)
		  (End (+ Index Numb)))
	    (while (< Index End)
		(send self 'Increment-Index)
		(set! aux (append aux (list ,body)))
		(set! Result (append Result (last-pair aux))))
	    (if (= Numb 1) (car aux) aux))))))

--- NEW FILE: node.foo ---
(require 'oops)
(define-class Node (class-vars Function-db) (instance-vars Data
							   Args
							   Funx
							   Result
							   Partial-Result
							   (Index -1)
							   (NumResults 1)))

(define-method Node (reset)
    (set! Partial-Result '())
    (set! Result '())
    (set! Index -1))

(define-method Node (get-Function-db)
  (let ((aux) (name (eval (class-name self))))
     (for-each
      (lambda (x)
       (if (method-known? x name) (set! aux (cons x aux)))) Function-db)
    (reverse aux)))
(define-method Node (get-Data) Data)
(define-method Node (get-Args) Args)
(define-method Node (get-Funx) Funx)
(define-method Node (get-Result) Result)
(define-method Node (get-Partial-Result) Partial-Result)
(define-method Node (get-Index) Index)
(define-method Node (get-NumResults) NumResults)

(define-method Node (set-Data Lst)
  (send self 'set-Partial-Result '())
  (set! Data Lst))
(define-method Node (set-Args . Lst)
;  (send self 'set-Partial-Result '())
  (set! Args Lst))
(define-method Node (set-Funx Fun)
  (let ((fundb (send self 'get-Function-db)) (fun) (args) (aux))
     (send self 'set-Args)
     (send self 'set-Partial-Result '())
     (cond
     	((procedure? Fun)			(set! Funx Fun))
	((member Fun fundb)			(set! Funx Fun))
	((and (pair? Fun)
	      (or (member (car Fun) fundb)
	          (procedure? (car Fun))))	(set! Funx Fun))
	(#t
		(prn "WARNING Unable to set this Function : "Fun) #f))))
     			  
(define-method Node (set-Result Lst)         (set! Result Lst))
(define-method Node (set-Partial-Result Lst) (set! Partial-Result Lst))
(define-method Node (set-Index Val)          (set! Index Val))
(define-method Node (set-NumResults Val)
   (if (and (number? Val)
    	    (>= Val 1))
	(set! NumResults Val)
	(if (and (pair? Val)
		 (number? (car Val))
		 (>= (car Val) 1)) (set! NumResults (car Val))
				   (error 'Node "set-NumResults ~s" Val))))
(define-method Node (set-Function-db Lst)
  (let ((fundb (send self 'get-Function-db)))
    (set! Function-db
    	(if (member Lst fundb) fundb (append fundb (list Lst))))))


(define-method Node (Increment-Index)
    (send self 'set-Index (+ 1 (send self 'get-Index))))


(define-method Node (set-fields . args)
  (let ((flg #f) (aux))

    (set! aux (assq 'Funx args))
    (if aux (begin
    		(send self 'set-Funx (cadr aux))
		(set! flg #t)))
    (set! aux (assq 'Data args))
    (if aux (begin
    		(send self 'set-Data (cadr aux))
		(set! flg #t)))
    (set! aux (assq 'Args args))
    (if aux (begin
    		(apply send (append (list self 'set-Args) (cdr aux)))
		(set! flg #t)))
    (set! aux (assq 'NumResults args))
    (if aux (begin
    		(send self 'set-NumResults (cadr aux))
		(set! flg #t)))
    (if flg #t
     	     (if (not (null? args))
	     		 (apply send (append (list self 'set-Args) args)))
	     #t)))

(define-method Node (calculate body . args)
   (let* ((aux  (send self 'get-Result))
	  (Data (send self 'get-Data))
	  (Numb (send self 'get-NumResults))
	  (End  (+ (send self 'get-Index) Numb))
	  (indx) (aux1)
	  (args (if (not (null? args)) (car args) '())))

      (while (< (send self 'get-Index) End)
        (send self 'Increment-Index)
	(set! indx (send self 'get-Index))
	(set! aux1
	  (append aux1 (list
	    (cond
	     ((null? args)	   (apply body (list Data indx aux)))
	     ((= (length args) 1) (apply body (list (car args) Data indx aux)))
	     (#t		(apply body (list args Data indx aux)))))))

	(send self 'set-Result (append Result (last-pair aux1)))
	(if (= Numb 1) (set! aux1 (car (last-pair aux1))))
	(set! aux (send self 'get-Result)))
      aux1))

(define-method Node (node-next)
   (let ((fundb (send self 'get-Function-db))
   	 (meth (send self 'get-Funx))
   	 (args (send self 'get-Args))
	 (Numb (send self 'get-NumResults))
	 (Resl))

    (if (not (null? meth))
      (begin
       (set! Resl
    	(if (procedure? meth)
	    (if (not (null? args)) (send self 'calculate meth args)
		     (send self 'calculate meth))
	    (if (null? args) (send self meth)
	    		     (apply send (append (list self meth) args)))))
			     Resl))))

(define-method Node (compute . args)
   (if (not (null? args)) (apply send (append (list self 'set-fields) args)))
   (send self 'node-next))


(define-method Node (describe-Function Val)
   (newline)
   (if (method-known? Val (eval (class-name self)))
	(begin
	    (prn "**"Val"**")
	    (pp (eval Val)))
	(prn "! Unknown Function ! :"Val)))

(define-method Node (get-Description)
  (let ((Cname (class-name self)))
    (newline)
    (if (equal? Cname 'Node)
    		(prn " This is a Node Object. ")
		(prn " This is a Node Object of the Subclass :"Cname))
    (newline)
    (prn " Function  : "(send self 'get-Funx))
    (prn " Data      : "(send self 'get-Data))
    (prn " Arguments : "(send self 'get-Args))
    (newline)
    (prn " Number of Results :"(send self 'get-NumResults))
    (newline)
    (prn " :: Internal state :: ")
    (newline)
    (prn "      Index         :"(send self 'get-Index))
    (prn "      Result        :"(send self 'get-Result))
    (prn "      Parial-Result :"(send self 'get-Partial-Result))))

--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/node/Makefile.am
# 2004 rumori

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

NULL = 

pkgnode_DATA = $(ELKFOO_NODE_FILES)

pkgnodedir = $(pkgdatadir)/control/node

ELKFOO_NODE_FILES = \
	node-function-database.foo \
	node-functionalities.foo \
	node.foo \
	$(NULL)

--- NEW FILE: node-function-database.foo ---
;
;;
;;;	GENERAL FUNCTIONS
;;
;
(define (rand01) (/ (random) 2147483647))

(define (randint a z) (+ a (* (- z a) (rand01))))

(define (alea a z) (inexact->exact (round (randint a z))))

(define (mk-ordrlst lnz . start)
   (let* ((i (if (and (not (null? start))
   		      (number? (car start))) (car start) 0))
   	 (sign (if (>= lnz i) - +))
   	 (resl '()))
      (while (not (= lnz i))
	(set! resl (cons lnz resl)) (set! lnz (sign lnz 1)))
      (cons i resl)))

(define (make-ordrlst lnz . data)
  (let* ((i (if (and (not (null? data))
                     (number? (car data))) (car data) 0))
         (q (if (and (not (null? data))
                     (= (length data) 2)
                     (number? (cadr data))) (cadr data) 1))
         (sign (if (>= lnz i) - +))
         (conn (if (>= lnz i) <= >=))
         (resl '()))
    (while (not (conn lnz i))
           (set! resl (cons lnz resl))
           (set! lnz (sign lnz q)))
    (cons i resl)))

(define (eliminate el lst)
   (let ((rsl) (flg #t))
      (for-each
        (lambda (x)
	   (if (and flg
	   	   (equal? x el)) (set! flg #f)
		   		  (set! rsl (append rsl (list x))))) lst)
     rsl))

(define (eliminate-all el lst)
   (let ((rsl))
      (for-each
        (lambda (x)
	   (if (not (equal? x el)) (set! rsl (append rsl (list x))))) lst)
     rsl))

(define (Lstshuffle lst)
    (let* ((lnz (1- (length lst))) (resl) (el))
       (while (not (null? lst))
       	   (set! el (nth lst (alea 0 lnz)))
	   (set! lst (eliminate el lst))
	   (set! resl (cons el resl))
	   (set! lnz (1- lnz)))
       resl))

(define (Lstshuffle.old lst)
    (let ((aux) (lnz (length lst)) (resl) (el))
       (while (< (length resl) lnz)
       	   (set! aux (alea 0 (- lnz 1)))
	   (set! el (nth lst aux))
	   (while (member el resl)
		(set! aux (alea 0 (- lnz 1)))
		(set! el (nth lst aux)))
	   (set! resl (cons el resl)))
       resl))
;
;;
;;;	SELECTION FUNCTIONS
;;
;
(define (aleasel Lst) (let ((lnz (- (length Lst) 1))) (nth Lst (alea 0 lnz))))

(define (seriessel Lst Dum)
  (let ( (lnz (1- (length Lst))) (elm))
    (if (null? Dum)
	(set! Dum (Lstshuffle (mk-ordrlst lnz)))
        (if (= (length Dum) 1)
	   (begin (set! elm (car Dum))
	   	  (set! Dum (Lstshuffle (mk-ordrlst lnz)))
	   	  (while (and (> lnz 1) (= elm (car Dum)))
		  	(set! Dum (Lstshuffle (mk-ordrlst lnz))))
		  (set! Dum (cons elm Dum)))))
    (set! elm (car Dum))
    (list (nth Lst elm) (cdr Dum))))

(define (nextsel Lst indx) (let* ((lnz (length Lst))
			   	  (aux1 (if (>= indx lnz) (- lnz 1) indx)))
			      (list-ref Lst aux1)))

(define (circsel Lst indx) (let* ((lnz (length Lst))
			   	  (aux1 (modulo indx lnz)))
			      (list-ref Lst aux1)))

(define (mirrorsel Lst indx) (let* ((lnz (- (length Lst) 1))
				    (lenz2 (* 2 lnz))
			    	    (mod (modulo indx lenz2))
			    	    (aux1 (if (> mod lnz) (- lenz2 mod) mod)))
			      (list-ref Lst aux1)))

(define (intpsel Lst indx totn)
   (let* ((lnz (length Lst))
	  (aux1 (/ lnz totn)))
     (if (> indx totn) (set! indx totn))
     (if (>= lnz totn) (list-ref Lst indx)
		  (list-ref Lst (inexact->exact (truncate (* aux1 indx)))))))


(define (groupsel Lst Dum mini maxi)
  (let ((num) (val) (nval) (Lstaux) (Numaux1) (Numaux2) (flg #f))
    (if (null? Dum)
	(set! Numaux1 (map (lambda (x) (+ x mini))
	    				(mk-ordrlst (- maxi mini))))
	(set! val     (car Dum))
	(set! num     (cadr Dum))
	(set! Numaux1 (caddr Dum))
	(set! Numaux2 (cadddr Dum))
	(set! Lstaux  (car (cddddr Dum))))
    (if (not (null? num))
	(set! num (if (= num 2) '() (- num 1)))
	(set! num (seriessel Numaux1 Numaux2))
	(set! Numaux2 (cadr num))
	(set! num (car num))
	(if (= num 1) (set! num '()))
	(set! val (seriessel Lst Lstaux))
	(set! Lstaux (cadr val))
	(set! val (car val)))
	(list val num Numaux1 Numaux2 Lstaux)))

(define (alcircsel Lst indx)
   (let* ((lnz (length Lst))
          (aux1 (modulo indx lnz))
	  (aux2 (list-head Lst aux1))
	  (lnz2 (length aux2)))
      (if (= 0 lnz2) '()
		      (list-ref aux2 (alea 0 (1- lnz2))))))

;
;;
;;;	INTERPOLATION FUNCTIONS
;;
;


(define (linint xi xa ya xz yz)
    (cond
       ((= xi xa)	ya)
       ((= xi xz)	yz)
       (#t		(+ ya (* (- yz ya) (/ (- xi xa) (- xz xa)))))))

(define (expint xi xa ya xz yz pnd)
    (cond
       ((= xi xa)	ya)
       ((= xi xz)	yz)
       (#t		(expon (/ (- xi xa) (- xz xa)) ya yz pnd))))

(define (lstlinint xi xa lsta xz lstz)
   (map (lambda (ya yz) (linint xi xa ya xz yz)) lsta lstz))

(define (lstexpint xi xa lsta xz lstz pnd)
   (map (lambda (ya yz) (expint xi xa ya xz yz pnd)) lsta lstz))

(define (stepfun xi xa ya xz yz) (if (>= xi xz) yz ya))

(define (stadint xi xa ya xz yz)
   (let ((x) (y) 
         (x1 (+ (/ (- xz xa) 3) xa))
         (x2 (+ (* 2 (/ (- xz xa) 3)) xa))
	 (lsta (append (make-list 5 ya) (make-list 5 yz))))
      (set! x (if (< xi x2) 0 (/ (* 9 (- xi x2)) (- xz x2))))
      (set! y (if (< xi x1) (/ (* 9 (- xi xa)) (- x1 xa)) 9))
      (nth lsta (alea x y))))

(define (lststadint xi xa lsta xz lstz)
    (map (lambda (ya yz) (stadint xi xa ya xz yz)) lsta lstz))

(define (filtre Lst Min Max)
 (let ((rsl '()))
  (for-each (lambda (x) (if (and (>= x Min)
  				 (<= x Max)) (set! rsl (cons x rsl)))) Lst)
  (reverse rsl)))

;
;;
;;;	IMPLEMENTATION AS NODE FUNCTIONS
;;
;

(add-Node-Function ALEA	(aleasel Data))
(add-Node-Function ALCIRC (alcircsel Data Index))
(add-Node-Function CIRC	(circsel Data Index))
(add-Node-Function EXPINT
    (lambda (x)
	(expint x (car Data) (cadr Data) (caddr Data) (cadddr Data)
					 (car (cddddr Data))))
    Xi)
(add-Node-Function GIVEDATA (identity Data))
(add-Node-Function GROUP
    (lambda (x y)
	(let ((aux1 (groupsel Data Partial-Result x y)))
	    (set! Partial-Result aux1) (car aux1)))
    Minimum-RepetitionRange Maximum-RepetitionRange)
(add-Node-Function INTPSEL
    (lambda (x)
    	(intpsel Data Index x)) Number-Results)
(add-Node-Function INTSERIES
    (lambda X
	(let ((X1 (car X)) (X2 (cadr X)))
	    (if (not (null? X2)) (mk-ordrlst X1 X2)
	 	   (mk-ordrlst X1))))
    Values)
(add-Node-Function LININT
    (lambda (x)
	(linint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function LSTEXPINT
    (lambda (x)
	(lstexpint x (car Data) (cadr Data) (caddr Data) (cadddr Data)
	    					(car (cddddr Data))))
    Xi)
(add-Node-Function LSTLININT
    (lambda (x)
	(lstlinint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function LSTSTADINT
    (lambda (x)
	(lststadint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function MIRROR (mirrorsel Data Index))
(add-Node-Function NEXT	(nextsel Data Index))
(add-Node-Function SERIES
    (let ((aux1 (seriessel Data Partial-Result)))
	(set! Partial-Result (cadr aux1)) (car aux1)))
(add-Node-Function SHUFFLE (Lstshuffle Data))
(add-Node-Function STADINT
    (lambda (x)
	(stadint x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)
(add-Node-Function STEP
    (lambda (x)
	(stepfun x (car Data) (cadr Data) (caddr Data) (cadddr Data)))
    Xi)

[foo-cvs] foo/elkfoo/scm/control/processes Makefile.am,NONE,1.1 process.foo,NONE,1.1 scheduler.foo,NONE,1.1

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

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

Added Files:
	Makefile.am process.foo scheduler.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: process.foo ---
(require 'oops 'oops.scm)

;;;
;;; abstract class Process
;;;

(define-class Process)

;;;
;;; subclasses of Process must override run
;;; run has to return either a non-negative number
;;; indicating the delay after which it will be
;;; called again by the scheduler, or #t to be deactivated,
;;; or #f to be removed from the scheduler
;;;

(define-method Process (run scheduler)
    (error 'run "subclass responsability"))

;;;
;;; the following two methods are envoked by the scheduler
;;; when the priority or the time of the process was changed
;;; at the moment these methods only print what happened (and
;;; show how one gets to the information of what happened)
;;;

(define-method Process (priorityChanged scheduler)
    (format #t "priority changed to ~a for process id ~a~%"
	(send scheduler 'priorityOfProcess self)
	(send scheduler 'idOfProcess self)))

(define-method Process (timeChanged scheduler)
    (format #t "time changed to ~a for process id ~a~%"
	(send scheduler 'timeOfProcess self)
	(send scheduler 'idOfProcess self)))

--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/processes/Makefile.am
# 2004 rumori

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

NULL = 

pkgprocesses_DATA = $(ELKFOO_PROCESSES_FILES)

pkgprocessesdir = $(pkgdatadir)/control/processes

ELKFOO_PROCESSES_FILES = \
	process.foo \
	scheduler.foo \
	$(NULL)

--- NEW FILE: scheduler.foo ---
(require 'oops 'oops.scm)
(require 'struct 'struct.scm)

;;;
;;; structure thread
;;;

(define-structure thread identifier process priority)

;;;
;;; class Scheduler
;;;

(define-class Scheduler
    (instance-vars
	(time 0)
	(lastId 0)
	(processes (list 'head))
	(waiting (list 'head))
	(queue (list 'head))))

;;;
;;; public methods:
;;;
;;; activateProcess <aProcess>			=> #t | #f
;;; addProcess <aProcess> <aPriority> <aDelay>	=> process id | #f
;;; getTime					=> time
;;; idOfProcess <aProcess>			=> process id | #f
;;; priorityOfProcess <aProcess>		=> process priority | #f
;;; processActive? <aProcess>			=> #t | #f
;;; processOfId <aNumber>			=> process | #f
;;; removeProcess <aProcess>			=> #t | #f
;;; runUntil {<end> | #f}			=> time
;;; setProcessPriority <aProcess> <aPriority>	=> #t | #f
;;; setProcessTime <aProcess> <aTime>		=> #t | #f
;;; setTime <aTime>				=> old time
;;; step					=> time | #f
;;; timeOfProcess <aProcess>			=> process time | #f
;;;

(define-method Scheduler (getTime)
    time)

(define-method Scheduler (setTime aTime)
    (set! time aTime))

(define-method Scheduler (addProcess aProcess aPriority aDelay)
    (if (number? (send self 'idOfProcess aProcess))
	#f
	(set! lastId (1+ lastId))
	(let ((thread (make-thread lastId aProcess aPriority)))
	    (set! processes (append! processes (list thread)))
	    (send self 'enqueue thread (+ aDelay time))
	    lastId)))

(define-method Scheduler (removeProcess aProcess)
    (let ((thread (send self 'remove thread-process aProcess processes)))
	(if (not thread)
	    #f
	    (send self 'dequeue thread)
	    #t)))

(define-method Scheduler (setProcessPriority aProcess aPriority)
    (let ((thread (send self 'find thread-process aProcess processes))
	  (theTime 0))
	(if (not thread)
	    #f
	    (set! theTime (send self 'dequeue thread))
	    (if (not theTime)
		#f
		(set-thread-priority! thread aPriority)
		(send self 'enqueue thread theTime)
		(send (thread-process thread) 'priorityChanged self)
		#t))))

(define-method Scheduler (setProcessTime aProcess aTime)
    (let ((thread (send self 'find thread-process aProcess processes)))
	(if (not thread)
	    #f
	    (send self 'dequeue thread)
	    (send self 'enqueue thread aTime)
	    (send (thread-process thread) 'timeChanged self)
	    #t)))

(define-method Scheduler (priorityOfProcess aProcess)
    (send self 'finder thread-process thread-priority aProcess))

(define-method Scheduler (timeOfProcess aProcess)
    (let* ((keyFunc (lambda (x) (thread-process (cdr x))))
	   (result (send self 'find keyFunc aProcess queue)))
	(if (not result)
	    #f
	    (car result))))

(define-method Scheduler (idOfProcess aProcess)
    (send self 'finder thread-process thread-identifier aProcess))

(define-method Scheduler (processOfId anId)
    (send self 'finder thread-identifier thread-process anId))

(define-method Scheduler (processActive? aProcess)
    (and (send self 'idOfProcess aProcess)
	 (not (send self 'find thread-process aProcess waiting))))

(define-method Scheduler (activateProcess aProcess aDelay)
    (let ((thread (send self 'find thread-process aProcess waiting)))
	(if (not thread)
	    #f
	    (send self 'activate thread aDelay))))

(define-method Scheduler (step)
    (if (null? (cdr queue))
	#f
	(let* ((thread (cdadr queue)) (telay 0)
	       (process (thread-process thread)))
	    (set! time (caadr queue))
	    (set-cdr! queue (cddr queue))
	    (set! telay (send process 'run self))
	    (if (number? telay)
		(send self 'enqueue thread (+ time telay))
		(if (not telay)
		    (send self 'removeProcess process)
		    (send self 'deactivate thread)))
	    time)))

(define-method Scheduler (runUntil end)
    (if (number? end)
	(while (and (not (null? (cdr queue))) (<= (caadr queue) end))
	    (send self 'step))
	(while (send self 'step) '()))
    time)

;;;
;;; private methods
;;;

(define-method Scheduler (finder keyFunc valueFunc anObject)
    (let ((result (send self 'find keyFunc anObject processes)))
	(if (not result)
	    #f
	    (valueFunc result))))

(define-method Scheduler (find keyFunc anObject source)
    (define (loop x)
	(if (null? x)
	    #f
	    (if (eq? (keyFunc (car x)) anObject)
		(car x)
		(loop (cdr x)))))
    (loop (cdr source)))

(define-method Scheduler (remove keyFunc anObject source)
    (define (loop x)
	(if (null? (cdr x))
	    #f
	    (if (eq? (keyFunc (cadr x)) anObject)
		(begin1
		    (cadr x)
		    (set-cdr! x (cddr x)))
		(loop (cdr x)))))
    (loop source))
		
(define-method Scheduler (enqueue thread time)
    (let ((priority (thread-priority thread))
          (id (thread-identifier thread)))
	(define (insert x)
	    (if (null? (cdr x))
		(set! queue (append! queue (list (cons time thread))))
		(if (or (< (caadr x) time)
			(or (and (= (caadr x) time)
				 (> (thread-priority (cdadr x)) priority))
			    (and (= (caadr x) time)
				 (= (thread-priority (cdadr x)) priority)
				 (< (thread-identifier (cdadr x)) id))))
		    (insert (cdr x))
		    (set-cdr! x
			(append! (list (cons time thread)) (cdr x))))))
	(insert queue)))

(define-method Scheduler (dequeue thread)
    (let ((result (send self 'remove cdr thread queue)))
	(if result
	    (car result)
	    result)))

(define-method Scheduler (deactivate thread)
    (set! waiting (append! waiting (list thread))))

(define-method Scheduler (activate thread telay)
    (define (remove x)
	(if (null? (cdr x))
	    #f
	    (if (eq? (cadr x) thread)
		(begin1
		    (cadr x)
		    (set-cdr! x (cddr x)))
		(remove (cdr x)))))
    (let ((thread (remove waiting)))
	(if (not thread)
	    #f
	    (send self 'enqueue thread (+ time telay))
	    #t)))

[foo-cvs] foo/elkfoo/scm/control/abstraction Makefile.am,NONE,1.1 abstr-functlity.foo,NONE,1.1 abstraction.foo,NONE,1.1 comp-type.foo,NONE,1.1 funx-type.foo,NONE,1.1 hier-type.foo,NONE,1.1 var-type.foo,NONE,1.1

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

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

Added Files:
	Makefile.am abstr-functlity.foo abstraction.foo comp-type.foo 
	funx-type.foo hier-type.foo var-type.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: hier-type.foo ---
(define-class Hier-Type (instance-vars Descriptor
				       Init-Hier
				       Main-Hier
				       Coda-Hier))

(define-method Hier-Type (checkData)
   (let ((flg #t))
	(if (null? Descriptor)
	   (if (and (null? Init-Hier)
		    (null? Main-Hier)
		    (null? Coda-Hier))
		#t
		(if (not (send self 
		        'set-Descriptor (list (list 'Init-Hier Init-Hier)
					      (list 'Main-Hier Main-Hier)
					      (list 'Coda-Hier Coda-Hier))))
			(set! flg #f)))
	   (if (not (send self 'set-Descriptor Descriptor)) (set! flg #f)))
	(if (not flg) (prn "Error Hierarchy "Descriptor))
	flg))

(define-method Hier-Type (set-Descriptor Lst)
  (let ((SymLst (list 'Init-Hier 'Main-Hier 'Coda-Hier)) 
   	(aux) (flg #t))

    (if (not (null? Lst))
       (if (and  (not (pair? Lst))
		 (not (symbol? Lst)))
       	   (set! flg #f)

   	   (set! aux (first-symbol Lst))
           (if (not (member aux SymLst))
		(set! Lst (list (list 'Init-Hier Lst) (list 'Main-Hier Lst)
				                      (list 'Coda-Hier Lst)))
		(if (symbol? (car Lst)) (set! Lst (list Lst))))
   	   (for-each
   	     (lambda (x)
               (set! aux 
	         (cond
	           ((equal? (car x) 'Init-Hier)  
				 (send self 'set-Init-Hier (clean (cdr x))))
	           ((equal? (car x) 'Main-Hier)
				 (send self 'set-Main-Hier (clean (cdr x))))
	           ((equal? (car x) 'Coda-Hier)
				 (send self 'set-Coda-Hier (clean (cdr x))))))
               (if (not aux) (set! flg #f))) Lst)
   	   (if flg (set! Descriptor (list (list 'Init-Hier Init-Hier)
				    (list 'Main-Hier Main-Hier)
				    (list 'Coda-Hier Coda-Hier))))))
    flg))


(define-method Hier-Type (set-Init-Hier Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Init-Hier Lst)
	       (set! Descriptor '())
	       #t)
    	(prn "Error Hier-Type Init-Hier "Init-Hier)
	(set! Init-Hier '())
	#f))

(define-method Hier-Type (set-Main-Hier Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Main-Hier Lst)
	       (set! Descriptor '())
	       #t)
    	(prn "Error Hier-Type Main-Hier "Main-Hier)
	(set! Main-Hier '())
	#f))


(define-method Hier-Type (set-Coda-Hier Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Coda-Hier Lst)
	       (set! Descriptor '())
	       #t)
    	(prn "Error Hier-Type Coda-Hier "Coda-Hier)
	(set! Coda-Hier '())
	#f))

(define-method Hier-Type (check Lst)
   (if (not (list? Lst))
   	(if (not (symbol? Lst)) #f
				Lst)
			 (set! Lst (cleanlist Lst))
			 (if (or (null? Lst)
				 (symbolic? Lst)) Lst #f)))

(define-method Hier-Type (get-Descriptor)
   (if (null?  Descriptor) (list (list 'Init-Hier Init-Hier)
	    			 (list 'Main-Hier Main-Hier)
				 (list 'Coda-Hier Coda-Hier))
   			   Descriptor))

(define-method Hier-Type (get-Init-Hier)  Init-Hier)
(define-method Hier-Type (get-Main-Hier)  Main-Hier)
(define-method Hier-Type (get-Coda-Hier)  Coda-Hier)


--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/abstraction/Makefile.am
# 2004 rumori

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

NULL = 

pkgabstraction_DATA = $(ELKFOO_ABSTRACTION_FILES)

pkgabstractiondir = $(pkgdatadir)/control/abstraction

ELKFOO_ABSTRACTION_FILES = \
	abstr-functlity.foo \
	abstraction.foo \
	comp-type.foo \
	funx-type.foo \
	hier-type.foo \
	var-type.foo \
	$(NULL)

--- NEW FILE: comp-type.foo ---
(define-class Comp-Type (instance-vars Types
				       Variables
				       Comp-List
				       NumbOfElems
				       TotalNumbOfElems
				       (checkd #f)))

(define-method Comp-Type (checkData)
   (let ((flg #t))
	(if (not (null? Types))
	    (if (and (send self 'check-Types)
		     (send self 'check-NumbOfElems)) (send self 'adjust)
		     				     (set! flg #f)))
	(set! checkd #t)
	flg))

(define-method Comp-Type (check-Types)
  (let ((aux #t))
	(if (not (pair? Types)) (set! Types (list Types)))
	(set! Types (flatout Types))
	(for-each
	   (lambda (x)
	       (if (not (send self 'checkelType x)) (set! aux #f))) Types)
	aux))

(define-method Comp-Type (checkelType el)
   (let ((aux #t))
	(cond
	    ((symbol? el)	(if (or (not (bound? el))
	    				(abstraction? (eval el))
					(abstraction-mold? (eval el))) #t #f))
	    ((abstraction? el)		#t)
	    ((abstraction-mold? el)	#t)
	    ((pair?  el)	(for-each 
	    			  (lambda (x)
				    (if (not (send self 'checkelType x))
				    	   (set! aux #f))) 
				           el) aux)
	    (#t			#f))))

(define-method Comp-Type (check-NumbOfElems)
  (let ((aux #t) (flg #f) (aux1))
    (cond
      ((and (null? NumbOfElems)
	    (null? TotalNumbOfElems)) 

		(set! NumbOfElems
			(map (lambda (x) (send self 'count x)) Types))
		(set! TotalNumbOfElems 0)
		(for-each
		   (lambda (x) (set! TotalNumbOfElems  (+ TotalNumbOfElems x)))
					     			NumbOfElems)
		NumbOfElems)

      ((null? NumbOfElems)

		(set! aux1 (length Types))
		(set! NumbOfElems
    		    (map (lambda (x)
		    	    (max 0 (truncate (/ TotalNumbOfElems aux1)))) Types))
		NumbOfElems)

      (#t
    		(if (not (pair? NumbOfElems))
		    (set! NumbOfElems (list NumbOfElems))
		    (set!  NumbOfElems (flatout NumbOfElems)))
		(if (= (length NumbOfElems)
	               (length Types))
	 	  (for-each 
		    (lambda (x y)
		      (if (not (send self 'checkNumbel x y)) (set! aux #f)))
							  NumbOfElems Types)
	 	  (set! aux #f))
	  	(if aux
		    (begin
			(set! TotalNumbOfElems 0)
			(for-each
			   (lambda (x)
			      (if (number? x)
			      	(set! TotalNumbOfElems (+ TotalNumbOfElems x))
				(set! flg #t))) NumbOfElems)
		    NumbOfElems)
		    #f)))))


    
(define-method Comp-Type (checkNumbel el ti)
  (let ((aux #t))
	(cond
	    ((and (pair? el)
	    	  (pair? ti)) (if (= (length el)
					(length ti))
				(for-each
				    (lambda (x y)
					(if (not (send self 'checkNumbel x y))
					    (set! aux #f))) el ti) 
				aux 
				#f))
	    ((symbol? el)     #t)
	    ((number? el)     #t)
	    (#t		      #f))))


(define-method Comp-Type (count el)
     (if (pair? el) (map (lambda (x) (send self 'count x)) el)
     		    1))

(define-method Comp-Type (adjust)
  (set! Types
	    (map (lambda (x) (send self 'get-TypeSymbs x)) (flatten Types)))
  (set! Variables
	    (map (lambda (x) (send self 'get-VarNames x)) Types))
  (set! Comp-List
	(map (lambda (x y) (send self 'make-Component x y)) Types NumbOfElems))
  Types)

(define-method Comp-Type (get-TypeSymbs el)
    (cond
	((pair? el)		(map (lambda (x)
					    (send self 'get-TypeSymbs x)) el))
	((symbol? el)		el)
	((abstraction? el)	el)
	((abstraction-mold? el)	(vector-ref el 1))))

(define-method Comp-Type (get-VarNames el)
    (cond
	((pair? el)		(map (lambda (x)
					    (send self 'get-VarNames x)) el))
	((symbol? el)		(if (not (bound? el)) '() 
					 (send self 'get-VarNames (eval el))))
	((abstraction? el)	(send el 'get-Varnames))
	((abstraction-mold? el)	(send (make-abstraction el) 'get-Varnames))))

(define-method Comp-Type (get-Types . pos)
    (if (not checkd) (send self 'checkData))
    (if (null? pos) Types
		    (if (< pos (length Types))
		    		 (nth Types pos)
				 (error 'Abstraction "Components ~a" pos))))

(define-method Comp-Type (get-Components . pos)
    (if (not checkd) (send self 'checkData))
    (set! pos (if (not (null? pos)) (car pos) '()))
    (cond
	((null? pos)			Comp-List)
	((and (symbol? pos)
	    (equal? pos 'flat))		(flatten Comp-List))
	((number? pos)			(nth (flatten Comp-List) pos))
	((member? pos Types)  		(send self 'Extract pos))
	((and (pair? pos)
	    (member? (car pos) Type)
	    (number? (cadr pos)))   (send self 'Extract (car pos) (cadr pos)))
	(#t			    (error 'Abstraction "Components ~a" pos))))

(define-method Comp-Type (get-NumbOfElems)
    (if (not checkd) (send self 'checkData))
    NumbOfElems)

(define-method Comp-Type (get-TotalNumbOfElems) 
    (if (not checkd) (send self 'checkData))
    TotalNumbOfElems)

(define-method Comp-Type (get-Variables)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x y) (list x y)) Types Variables))


(define-method Comp-Type (get-VariablesValues . Tip)
    (if (not checkd) (send self 'checkData))
    (if (not (null? Tip)) (set! Tip (car Tip)))
    (map
	(lambda (x y)
	    (if (or (null? Tip)
		    (equal? x Tip))
	       (begin
		 (if (not (pair? y)) (set! y (list y)))
		 (cons x (map (lambda (z) (send z 'get-Variables)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define-method Comp-Type (get-VariablesList . Tip)
  (if (not checkd) (send self 'checkData))
  (if (not (null? Tip)) (set! Tip (car Tip)))
  (map
   (lambda (x y)
     (if (or (null? Tip)
	     (equal? x Tip))
	(begin
	   (if (not (pair? y)) (set! y (list y)))
	   (cons x (map (lambda (z) (send z 'get-Variables 'List)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define-method Comp-Type (get-VariablesDefaults . Tip)
  (if (not checkd) (send self 'checkData))
  (if (not (null? Tip)) (set! Tip (car Tip)))
  (map
   (lambda (x y)
     (if (or (null? Tip)
	     (equal? x Tip))
	(begin
	   (if (not (pair? y)) (set! y (list y)))
	   (cons x (map (lambda (z) (send z 'get-Variables 'Defaults)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define-method Comp-Type (get-Values . Tip)
    (if (not checkd) (send self 'checkData))
    (if (not (null? Tip)) (set! Tip (car Tip)))
    (map
     (lambda (x y)
       (if (or (null? Tip)
	       (equal? x Tip))
	(begin
	   (if (not (pair? y)) (set! y (list y)))
	(cons x (map (lambda (z) (send z 'get-Variables 'Current)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define (filtsymbs Lst)
   (map (lambda (x) (if (symbol? (car x)) (cadr x)
   			(map (lambda (y) (cadr y)) x))) (clean Lst)))

(define-method Comp-Type (get-Description)
    (newline)
    (prn " Total Number of Components :"TotalNumbOfElems)
    (prn " Number of different Types of Components :"(length Types))
    (for-each
       (lambda (x y z w)
       		(newline)
       		(prn "    Type "x)
		(prn "    Variables "z)
		(prn "    Number of Elements : "y)
		(prn "    Values : "(if (pair? w)
					(map (lambda (v)
						(send v 'get-Variables)) w)
					(if (abstraction? w)
					(send w 'get-Variables)))))
       Types NumbOfElems Variables Comp-List)
    (newline))

(define-method Comp-Type (make-Component tip numb)
    (let ((aux) (i numb))
	(while (> i 0)
	    (set! aux
	      (cons
		(cond
		    ((symbol? tip)   (if (not (bound? tip)) '()
		    		       (if (or (abstraction? (eval tip))
					       (abstraction-mold? (eval tip)))
					   (make-abstraction (eval tip)))))
		    ((abstraction-mold? tip)  (make-abstraction tip))
		    ((abstraction? tip)       (make-abstraction tip)))
		 aux))
	    (set! i (- i 1)))
	(if (= numb 1) (set! aux (car aux)))
	aux))

(define-method Comp-Type (set-Types Lst)
    (set! NumbOfElems '())
    (if (not (null? (clean Lst)))
       (begin
   	 (if (not (pair? Lst)) (set! Lst (list Lst)))
    	 (set! Types (clean Lst))
   	 (if (and (send self 'check-Types)
	          (send self 'check-NumbOfElems))
	 	(send self 'adjust)
		(error 'Components "check Types or NumbOfElems"))) #t))

(define-method Comp-Type (adjust-Type Code Elem) 
    (if (not checkd) (send self 'checkData))
    (if (or (null? Types)
    	    (not (symbol? Code)))
	(prn "Unable to adjust Component Type " Code)
	(if (not (send self 'checkelType Elem))
	    (prn "Unable to adjust Component Type " Elem)
	    (set! Types (map (lambda (x) (if (equal? Code x) Elem x)) Types))
	    (if (and (send self 'check-Types)
		     (send self 'check-NumbOfElems))
			(send self 'adjust)
			(error 'Components "check Types or NumbOfElems")))))

(define-method Comp-Type (add-Type Type . Numb)
    (if (not checkd) (send self 'checkData))
    (set! Numb (if (not (null? Numb))  (car Numb) 1))
    (if (not (number? Numb))
    	(prn "Unable to add Component Type "Numb)
    	(set! Types (append Types (list Type)))
    	(set! NumbOfElems (append NumbOfElems (list Numb)))
	(if (and (send self 'check-Types)
		 (send self 'check-NumbOfElems))
			(send self 'adjust)
			(error 'Components "check Types or NumbOfElems"))))
 
 (define-method Comp-Type (Extract-Component Tip . rfrnz)
  (let ((aux) (j -1) (resl))
    (set! rfrnz (cleanlist rfrnz))
    (for-each
	(lambda (x y) (if (equal? Tip x) (set! aux y))) Types Comp-List)
    (if (or (null? rfrnz)
    	    (not (pair? aux)))
	    aux
	    (for-each (lambda (x) (set! j (+ 1 j))
				 (if (= j (car rfrnz)) (set! resl x))) aux)
	    resl)))

(define-method Comp-Type (set-NumbOfElems Lst)
  (let ((aux1 (send self 'get-NumbOfElems))
  	(aux2 (send self 'get-TotalNumbOfElems)))
    (if (null? Lst) '()
	(set! TotalNumbOfElems '())
	(set! NumbOfElems Lst)
	(if (send self 'check-NumbOfElems)
	    (begin
	    	(send self 'adjust)
		(send self 'get-NumbOfElems))
	    (set! TotalNumbOfElems aux2)
	    (set! NumbOfElems aux1)
	    #f))))

(define-method Comp-Type (adjust-NumberofElement Tip Numb)
   (set! NumbOfElems 
   	(map (lambda (x y) (if (equal? x Tip) Numb y)) Types NumbOfElems))
   (send self 'check-NumbOfElems)
   (send self 'adjust))

(define-method Comp-Type (set-TotalNumbOfElems Num)
  (let ((aux1 (send self 'get-NumbOfElems))
  	(aux2 (send self 'get-TotalNumbOfElems)))
    (if (null? Num) '()
	(set! TotalNumbOfElems Num)
	(set! NumbOfElems '())
	(if (send self 'check-NumbOfElems)
	    (begin 
	    	(send self 'adjust)
		(send self 'get-NumbOfElems))
	    (set! TotalNumbOfElems aux2)
	    (set! NumbOfElems aux1)
	    #f))))

--- NEW FILE: abstr-functlity.foo ---
;
;;
;;;	Object Functionalities
;;
;


(define (make-an-instance2 Class . args)
  (check-class 'make-instance (eval Class))
  (let* ((e (the-environment))
	 (i (make-vector instance-size #f))
	 (class-env (class-env (eval Class)))
	 (instance-vars (class-instance-vars (eval Class))))
	(set-tag! i 'instance)
	(set-class-name! i Class)
	(set-instance-env! i
			    (eval `(let* ,instance-vars
				    (the-environment))
				    class-env))
	(eval `(set! self ',i) (instance-env i))
	(init-instance args (eval Class) i e)
	i))

(define (make-an-instance Class . args)
  (check-class 'make-instance Class)
  (let* ((e (the-environment))
	 (i (make-vector instance-size #f))
	 (class-env (class-env Class))
	 (instance-vars (class-instance-vars Class)))
	(set-tag! i 'instance)
	(set-class-name! i (vector-ref Class 1))
	(set-instance-env! i
			    (eval `(let* ,instance-vars
				    (the-environment))
				    class-env))
	(eval `(set! self ',i) (instance-env i))
	(init-instance args Class i e)
	i))

(define (make-a-class name . args)
  (let ((class-vars)
        (instance-vars (list (make-binding 'self)))
        (super)
        (super-class-env))
    (do ((a args (cdr a)))
        ((null? a))
        (cond ((not (pair? (car a)))
               (error 'define-class
                      "bad argument: ~s"
                      (car a)))
              ((eq? (caar a) 'class-vars)
               (check-vars (cdar a))
               (set! class-vars (cdar a)))
              ((eq? (caar a) 'instance-vars)
               (check-vars (cdar a))
               (set! instance-vars
                     (append instance-vars
                             (map make-binding
                                  (cdar a)))))
              ((eq? (caar a) 'super-class)
               (if (> (length (cdar a)) 1)
                   (error 'define-class
                          "only one super-class allowed"))
               (set! super (cadar a)))
              (else (error 'define-class
                           "bad keyword: ~s"
                           (caar a)))))
    (if (not (null? super))
        (let ((class (eval super)))
          (set! super-class-env (class-env class))
          (set! instance-vars
                (join-vars (class-instance-vars class)
                           instance-vars)))
        (set! super-class-env (the-environment)))
       (let ((c (make-vector class-size '())))
         (set-tag! c 'class)
         (set-class-name! c name)
         (set-class-instance-vars! c instance-vars)
         (set-class-env! c
                         (eval `(let* ,(map make-binding  class-vars)
                                       (the-environment))
                                        super-class-env))
         (set-class-super! c super)
         c)))

;
;;
;;;	Abstraction Functionalities
;;
;

(define (abstraction? f)
 (let ((name))
    (if (instance? f)
	  (begin
		(set! name (class-name f))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Abstraction)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Abstraction) #t #f)) #f)))

(define (abstraction-mold? f)
   (let ((name))
	(if (class? f)
	  (begin
		(set! name (class-name f))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Abstraction)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Abstraction) #t #f)) #f)))

(define HackdumVars)
(define HackdumFunx)
(define HackdumLocs)
(define HackdumHier)
(define HackdumNComps)
(define HackdumComps)

(define define-abstr-mold
  (macro (name . argms)
  `(define ,name (make-abstr-mold ',name ,@argms))))

(define (make-abstr-mold name . args)
  (let ((sup) (supPars) (Pars) (flg #t) (aux) (super 'Abstraction) (dum)
        (NLst (list 'Variables 'Locals 'NumbComponents 'Components
					     'Algorithm 'Hierarchy))
        (CLst (list 'Vars 'Locs 'NComps 'Comps 'Funx 'Hier)))

  (if (not (symbol? name))
   (begin
       (prn "The first argument should be a symbol :: The name of the mold")
       (prn "You should bind it to the same symbol-name. This is not a macro"))
   (if (not (null? args))
     (begin
       (for-each 
         (lambda (x) 
	   (cond
	      ((and (instance? x)
		    (abstraction? x))	     (set! sup x))
	      ((and (class? x)
		    (abstraction-mold? x))	     (set! sup x))
	      ((and (symbol? x)
		    (bound? x)
		    (instance? (eval x))
		    (abstraction? (eval x))) (set! sup (eval x)))
	      ((and (symbol? x)
		    (bound? x)
		    (class? (eval x))
		    (abstraction-mold? (eval x))) (set! sup (eval x)))
	      ((and (pair? x)
		    (symbol? (car x))
		    (member (car x) NLst))   (set! Pars (cons x Pars)))
	      (#t			     (set! flg #f)))) args)
       (if (not (null? sup))
       	  (begin
	   (set! super (class-name sup))
       	   (if (class? sup)
	   	(set! supPars (send (make-an-instance sup) 'getclassvars))
		(set! supPars (list 
			(cons 'Variables (send sup 'get-Variables 'List))
			(cons 'Locals (send sup 'get-Locals 'List))
			(cons 'Components (send sup 'get-Components 'Types))
		      (cons 'NumbComponents (send sup 'get-Components 'Number))
			(cons 'Algorithm (send sup 'get-Algorithm))
			(cons 'Hierarchy (send sup 'get-Hierarchy)))))))

       (for-each
         (lambda (x y)
	    (set! dum (assq x Pars))
	    (if (not dum) (set! dum (assq x supPars)))
	    (if dum
		(cond
		    ((equal? y 'Vars)  (set! HackdumVars (cdr dum))
				       (set! aux
				       	 (cons (list y (quote HackdumVars))
						aux)))
		    ((equal? y 'Locs)  (set! HackdumLocs (cdr dum))
				       (set! aux 
				         (cons (list y (quote HackdumLocs))
						aux)))
		    ((equal? y 'Comps) (set! HackdumComps (cdr dum))
				       (set! aux
				         (cons (list y (quote HackdumComps))
						aux)))
		   ((equal? y 'NComps) (set! HackdumNComps (cdr dum))
				       (set! aux
				         (cons (list y (quote HackdumNComps))
						aux)))
		    ((equal? y 'Funx)  (set! HackdumFunx (cdr dum))
				       (set! aux 
				         (cons (list y (quote HackdumFunx))
						aux)))
		    ((equal? y 'Hier)  (set! HackdumHier (cdr dum))
				       (set! aux 
				         (cons (list y (quote HackdumHier))
						aux)))))) NLst CLst)
	(make-a-class name `(super-class ,super) (cons 'class-vars aux)))
     (make-a-class name '(super-class Abstraction))))))


(define (make-abstraction . args)
  (let ((sup) (supPars) (Pars) (flg #t) (aux) (name 'Abstraction) (dum) (obj)
  	(NLst (list 'Variables 'Locals 'NumComponents 'Components
					    'Algorithm 'Hierarchy))
        (CLst (list 'Vars 'Locs 'NComps 'Comps 'Funx 'Hier)))

   (if (not (null? args))
     (begin
       (for-each 
         (lambda (x)
	   (cond
	      ((and (instance? x)
		    (abstraction? x))	     (set! sup x))
	      ((and (class? x)
		    (abstraction-mold? x))	     (set! sup x))
	      ((and (symbol? x)
		    (bound? x)
		    (instance? (eval x))
		    (abstraction? (eval x))) (set! sup (eval x)))
	      ((and (symbol? x)
		    (bound? x)
		    (class? (eval x))
		    (abstraction-mold? (eval x))) (set! sup (eval x)))
	      ((and (pair? x)
		    (symbol? (car x))
		    (member (car x) NLst))   (set! Pars (cons x Pars)))
	      (#t			     (set! flg #f)))) args)

       (if (not (null? sup))
       	  (begin
	   (set! name (class-name sup))
	   (if (instance? sup)
		(set! supPars (list 
			(cons 'Variables (send sup 'get-Variables 'List))
			(cons 'Locals (send sup 'get-Locals 'List))
		      (cons 'NumComponents (send sup 'get-Components 'Number))
			(cons 'Components (send sup 'get-Components 'Types))
			(cons 'Algorithm (send sup 'get-Algorithm))
			(cons 'Hierarchy (send sup 'get-Hierarchy))))) ))

       (for-each
         (lambda (x)
	    (set! dum (assq x Pars))
	    (if (not dum) (set! dum (assq x supPars)))
	    (if dum (set! aux (cons dum aux)))) NLst)
;       (define dum (make-an-instance2 name))
;	(define dum (eval name (the-environment)))
        (define dum (make-an-instance (eval name (the-environment))))
	(if (not (null? aux))
	  (begin
	    (apply send (append (list dum 'set-fields) aux))
	    (if (send dum 'checkData) dum (error 'Abstraction "Wrong Data")))
	  dum)
       )
       (make-instance Abstraction))))

(define (compute-abstraction obj . args)
   (if (abstraction? obj)
    (if (not (null? args)) (apply send (append (list obj 'compute) args))
	    	           (send obj 'compute))
    (error 'compute-abstraction "Not an Abstraction ~s" obj)))

(define (describe-abstraction obj)
    (if (abstraction? obj)
	(send obj 'get-Description)
	(if (abstraction-mold? obj)
	    (send (make-an-instance obj) 'get-mold-Description)
	    (prn" This is not an Abstraction"))))

(define (describe-abstr-mold obj)
    (if (abstraction-mold? obj)
	    (send (make-an-instance obj) 'get-mold-Description)
	    (prn" This is not an Abstraction-Mold")))

--- NEW FILE: abstraction.foo ---
(require 'oops)
(define-class Abstraction (class-vars Vars			;a List
				      Locs			;a List
				      Comps			;a List
				      NComps			;a List/Number
				      Funx			;a List
				      Hier)			;a List

			  (instance-vars Variables		;Var-type
					 Locals			;Var-type
					 Components		;Comp-type
					 Algorithm		;Funx-type
					 Hierarchy		;Hier-type
					 NumComponents		;Comp-type-var
					 Init-Val		;Private
					 Main-Val		;   "
					 Out-Val		;   "
					 Coda-Val))		;   "
;;;					 Unknown-Symbols))	;Listofsymbols
;;;					 ((Key-Words))		;Dictionary

(define-method Abstraction (getclassvars)
    (list (cons 'Variables Vars)
    	  (cons 'Locals Locs)
	  (cons 'Components Comps)
	  (cons 'NumComponents NComps)
	  (cons 'Algorithm Funx)
	  (cons 'Hierarchy Hier)))

(define-method Abstraction (setclassvars Lst)
   (for-each
	(lambda (x)
	    (cond
		((equal? (car x) 'Variables)	  (set! Vars  (cdr x)))
		((equal? (car x) 'Locals)	  (set! Locs  (cdr x)))
		((equal? (car x) 'NComponents)	  (set! NComps (cdr x)))
		((equal? (car x) 'Components)     (set! Comps (cdr x)))
		((equal? (car x) 'Algorithm)	  (set! Funx  (cdr x)))
		((equal? (car x) 'Hierarachy)	  (set! Hier  (cdr x))))) Lst)
    #t)

(define-method Abstraction (initialize-instance)
    (set! Variables   (make-instance Var-Type  (Variables Vars)))
    (set! Locals      (make-instance Var-Type  (Variables Locs)))
    (set! Components  (make-instance Comp-Type (Types Comps)))
    (set! Algorithm   (make-instance Funx-Type (Descriptor Funx)))
    (set! Hierarchy   (make-instance Hier-Type (Descriptor Hier)))
    (set! NumComponents (send Components 'set-NumbOfElems NComps))
    (if (send self 'checkData) #t (error 'Abstraction "Wrong Data")))

(define-method Abstraction (checkData)
  (let ((varunknwn))
  (if (and
	(send Variables  'checkData)
	(send Locals     'checkData)
	(send Components 'checkData)
	(send Algorithm  'checkData)
	(send Hierarchy  'checkData)) #t #f)))
;
(define-method Abstraction (get-Name) (class-name self))

(define-method Abstraction (compute . args)
  (let ((aux))

    (if (not (null? args))
    	 (apply send (append (list self 'set-Variables-Values) args)))
    (send self 'set-Initval '())
    (send self 'set-Mainval '())
    (send self 'set-Outval  '())
    (send self 'set-Codaval '())

    (send self 'Fix) 
    (send self 'set-Initval
    		  (send self 'parse 'Init (send self 'get-Algorithm 'Init)
    			           	  (send self 'get-Hierarchy 'Init)))
    (apply send (append (list self 'set-fields) (send self 'get-Initval)))
    (send self 'Fix) 
    (send self 'set-Mainval
    		  (send self 'parse 'Main (send self 'get-Algorithm 'Main)
    			                  (send self 'get-Hierarchy 'Main)))
    (apply send (append (list self 'set-fields) (send self 'get-Mainval)))
    (send self 'Fix) 
    (send self 'set-Outval 
    		  (send self 'parse 'Out  (send self 'get-Algorithm 'Out)
    			           	  '()))
    (apply send (append (list self 'set-fields) (send self 'get-Outval)))
    (send self 'Fix) 
    (send self 'set-Codaval 
    		  (send self 'parse 'Coda (send self 'get-Algorithm 'Coda)
    			           	  (send self 'get-Hierarchy 'Coda)))
    (apply send (append (list self 'set-fields) (send self 'get-Codaval)))
    (send self 'Fix) 

    (set! aux (assq 'out (send self 'get-Outval)))
    (if aux (cadr aux) (send self 'get-Outval))))

(define-method Abstraction (Fix)
  (let ((vars (send self 'get-Variables)) (aux))

    (for-each
      (lambda (x)
	(set! aux (assq (cadr x) vars))
	(if aux (send Locals 'set-Variables (cons (car x) aux))
      	 	(set! aux (assq (caddr x) vars))
	 	(if aux (send Locals 'set-Variables (cons (car x) aux)))))
					(send self 'get-Locals 'List))

    (set! vars (append vars (send self 'get-Locals)))
 
    (for-each
      (lambda (x)
	(if (assq x vars)
	   (send Components 'adjust-Type x (cadr (assq x vars)))))
					(send self 'get-Components 'Types))
   
    (set! aux (assq (send self 'get-NumComponents) vars))
    (if aux (send self 'set-NumComponents (cadr aux)))

    (for-each
      (lambda (x y)
	(if (assq x vars)
	   (send self 'set-Comp-Typ-Numb y (cadr (assq x vars)))))
					(send self 'get-Components 'Number)
					(send self 'get-Components 'Types))
    (for-each
      (lambda (x)
	(if (and (pair? (cadr x))
		 (= (length (cadr x)) 1))
	  (begin
	     (set! aux (assq (caadr x) vars))
	     (if aux
	         (send Hierarchy 'set-Descriptor (cons (car x) (cadr aux))))))) 
		  			(send self 'get-Hierarchy))))

(define-method Abstraction (set-fields . args)
  (let ((flg #t))

   (if (null? args) '()

    (for-each
      (lambda (x)

      (cond
        ((not (pair? x)) #f)
        ((= (length x) 1) #f)
	((equal? (car x) 'Variables)
	   (apply send (append (list self 'set-Variables) (cdr x))))
	((or (equal? (car x) 'Variables-Names)
	      	  (equal? (car x) 'VNames))
	   (apply send (append (list self 'set-Variables-Names) (cdr x))))
	((or (equal? (car x) 'Variables-Defaults)
	      	  (equal? (car x) 'VDefaults))
	   (apply send (append (list self 'set-Variables-Defaults) (cdr x))))
	((or (equal? (car x) 'VarValues)
	      	  (equal? (car x) 'Variables-Current)
	      	  (equal? (car x) 'Variables-Values)
	      	  (equal? (car x) 'VValues))
	   (apply send (append (list self 'set-Variables-Values) (cdr x))))

	((equal? (car x) 'Locals)
	   (apply send (append (list self 'set-Locals) (cdr x))))
	((or (equal? (car x) 'Locals-Names)
	      	  (equal? (car x) 'LNames))
	   (apply send (append (list self 'set-Locals-Names) (cdr x))))
	((or (equal? (car x) 'Locals-Defaults)
	      	  (equal? (car x) 'LDefaults))
	   (apply send (append (list self 'set-Locals-Defaults) (cdr x))))
	((or (equal? (car x) 'Locals-Values)
	      	  (equal? (car x) 'LValues))
	   (apply send (append (list self 'set-Locals-Values) (cdr x))))

	((equal? 'Hierarchy (car x))
	      			(send self 'set-Hierarchy (cdr x)))
	((equal? 'Init-Hier (car x))
	      			(send self 'set-Init-Hier (cdr x)))
	((equal? 'Main-Hier (car x))
	      			(send self 'set-Main-Hier (cdr x)))
	((equal? 'Coda-Hier (car x))
	      			(send self 'set-Coda-Hier (cdr x)))

	((equal? 'Algorithm (car x))
	      			(send self 'set-Algorithm (cdr x)))
	((equal? 'Init-Func (car x))
	      			(send self 'set-Init-Func (cdr x)))
	((equal? 'Main-Func (car x))
	      			(send self 'set-Main-Func (cdr x)))
	((equal? 'Out-Func (car x))
	      			(send self 'set-Out-Func (cdr x)))
	((equal? 'Coda-Func (car x))
	      			(send self 'set-Coda-Func (cdr x)))

	((and (equal? 'Components (car x))
	      (not (null? (cleanlist (cdr x)))))
	      			(send self 'set-Components (cdr x)))
	((equal? 'NumComponents (car x))
	      			(send self 'set-NumComponents (cadr x)))

	((member (car x) (send self 'get-Variables 'Names)) 
			(apply send (append (list self 'set-Variables) x)))
	((member (car x) (send self 'get-Locals 'Names))
	      		(apply send (append (list self 'set-Locals) x)))

	((symbol? (car x))
	        (for-each
	         (lambda (t v)
		  (if (member (car x) v)
			(send self 'set-Comp-Var-Val t x)))
			     (send self 'get-Components 'Types)
			     (send self 'get-Components 'VarNames)))
	(#t	(set! flg #f)))) args))
   flg))

(define-method Abstraction (parse Symb Funx Hier)
  (if (null? Funx) '()
    (let* ((aux) (resl) (varunknown) (symblst)
	   (db1 (append (list (list 'self self))
	   		(send self 'get-Variables)
			(send self 'get-Locals)
			(list (list 'Components (send self 'get-Components)))))
	   (db2 (reverse
	          (append (send self 'get-Initval) (send self 'get-Mainval)
		        (send self 'get-Outval)    (send self 'get-Codaval))))
	   (db3 (map
	 	   (lambda (x y) (list x y)) (send self 'get-Components 'Types)
					     (send self 'get-Components)))
	    (Funx (send self 'parse0 Funx Hier db1 db2 db3)))

    (set! varunknown (send self 'check Funx db1 db2 db3))
    (if (null? varunknown)
	  (map
	    (lambda (n)
	      (set! symblst (append symblst (cdr n)))
	      (set! n (car n))
	      (set! aux
		(list (car n)
		      (apply (cadr n)
			 (map (lambda (z)
			   (send self 'resolv z db1 db2 resl db3)) (cddr n)))))
	    (set! resl (cons aux resl))
	    (apply send (append (list self 'set-fields) (list aux)))
	    aux) Funx)
;else
      (if (or (equal? Symb 'Init)
	      (equal? Symb 'Main)
	      (equal? Symb 'Coda))
	(map
	    (lambda (n)
	      (set! symblst (append symblst (cdr n)))
	      (set! n (car n))
	      (set! aux
		(list (car n)
		  (apply (cadr n)
		     (map (lambda (z)
			(send self 'resolv z db1 db2 resl db3)) (cddr n)))))
	    (set! resl (cons aux resl))
	    aux) Funx)

	(prn "Undefined symbols in"Symb"Func : " varunknown)
	(list
	  (lambda v 
            (set! db1 (append (map (lambda (x y) (list x y)) varunknown v) 
	    		      db1))
	(cadr (assq 'out
            (map
	      (lambda (n)
		(set! symblst (append symblst  (cdr n)))
		(set! n (car n))
		(set! aux
		  (list (car n)
	                (apply (cadr n)
			(map (lambda (z)
			   (send self 'resolv z db1 db2 resl db3)) (cddr n)))))
		(set! resl (cons aux resl)) aux) Funx)))) varunknown))))))


(define-method Abstraction (parse0 Funx Hier db1 db2 db3)
  (let ((resl ()) (aux))
    (if (not (pair? (car Funx))) (set! Funx (list Funx)))
    (if (not (null? Hier))
	(begin
	  (for-each
	    (lambda (x)  (set! aux (assq x Funx))
		         (if aux (set! resl (cons aux resl)))) Hier)
	  (set! Funx (reverse resl))))
    (map
      (lambda (x) (if (symbol? (car x))
		         (begin
			   (set! aux (send self 'parse1 (cdr x) db1 db2 db3))
			   (list (append (list (car x)) (car aux)) (cadr aux)))
	 	         (send self 'parse1 x db1 db2 db3))) Funx)))


(define-method Abstraction (parse1 funx db1 db2 db3)
  (let ((fun (car funx)) (pars (cdr funx)) 
  	(allpars) (nwpars ())
        (n -1) (m -1) (l -1) (auxil)
        (varmap ()) (Symlst '()) (Resul))

    (if (not (procedure? fun))
    			   (set! fun (send self 'resolv fun db1 db2 '() db3)))
   (if (not (procedure? fun))
      (begin (prn "Error Abstraction : not a procedure "fun)
    	     (error 'Abstraction "Parse"))
      (set! allpars
	(map 
	  (lambda (x)
	    (cond
	       ((symbol? x)                (set! Symlst (cons x Symlst))
					   (set! nwpars (cons x nwpars))
					   (set! m (+ m 1)) (list 'L m))
	       ((and (pair? x)
		     (procedure? (car x))) (set! auxil (parse1 x db1 db2 db3))
					   (set! Symlst (append
					   (reverse (cadr auxil)) Symlst))
					   (set! auxil (car auxil))
					   (set! nwpars  (cons auxil nwpars))
					   (set! m (+ m 1)) (list 'L m))
	      ((and (pair? x)
		    (symbol? (car x))
		    (equal? (cadr x) 'map)) (set! Symlst (cons (car x) Symlst))
					    (set! varmap (cons (car x) varmap))
					    (set! n (+ 1 n)) (list 'M n))
	      ((and (pair? x)
		    (pair? (car x))
		    (procedure? (caar x))
		    (equal? (cadr x) 'map))
				(set! auxil
				     (send self 'parse1 (car x) db1 db2 db3))
				(set! Symlst (append
				(reverse (cadr auxil)) Symlst))
				(set! auxil (car auxil))
				(set! varmap (cons auxil varmap))
				(set! n (+ 1 n)) (list 'M n))
	      ((and (pair? x)
		    (pair? (car x))
		    (equal? (cadr x) 'map));(set! varmap (cons (car x) varmap))
					   ;(set! n (+ 1 n)) (list 'M n))
				(set! auxil
			   (send self 'parse1 (cons list (car x)) db1 db2 db3))
				(set! Symlst (append
				(reverse (cadr auxil)) Symlst))
				(set! auxil (car auxil))
				(set! varmap (cons auxil varmap))
				(set! n (+ 1 n)) (list 'M n))
	    ((pair? x)		(set! auxil
	    			 (send self 'parse1 (cons list x) db1 db2 db3))
				(set! Symlst (append
				(reverse (cadr auxil)) Symlst))
				(set! auxil (car auxil))
				(set! nwpars  (cons auxil nwpars))
				(set! m (+ m 1)) (list 'L m))
	    (#t                             (set! nwpars (cons x nwpars))
					    (set! m (+ m 1)) (list 'L m)))) 
	  pars))
      (set! nwpars (reverse nwpars))
      (set! varmap (reverse varmap))
      (set! n -1)

      (list
        (if (null? varmap)
            (cons fun nwpars)
	    (append (list map
		         (if (null? nwpars)
			     (lambda m (apply fun m))
			     (list apply (lambda l (lambda m (apply fun
				 (map (lambda (x)
			             (if (equal? (car x) 'L) (nth l (cadr x))
						             (nth m (cadr x))))
				     allpars))))
			         nwpars)))
		      varmap))
        Symlst))))

(define-method Abstraction (resolv el db1 db2 db3 db4)
  (let ((db (append db1 db2 db3)) (aux1) (aux2) (v) (aux3))
   (cond
      ((symbol? el)
      	    (set! aux1 (assq el (append db3 db2 db4)))
	    (if aux1
	      (cadr aux1)
      	      (set! aux2 (assq el db1))
	      (if aux2
	       (begin
		 (set! aux2 (cadr aux2))
      	         (cond
      	           ((symbol? aux2) (set! aux3 (assq aux2 (append db3 db2 db4)))
			           (if aux3 (cadr aux3) aux2))
      	           (#t	   aux2)))
      	       (if (equal? el 'out) (send self 'get-Outval) el))))
      ((pair? el)
      	    (if (procedure? (car el))
	       (apply (car el) 
                        (map (lambda (x) (send self 'resolv x db1 db2 db3 db4)) 
				     (cdr el)))
	       (map (lambda (x) (send self 'resolv x db1 db2 db3 db4)) el)))
      (#t            el))))
(define-method Abstraction  (check0 el db1 db2 db3 db4)
   (if  (or (assq el db1)
   	    (assq el db2)
	    (assq el db3)
	    (equal? el 'out)
   	    (member el db4)) #f el))

(define-method Abstraction (check funx db1 db2 db3)
    (let* ((dbvar ()) (resl) (aux) (symlst ()))
	(for-each
	  (lambda (n) 
	    	(set! symlst (append symlst  (cadr n)))
	    	(set! n (car n))
	    	(set! dbvar (cons  (car n) dbvar))) funx)
	(for-each
	  (lambda (x)
	  	(set! aux (send self 'check0 x db1 db2 db3 dbvar))
		(if (and aux 
			(not (member aux resl)))
				(set! resl (cons aux resl)))) symlst)
	(reverse resl)))
;
(define-method Abstraction (reset-VarLocs)
  (let ((lnz (length (send self 'get-Variables))))
     (apply send (append (list self 'set-Variables) (make-list lnz '())))
     (set! lnz (length (send self 'get-Locals)))
     (apply send (append (list self 'set-Locals) (make-list lnz '())))))
;
(define-method Abstraction (set-Initval Lst) (set! Init-Val Lst))
(define-method Abstraction (set-Mainval Lst) (set! Main-Val Lst))
(define-method Abstraction (set-Outval Lst)  (set! Out-Val Lst))
(define-method Abstraction (set-Codaval Lst) (set! Coda-Val Lst))
(define-method Abstraction (get-Initval) Init-Val)
(define-method Abstraction (get-Mainval) Main-Val)
(define-method Abstraction (get-Outval)  Out-Val)
(define-method Abstraction (get-Codaval) Coda-Val)

;
;;
;;;	Methods to set! the object-fields
;;
;

(define-method Abstraction (set-Variables . Lst)
  (if (send Variables 'set-Variables Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables : ~a" Lst)))

(define-method Abstraction  (reset-Variables . Lst)
  (if (send Variables 'reset-Variables Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "reset-Variables : ~a" Lst)))

(define-method Abstraction (set-Variables-Names . Lst)
  (if (send Variables 'set-Names Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables-Names : ~a" Lst)))

(define-method Abstraction (set-Variables-Defaults . Lst)
  (if (send Variables 'set-Defaults Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables-Defaults : ~a" Lst)))

(define-method Abstraction (set-Variables-Values . Lst)
  (if (send Variables 'set-Values Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables-Values : ~a" Lst)))

(define-method Abstraction (add-Variable Lst . pos)
  (if (send Variables 'add-Variable Lst pos)
	(send self 'get-Variables 'List)
	(error 'Abstraction "add-Variable : ~a ~a" Lst pos)))

(define-method Abstraction (remove-Variable Elm)
  (if (send Variables 'remove-Variable Elm)
	(send self 'get-Variables 'List)
	(error 'Abstraction "remove-Variable : ~a" Elm)))

(define-method Abstraction (set-Locals . Lst)
  (if (send Locals 'set-Variables Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals : ~a" Lst)))

(define-method Abstraction (reset-Locals . Lst)
  (if (send Locals 'reset-Variables Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "reset-Locals : ~a" Lst)))

(define-method Abstraction (set-Locals-Names . Lst)
  (if (send Locals 'set-Names Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals-Names : ~a" Lst)))

(define-method Abstraction (set-Locals-Defaults . Lst)
  (if (send Locals 'set-Defaults Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals-Defaults : ~a" Lst)))

(define-method Abstraction (set-Locals-Values . Lst)
  (if (send Locals 'set-Values Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals-Values : ~a" Lst)))

(define-method Abstraction (add-Local Lst . pos)
  (if (send Locals 'add-Variable Lst pos)
	(send self 'get-Variables 'List)
	(error 'Abstraction "add-Local : ~a ~a" Lst pos)))

(define-method Abstraction (remove-Local Elm)
  (if (send Locals 'remove-Variable Elm)
	(send self 'get-Variables 'List)
	(error 'Abstraction "remove-Local : ~a" Elm)))

(define-method Abstraction (set-Algorithm . Lst)
    (if (send Algorithm 'set-Descriptor (clean Lst))
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Algorithm : ~a" Lst)))

(define-method Abstraction (reset-Algorithm . Lst)
  (let ((aux (send self 'get-Algorithm)))
    (send Algorithm 'set-Descriptor '())
    (if (send Algorithm 'set-Descriptor (clean Lst))
    	(send self 'get-Algorithm)
	(error 'Abstraction "reset-Algorithm : ~a" Lst))))

(define-method Abstraction (set-Init-Func . Lst)
    (if (send Algorithm 'set-Init-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Init-Func : ~a" Lst)))

(define-method Abstraction (set-Main-Func . Lst)
    (if (send Algorithm 'set-Main-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Main-Func : ~a" Lst)))

(define-method Abstraction (set-Out-Func . Lst)
    (if (send Algorithm 'set-Out-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Out-Func : ~a" Lst)))

(define-method Abstraction (set-Coda-Func . Lst)
    (if (send Algorithm 'set-Coda-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Coda-Func : ~a" Lst)))

(define-method Abstraction (set-Hierarchy . Lst)
    (if (send Hierarchy 'set-Descriptor (clean Lst))
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Hierarchy : ~a" Lst)))

(define-method Abstraction (set-Init-Hier Lst)
    (if (not (list? Lst)) (set! Lst (list Lst)))
    (if (send Hierarchy 'set-Init-Hier Lst)
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Init-Hier : ~a" Lst)))

(define-method Abstraction (set-Main-Hier Lst)
    (if (not (list? Lst)) (set! Lst (list Lst)))
    (if (send Hierarchy 'set-Main-Hier Lst)
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Main-Hier : ~a" Lst)))

(define-method Abstraction (set-Coda-Hier Lst)
    (if (not (list? Lst)) (set! Lst (list Lst)))
    (if (send Hierarchy 'set-Coda-Hier Lst)
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Coda-Hier : ~a" Lst)))

(define-method Abstraction (set-Components . Lst)
    (if (send Components 'set-Types Lst)
    	(send self 'get-Components 'Types)
	(error 'Abstraction "set-Components : ~a" Lst)))

(define-method Abstraction (set-NumComponents Lst)
  (let ((aux (send self 'get-Components 'Types)) (flg #t))
    (if (symbol? Lst)
    	(begin
	    (set! NumComponents Lst)
	    Lst)
	(if (or (pair? Lst)
		(= (length aux) 1))
	    (set! flg (send Components 'set-NumbOfElems Lst))
	    (set! flg (send Components 'set-TotalNumbOfElems Lst)))
	(if flg
	   (begin
		(set! NumComponents (send self 'get-Components 'Number))
		NumComponents)
	(error 'Abstraction "set-NumComponents : ~a" Lst)))))

(define-method Abstraction (set-Comp-Typ-Numb Typ Num)
  (let ((aux (send self 'get-Components 'Types)) (flg #t))
    (if (and (member Typ aux)
    	     (number? Num))
	(set! flg (send Components 'adjust-NumberofElement Typ Num))
	(set! flg #f))
    (if flg (send self 'get-Components 'Number)
	(error 'Abstraction "set-Comp-Typ-Numb : ~a ~a" Typ Num))))

(define-method Abstraction (set-Comp-Var-Val Typ Lst . ind)
  (let ((aux) (i -1) (ind (if (not (null? ind)) (car ind) '())))
    (for-each 
     (lambda (x y)
      (if (equal? Typ x) (set! aux y))) (send self 'get-Components 'Types)
					(send self 'get-Components))
    (if (not (pair? aux)) (set! aux (list aux)))
    (if (not (null? aux))
       (for-each
	(lambda (x)
	  (set! i (+ i 1))
	  (if (or (null? ind) (= ind i))
	    (apply send (append (list x 'set-Variables-Values) Lst)))) aux)))
   #t)

(define-method Abstraction (set-Comp-Var-Def Typ Lst . ind)
  (let ((aux) (i -1) (ind (if (not (null? ind)) (car ind) '())))
    (for-each 
     (lambda (x y)
      (if (equal? Typ x) (set! aux y))) (send self 'get-Components 'Types)
					(send self 'get-Components))
    (if (not (pair? aux)) (set! aux (list aux)))
    (if (not (null? aux))
       (for-each
	(lambda (x)
	  (set! i (+ i 1))
	  (if (or (null? ind) (= ind i))
	   (apply send (append (list x 'set-Variables-Defaults) Lst)))) aux)))
  #t)


;
;;
;;;	Methods to get data from the object-fields
;;
;

(define-method Abstraction (get-NumComponents) NumComponents)
(define-method Abstraction (get-Varnames)  (send self 'get-Variables 'Names))
(define-method Abstraction (get-Varvalues) (send self 'get-Variables))
(define-method Abstraction (get-Localsnames) (send self 'get-Locals 'Names))
(define-method Abstraction (get-Localsvalues) (send self 'get-Locals))
(define-method Abstraction (get-Componentsnames)
					 (send self 'get-Components 'Types))
(define-method Abstraction (get-NumberOfComponents)
				   	(send self 'get-Components 'Number))
(define-method Abstraction (get-TotalNumberOfComponents)
				    (send self 'get-Components 'TotalNumber))

(define-method Abstraction (get-Variables . Args)
   (if (null? Args)
	(send Variables 'get-Variables)
	(set! Args (car Args))
	(cond
	   ((null? Args)		(send Variables 'get-Variables))
	   ((equal? Args 'List)		(send Variables 'get-Variables-List))
	   ((equal? Args 'Names)	(send Variables 'get-Names))
	   ((equal? Args 'Defaults)	(send Variables 'get-Defaults))
	   ((equal? Args 'Current)	(send Variables 'get-Values)))))

(define-method Abstraction (get-Locals . Args)
   (if (null? Args)
	(send Locals 'get-Variables)
	(set! Args (car Args))
	(cond
	   ((null? Args)		(send Locals 'get-Variables))
	   ((equal? Args 'List)		(send Locals 'get-Variables-List))
	   ((equal? Args 'Names)	(send Locals 'get-Names))
	   ((equal? Args 'Defaults)	(send Locals 'get-Defaults))
	   ((equal? Args 'Current)	(send Locals 'get-Values)))))

(define-method Abstraction (get-Algorithm . Args)
   (if (null? Args)
	(send Algorithm 'get-Descriptor)
	(set! Args (car Args))
	(cond
	   ((equal? Args 'Init)		(send Algorithm 'get-Init-Func))
	   ((equal? Args 'Main)		(send Algorithm 'get-Main-Func))
	   ((equal? Args 'Out)		(send Algorithm 'get-Out-Func))
	   ((equal? Args 'Coda)		(send Algorithm 'get-Coda-Func)))))

(define-method Abstraction (get-Hierarchy . Args)
   (if (null? Args)
	(send Hierarchy 'get-Descriptor)
	(set! Args (car Args))
	(cond
	   ((equal? Args 'Init)		(send Hierarchy 'get-Init-Hier))
	   ((equal? Args 'Main)		(send Hierarchy 'get-Main-Hier))
	   ((equal? Args 'Coda)		(send Hierarchy 'get-Coda-Hier)))))


(define-method Abstraction (get-Components . Args)
 (if (null? Args)
   (send Components 'get-Components)
   (set! Args (car Args))
   (cond
    ((null? Args)		      (send Components 'get-Components))
    ((equal? Args 'Description)       (send Components 'get-Description))
    ((equal? Args 'Number)	      (send Components 'get-NumbOfElems))
    ((equal? Args 'TotalNumber)       (send Components 'get-TotalNumbOfElems))
    ((equal? Args 'Types)	      (send Components 'get-Types))
    ((equal? Args 'Variables)	      (send Components 'get-VariablesValues))
    ((equal? Args 'VariablesList)     (send Components 'get-VariablesList))
    ((equal? Args 'VariablesNames)    (send Components 'get-Variables))
    ((equal? Args 'VariablesCurrent)  (send Components 'get-Values))
    ((equal? Args 'VariablesDefaults) (send Components 'get-VariablesDefaults))
    ((equal? Args 'VarNames)          (send Components 'get-Variables))
    ((equal? Args 'VarValues)         (send Components 'get-Values)))))

(define-method Abstraction (Extract-Component Typ . rfrnz)
    (send Components 'Extract-Component Typ rfrnz))

(define-method Abstraction (get-Description)
    (newline)
    (prn "This is an Abstraction of Type : "(send self 'get-Name))
    (newline)
    (prn " Variables : "(send self 'get-Variables 'List))
    (prn " Locals    : "(send self 'get-Locals 'List))
    (send self 'get-Components 'Description)
    (prn " Algorithm : ")
    (prn "    Initialization  :"(send self 'get-Algorithm 'Init))
    (prn "    Main-Body       :"(send self 'get-Algorithm 'Main))
    (prn "    Output Function :"(send self 'get-Algorithm 'Out))
    (prn "    Coda            :"(send self 'get-Algorithm 'Coda))
    (newline)
    (prn " Hierarchy : ")
    (prn "    Initialization  :"(send self 'get-Hierarchy 'Init))
    (prn "    Main-Body       :"(send self 'get-Hierarchy 'Main))
    (prn "    Coda            :"(send self 'get-Hierarchy 'Coda)))

(define-method Abstraction (get-mold-Description)
  (let ((aux (send self 'getclassvars)) (aux1))
    (newline)
    (prn "This is the Abstraction-mold : "(send self 'get-Name))
    (newline)

    (set! aux1 (assq 'Variables aux))
    (prn " Variables : "(if aux1 (cdr aux1) "Undefined"))
    (set! aux1 (assq 'Locals aux))
    (prn " Locals    : "(if aux1 (cdr aux1) "Undefined"))

    (set! aux1 (assq 'Components aux))
    (prn " Component Types : "(if aux1 (cdr aux1) "Undefined"))

    (set! aux1 (assq 'Algorithm aux))
    (set! aux1 (if aux1 (cdr (assq 'Algorithm aux)) '()))
    (if (null? aux1)
      (prn " Algorithm : Undefined")
      (prn " Algorithm : ")
      (prn "    Initialization  :"(if (assq 'Init-Func aux1) 
    				    (cdr (assq 'Init-Func aux1)) "Undefined"))
      (prn "    Main-Body       :"(if (assq 'Main-Func aux1) 
    				    (cdr (assq 'Main-Func aux1)) "Undefined"))
      (prn "    Output Function :"(if (assq 'Out-Func aux1) 
    				    (cdr (assq 'Out-Func aux1))
				    (if (assq 'out aux1)
				       (cdr (assq 'out aux1))
				       (car aux1))))
      (prn "    Coda            :"(if (assq 'Coda-Func aux1) 
    				    (cdr (assq 'Coda-Func aux1)) 
				    "Undefined")))
    (newline)
    (set! aux1 (assq 'Hierarchy aux))
    (set! aux1 (if aux1 (cdr (assq 'Hierarchy aux)) '()))
    (if (null? aux1)
      (prn " Hierarchy : Undefined")
      (prn " Hierarchy : ")
      (prn "    Initialization  :"(if (assq 'Init-Hier aux1) 
    				    (cadr (assq 'Init-Hier aux1)) "Undefined"))
      (prn "    Main-Body       :"(if (assq 'Main-Hier aux1) 
    				    (cadr (assq 'Main-Hier aux1)) "Undefined"))
      (prn "    Coda            :"(if (assq 'Coda-Hier aux1) 
    				    (cadr (assq 'Coda-Hier aux1)) 
				    "Undefined")))))

--- NEW FILE: funx-type.foo ---
(define-class Funx-Type (instance-vars Descriptor
				       Init-Func
			 	       Main-Func
				       Out-Func
				       Coda-Func
				       Init-Symbols
				       Main-Symbols
				       Out-Symbols
				       Coda-Symbols))

(define-method Funx-Type (checkData)
   (let ((flg #t))
	(if (null? Descriptor)
	   (if (and (null? Init-Func)
		    (null? Main-Func)
		    (null? Out-Func)
		    (null? Coda-Func))
		#t
		(if (not (send self 
		        'set-Descriptor (list (list 'Init-Func Init-Func)
					      (list 'Main-Func Main-Func)
					      (list 'Out-Func  Out-Func)
					      (list 'Coda-Func Coda-Func))))
			(set! flg #f)))
	   (if (not (send self 'set-Descriptor Descriptor)) (set! flg #f)))
	(if (not flg) (prn "Error Algorithm "Descriptor))
	flg))

(define-method Funx-Type (set-Descriptor Lst)
  (let ((SymLst (list 'Init-Func 'Main-Func 'Out-Func 'Coda-Func)) 
   	(aux) (flg #t))

    (if (not (null? (flatout Lst)))
       (if (not (pair? Lst))
       	   (set! flg #f)

   	   (set! aux (first-symbol Lst))
           (if (not (member aux SymLst))
		(set! Lst (list (list 'Out-Func Lst)))
		(if (symbol? (car Lst)) (set! Lst (list Lst))))
   	   (for-each
   	     (lambda (x)
               (set! aux 
	         (cond
	           ((equal? (car x) 'Init-Func)
				 (send self 'set-Init-Func (clean (cdr x))))
	           ((equal? (car x) 'Main-Func)
				 (send self 'set-Main-Func (clean (cdr x))))
	           ((equal? (car x) 'Out-Func)
				 (send self 'set-Out-Func  (clean (cdr x))))
	           ((equal? (car x) 'Coda-Func)
				 (send self 'set-Coda-Func (clean (cdr x))))))
               (if (not aux) (set! flg #f))) Lst)
   	   (if flg (set! Descriptor (list (list 'Init-Func Init-Func)
				          (list 'Main-Func Main-Func)
				          (list 'Out-Func  Out-Func)
				          (list 'Coda-Func Coda-Func)))))
		   (set! Init-Func '()) (set! Main-Func '())
		   (set! Out-Func '()) (set! Coda-Func '())
		   (set! Descriptor (list (list 'Init-Func '())
		   			  (list 'Main-Func '())
					  (list 'Out-Func '())
					  (list 'Coda-Func '()))))
	flg))

(define (first-symbol Lst)
    (let ((resl '()) (Lst (flatten Lst)))
    	(while (and (null? resl) (not (null? Lst)))
	    (if (symbol? (car Lst)) (set! resl (car Lst))
	    			    (set! Lst (cdr Lst))))
	resl))

(define-method Funx-Type (set-Init-Func Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Init-Func Lst)
	       (set! Descriptor '())
	       (set! Init-Symbols (symbols Lst))
	       #t)
	(set! Init-Func '())
	#f))

(define-method Funx-Type (set-Main-Func Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Main-Func Lst)
	       (set! Descriptor '())
	       (set! Main-Symbols (symbols Lst))
	       #t)
	(set! Main-Func '())
	#f))

(define-method Funx-Type (set-Out-Func Lst)
  (if (or (null? Lst)
  	  (null? (flatout Lst)))
     (begin (set! Out-Func Lst)
	       (set! Descriptor '())
	       (set! Out-Symbols '())
	       #t)
     (while (and (= (length Lst) 1)
   	         (pair? (car Lst)))	(set! Lst (car Lst)))
     (if (and (symbol? (car Lst))
    	      (equal? 'out (car Lst))) (set! Lst (list Lst))
	     			       (set! Lst (list (cons 'out Lst))))
     (set! Lst (send self 'check Lst))
     (if (and Lst (not (null? Lst)))
    	(begin (set! Out-Func Lst)
	       (set! Descriptor '())
	       (set! Out-Symbols (symbols Lst))
	       #t)
	(set! Out-Func '())
	#f)))

(define-method Funx-Type (set-Coda-Func Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Coda-Func Lst)
	       (set! Descriptor '())
	       (set! Coda-Symbols (symbols Lst))
	       #t)
	(set! Coda-Func '())
	#f))

(define (symbols Lst)
    (map
	(lambda (x)
		(cons (car x) (body-symbs (cdr x)))) Lst))

(define (body-symbs Lst)
   (let ((aux))
   	(for-each
	    (lambda (x)
		(if (symbol? x) (set! aux (cons x aux)))) (flatten Lst))
	aux))

(define-method Funx-Type (canonic Lst)
  (let ((aux))

    (while (and (pair? Lst)
		(= (length Lst) 1)
		(pair? (car Lst))) (set! Lst (car Lst)))
    (if (symbol? (car Lst)) (set! Lst (list Lst)))

    (map (lambda (x) (set! aux (send self 'canterm x))
		     (cons (car aux) (send self 'canbody (cdr aux)))) Lst)))

(define-method Funx-Type  (canterm Lst)
    (if (and (pair? Lst)
        (= (length Lst) 1)) (send self 'canterm (car Lst)) Lst))

(define-method Funx-Type  (canbody Lst)
    (if (and (= (length Lst) 1)
	     (pair? (car Lst))) (set! Lst (send self 'canbody (car Lst))))
    (map (lambda (x) (send self 'canparm x)) Lst))

(define-method Funx-Type (canparm Lst) Lst)

(define-method Funx-Type (check Lst)
  (let ((flg #t))

    (if (null? (cleanlist Lst)) '()

	(set! Lst (send self 'canonic Lst))
	(for-each
	  (lambda (x) (if (not (send self 'checkterm x)) (set! flg #f))) Lst)
	(if flg Lst #f))))

(define-method Funx-Type (checkterm el)
    (if (and (symbol? (car el)) (send self 'checkbody (cdr el))) el #f))

(define-method Funx-Type (checkbody expr)
  (let ((flg #t))
    (for-each
     (lambda (x) (if (not (send self 'checkpars x)) (set! flg #f))) (cdr expr))

    (if (and flg
    	     (or (symbol? (car expr))
	     	 (procedure? (car expr)))) expr #f)))

(define-method Funx-Type (checkpars el)
    (cond
    	((pair? el)		(send self 'checkpairpar el))
	(#t			#t)))

(define-method Funx-Type (checkpairpar el)
  (let ((flg #t))
    (for-each (lambda (x) (if flg (set! flg (checkpars x)))) el)
    (cond
	(flg							#t)
	((and (equal? 'map (cadr el))
	      (or (symbol? (car el))
	      	  (and (pair? (car el))
		       (send self 'checkpairpar (car el)))))	#t)
        ((send self 'checkbody el)				#t)
	(#t							#f))))


(define-method Funx-Type (get-Descriptor)
   (if (null?  Descriptor) (list (list 'Init-Func Init-Func)
	    			 (list 'Main-Func Main-Func)
				 (list 'Out-Func  Out-Func)
				 (list 'Coda-Func Coda-Func))
   			   Descriptor))

(define-method Funx-Type (get-Init-Func)  Init-Func)
(define-method Funx-Type (get-Main-Func)  Main-Func)
(define-method Funx-Type (get-Out-Func)   Out-Func)
(define-method Funx-Type (get-Coda-Func)  Coda-Func)

(define-method Funx-Type (get-Symbols)
   (append Init-Symbols Main-Symbols Out-Symbols Coda-Symbols))

(define-method Funx-Type (get-Init-Symbols) Init-Symbols)
(define-method Funx-Type (get-Main-Symbols) Main-Symbols)
(define-method Funx-Type (get-Out-Symbols)  Out-Symbols)
(define-method Funx-Type (get-Coda-Symbols) Coda-Symbols)


--- NEW FILE: var-type.foo ---
(require 'oops)
(define-class Var-Type (instance-vars  Variables
				       (checkd #f)))

(define-method Var-Type (checkData)
  (let ((flg #t) (aux) (varis))
   (set! varis
    (cond
       ((null? Variables)	'())
       ((pair? Variables)	(map (lambda (x)
       					(set! aux (send self 'check0 x))
					(if (not aux) (set! flg #f)) aux)
				      Variables))
       ((symbol? Variables)	(list (list Variables '() '())))
       (#t			(set! flg #f))))
   (set! checkd #t)
   (if flg (begin (set! Variables varis) #t)
   	   (set! Variables '())   #f)))

(define-method Var-Type (check0 el)
    (cond
	((symbol? el)			(list el '() '()))
	((and (pair? el)
	      (= (length el) 1))	(send self 'check0 (car el)))
	((and (pair? el)
	      (= (length el) 2)
	      (symbol? (car el)))	(list (car el) (cadr el) '()))
	((and (pair? el)
	      (= (length el) 3)
	      (symbol? (car el)))	el)
	(#t				#f)))

(define-method Var-Type (get-Names)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (car x)) Variables))

(define-method Var-Type (get-Defaults)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (cadr x)) Variables))

(define-method Var-Type (get-Values)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (caddr x)) Variables))

(define-method Var-Type (get-Variables)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (if (null? (caddr x))
    			 (list (car x) (cadr x))
			 (list (car x) (caddr x))))  Variables))

(define-method Var-Type (get-Variables-List)
    (if (not checkd) (send self 'checkData))
    Variables)

(define-method Var-Type (reset-Variables . Lst)
   (set! Variables '())
   (if (not (null? Lst)) (apply send (append (list self 'set-Variables) Lst)))
   #t)

(define-method Var-Type (set-Names Lst)
   (set! Lst (flatten Lst))
   (if (not (symbolic? Lst))
   	'()
   	(send self 'set-Variables (map (lambda (x) (list x '() '())) Lst))))

(define-method Var-Type (set-Defaults Lst)
  (let ((vars (send self 'get-Variables-List)) (aux) (dum))


    (if (or (null? vars)
    	    (null? Lst))
       '()

	(if (not (pair? Lst))
	    (set! Variables
	    		(cons (list (caar vars) Lst (caddar vars)) (cdr vars)))

	    (set! dum (first-symbol Lst))
	    (if (assq dum vars)
	      (if (equal? (car Lst) dum)
	        (set! Variables
			(cons (list (caar vars) (car Lst) (caddar vars))
		  		    (cdr vars)))
		(set! Variables
		 (map
		  (lambda (x)
		     (set! aux (assq (car x) Lst))
		     (if (not aux) (set! aux (member (car x) Lst)))
		     (set! aux (if aux (cadr aux) '()))
		     (list (car x) aux (caddr x))) vars)))

	      	(set! aux
		 (map (lambda (x y) (list (car x) y (caddr x))) vars Lst))
	      	(set! dum (length aux))
	      	(if (< dum (length vars))
			(set! aux (append aux (list-tail vars dum))))
	      	(set! Variables aux)))

	(if (send self 'checkData)
		(send self 'get-Variables-List)
    		(set! Variables vars) #f))))

(define-method Var-Type (set-Values Lst)
  (let ((vars (send self 'get-Variables-List)) (dum) (aux))

    (if (or (null? vars)
    	    (null? Lst))
       '()

	(if (not (pair? Lst))
	    (set! Variables
	    		(cons (list (caar vars) (cadar vars) Lst) (cdr vars)))

	    (set! dum (first-symbol Lst))
	    (if (assq dum vars)
	      (if (equal? (car Lst) dum)
	        (set! Variables (cons (list (caar vars) (cadar vars) (car Lst))
		  		   (cdr vars)))
		(set! Variables
		 (map
		  (lambda (x)
		     (set! aux (assq (car x) Lst))
		     (if (not aux) (set! aux (member (car x) Lst)))
		     (set! aux (if aux (cadr aux) '()))
		     (list (car x) (cadr x) aux)) vars)))

	      	(set! aux
		 (map (lambda (x y) (list (car x) (cadr x) y)) vars Lst))
	      	(set! dum (length aux))
	      	(if (< dum (length vars))
			(set! aux (append aux (list-tail vars dum))))
	      	(set! Variables aux)))

	(if (send self 'checkData)
		(send self 'get-Variables-List)
    		(set! Variables vars) #f))))


(define-method Var-Type (set-Variables Lst)
  (let ((vars (send self 'get-Variables-List)) (dum) (aux) (i -1)
  	(flg1 #t) (flg2 #t) (flg3 #f))

   (if (or (null? Lst)
           (and (null? vars)
	   	(null? (car Lst))))
      #t
      (if (null? vars)
 ...
 
[truncated message content]

[foo-cvs] foo/elkfoo/scm/control/interface-lib Makefile.am,NONE,1.1 sp-components.foo,NONE,1.1 sp-datapack-funs.foo,NONE,1.1 sp-inoutmatrix.foo,NONE,1.1 sp-patchgen-funs.foo,NONE,1.1 sp-sigpack-type.foo,NONE,1.1 sp-sndpack-type.foo,NONE,1.1

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

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

Added Files:
	Makefile.am sp-components.foo sp-datapack-funs.foo 
	sp-inoutmatrix.foo sp-patchgen-funs.foo sp-sigpack-type.foo 
	sp-sndpack-type.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: sp-components.foo ---
(define (Bln Dur Frq . args)
   (let* ((Frq  (Sigpar-fun Frq Dur))
    	  (args (flatout args))
	  (taps 10) (seed 1993))
	(if (not (null? args))
	  (begin
	      (if (not (null? (car args)))  (set! taps (car args)))
       	      (if (not (null? (cadr args))) (set! seed (cadr args)))))
	(bln~ Frq taps seed)))

(define (Cfilter Dur Frq Bdw Input)
   (let ((Input (Input-fun Input Dur)))
	(c2pf~ Input Frq Bdw)))

(define (CPZfilter Dur C0 C1 C2 D0 D1 D2 Input)
   (let ((Input (Input-fun Input Dur)))
	(c2p2zf~ Input C0 C1 C2 D0 D1 D2)))

(define (Fof Dur Fnd Frq Bdw Amp Tex Dbt Att)
   (let ((Fnd   (Sigpar-fun Fnd Dur))
	 (Frq   (Sigpar-fun Frq Dur))
	 (Bdw   (Sigpar-fun Bdw Dur))
	 (Amp	(Sigpar-fun Amp Dur))
	 (Tex	(Sigpar-fun Tex Dur))
	 (Dbt	(Sigpar-fun Dbt Dur))
	 (Att	(Sigpar-fun Att Dur)))

	(fof~ Fnd Frq Bdw Amp Tex Dbt Att)))

(define (FVEfilter Dur F1 Q Input)
   (let ((Input (Input-fun Input Dur))
	 (F1	(Sigpar-fun F1 Dur))	    ; F1 = (sin (* 2 pi (/ Frq SR)))
	 (Q	(Sigpar-fun Q Dur)))	    ; Q  = (/ Bdw (/ Frq 2))
	(fve~ Input F1 Q)))

(define (Lookup Dur Snd Pos . taps)
   (let ((Snd  (Sndpar-fun Snd))
         (Pos  (Sigpar-fun Pos Dur))
   	 (taps (cleanlist taps)))
      (if (pair? Snd)  (apply add~ 
      				(map
				 (lambda (x)
				   (if (not (null? taps))
				   	 (lookup-snd~ x Pos (car taps))
		 			 (lookup~snd~ x Pos))) Snd))
		       (if (not (null? taps))
		             (lookup-snd~ Snd Pos (car taps))
				(lookup-snd~ Snd Pos)))))

(define (Module Dur K-expr . Input) ;(prn Input)
  (let ((Input (if (null? Input) #f (car Input)))) ;(prn Input)
     (if Input 
        (begin
	   (if (and (pair? Input)
	       (= (length Input) 1)) (set! Input (car Input)))
	   (set! Input
	   	(if (pair? Input) (map (lambda (x) (Input-fun x Dur)) Input)
				  (Input-fun Input Dur)))
	   (K-expr Dur Input))
        (K-expr Dur))))

(define (Noise . seed)
   (let ((seed (cleanlist seed)))
	(if (not (null? seed))  (noise~ (car seed))
		  (noise~))))

(define (Reverb Dur NCh Ndl Rvt0 Damp Input . delays)
  (let ((Input (if (pair? Input) (map (lambda (x) (Input-fun x Dur)) Input)
				 (list (Input-fun Input Dur))))
    	(delays (if (not (null? delays)) (list (flatten delays)) #f))
	(rin) (rout))
    (set! rin 
	  (if delays (apply reverb~ (append (list Ndl Rvt0 Damp) Input delays))
		     (apply reverb~ (append (list Ndl Rvt0 Damp) Input))))
       (do ((c NCh (- c 1))) ((= c 0) (if (= (length rout) 1) (car rout) rout))
	    (set! rout (cons (revout~ c rin) rout)))))

(define (Revrb8 Dur NCh Rvt0 Damp Input)
    (let ((Input (if (pair? Input) (map (lambda (x) (Input-fun x Dur)) Input)
				   (list (Input-fun Input Dur))))
	  (rin) (rout))
      (set! rin (apply reverb~ (append (list 8 Rvt0 Damp) Input)))
      (do ((c NCh (- c 1))) ((= c 0) (if (= (length rout) 1) (car rout) rout))
	   (set! rout (cons (revout~ c rin) rout)))))

(define (Revrb12 Dur NCh Rvt0 Damp Input)
    (let ((Input (if (pair? Input) (map (lambda (x) (Input-fun x Dur)) Input)
				   (list (Input-fun Input Dur))))
	  (rin) (rout))
      (set! rin (apply reverb~ (append (list 12 Rvt0 Damp) Input)))
      (do ((c NCh (- c 1))) ((= c 0) (if (= (length rout) 1) (car rout) rout))
	   (set! rout (cons (revout~ c rin) rout)))))

(define (Revrb16 Dur NCh Rvt0 Damp Input)
    (let ((Input (if (pair? Input) (map (lambda (x) (Input-fun x Dur)) Input)
				   (list (Input-fun Input Dur))))
	  (rin) (rout))
      (set! rin (apply reverb~ (append (list 16 Rvt0 Damp) Input)))
      (do ((c NCh (- c 1))) ((= c 0) (if (= (length rout) 1) (car rout) rout))
	   (set! rout (cons (revout~ c rin) rout)))))

(define (Sampler Dur Frq Snd . taps)
  (let ((Snd  (Sndpar-fun Snd))
        (Frq  (Sigpar-fun Frq Dur))
	(taps (if (not (null? (cleanlist taps))) (cleanlist taps) #f)))
     (if (pair? Snd)
	(apply add~ (map (lambda (x) (if taps (transp-snd~ Snd Frq (car taps))
	  	 			      (transp-snd~ Snd Frq))) Snd))
	(if taps (transp-snd~ Snd Frq (car taps))
		 (transp-snd~ Snd Frq)))))

(define (Sine Dur Frq . initphas)
   (let ((Frq      (Sigpar-fun Frq Dur))
         (initphas (cleanlist initphas)))
	(if (not (null? initphas))  (sine~ Frq (car initphas))
		     		    (sine~ Frq))))

(define (Sndread Snd)
   (let ((Snd (Sndpar-fun Snd)))
      (if (pair? Snd)  (apply add~ (map (lambda (x) (read-snd~ x)) Snd))
		       (read-snd~ Snd))))

(define (Vfilter Dur Frq Bdw Input)
   (let ((Input (Input-fun Input Dur))
	 (Frq   (Sigpar-fun Frq Dur))
	 (Bdw   (Sigpar-fun Bdw Dur)))
	(v2pf~ Input Frq Bdw)))


--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/interface-lib/Makefile.am
# 2004 rumori

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

NULL = 

pkginterface_DATA = $(ELKFOO_INTERFACE_FILES)

pkginterfacedir = $(pkgdatadir)/control/interface-lib

ELKFOO_INTERFACE_FILES = \
	sp-components.foo \
	sp-datapack-funs.foo \
	sp-inoutmatrix.foo \
	sp-patchgen-funs.foo \
	sp-sigpack-type.foo \
	sp-sndpack-type.foo \
	$(NULL)

--- NEW FILE: sp-inoutmatrix.foo ---
;
;Mtx === (Out1 Out2 Out3 ...)
;	    wherein Out1=(ValInput1 ValInput2 ...)
;
(define (Totalclean ListofSignals)
    (if (pair? ListofSignals) (cleanlist ListofSignals)
    		    	      (list ListofSignals)))

(define (Addupsig ListofSignals)
    (apply add~ (Totalclean ListofSignals)))

(define (Panfun Position Dur Input)
    (let ((Pos (Sigpar-fun Position Dur)))
	(list (mul~ Input (sub~ (~ 1) Pos))
	      (mul~ Input Pos))))

(define (Pan4fun Position Dur Input)
  (let ((Pos (min~ (~ 4.) (abs~ (Sigpar-fun Position Dur))))
	(vo1) (vo2) (vo3) (vo4))
      (set! vo1 (add~ (max~ (~ 0) (sub~ (~ 1) Pos))
      		      (max~ (~ 0) (sub~ Pos (~ 3)))))
      (set! vo2 (max~ (~ 0) (min~ Pos (sub~ (~ 2) Pos))))
      (set! vo3 (max~ (~ 0) (min~ (sub~ Pos (~ 1)) (sub~ (~ 3) Pos))))
      (set! vo4 (max~ (~ 0) (min~ (sub~ Pos (~ 2)) (sub~ (~ 4) Pos))))
      (list (mul~ Input vo1) (mul~ Input vo2) 
      	    (mul~ Input vo3) (mul~ Input vo4))))

(define (Outmapin Mtx Dur Input) ;(prn "Outmapin" Input Mtx)
 (if (null? Mtx) Input
  (define aux
    (cond
     ((null? Input)           (~ 0))
     ((null? Mtx)             Input)
     ((number? Mtx)           (cond
				 ((= Mtx 0)	(~ 0))
			         ((= Mtx 1)	(Addupsig Input))
				 (#t     (mul~ (~ Mtx) (Addupsig Input)))))
     ((signal? Mtx)           (mul~ Mtx (Addupsig Input)))
     ((sigpack? Mtx)          (mul~ (Sigpar-fun Mtx Dur) (Addupsig Input)))
     ((envelope? Mtx)         (mul~ (Sigpar-fun Mtx Dur) (Addupsig Input)))

     ((equal? (car Mtx) 'Pan) 	   (Panfun (cadr Mtx) Dur (Addupsig Input)))
     ((equal? (car Mtx) 'Pan4) 	   (Pan4fun (cadr Mtx) Dur (Addupsig Input)))
     ((equal? (car Mtx) 'All) 
     	  (if (not (pair? Input)) (set! Input (list Input)))
	  (Addupsig (map (lambda (x) (Outmapin1 (cadr Mtx) Dur x)) Input)))
     ((equal? (car Mtx) 'Map)
     	          (if (not (pair? Input)) (set! Input (list Input)))
     	          (map (lambda (x y) (Outmapin1 x Dur y)) (cdr Mtx) Input))
     ((equal? (car Mtx) 'Struct)
     	      (map
     	       (lambda (x)
     	        (clean (Outmapin1 (list 'struct x) Dur Input))) (cdr Mtx)))
     ((equal? (car Mtx) 'Inpstruct)
     	         (map
     	          (lambda (x)
     	           (clean
	            (Outmapin1 (list 'inpstruct x) Dur Input))) (cdr Mtx)))

     (#t	 (map (lambda (x) (Addupsig (Outmapin1 x Dur Input))) Mtx))))

  (if (and (pair? aux) (= (length aux) 1) (signal? (car aux))) (car aux) aux)))

(define (Outmapin1 Mtx Dur Input) ;(prn "Outmapin1" Input Mtx)
  (define aux
    (cond
     ((null? Input)           (~ 0))
     ((null? Mtx)             Input)
     ((number? Mtx)           (cond
				 ((= Mtx 0)	(~ 0))
			         ((= Mtx 1)	(Addupsig Input))
				 (#t     (mul~ (~ Mtx) (Addupsig Input)))))
     ((signal? Mtx)           (mul~ Mtx (Addupsig Input)))
     ((sigpack? Mtx)          (mul~ (Sigpar-fun Mtx Dur) (Addupsig Input)))
     ((envelope? Mtx)         (mul~ (Sigpar-fun Mtx Dur) (Addupsig Input)))

     ((equal? (car Mtx) 'Pan) 	   (Panfun (cadr Mtx) Dur (Addupsig Input)))
     ((equal? (car Mtx) 'Pan4) 	   (Pan4fun (cadr Mtx) Dur (Addupsig Input)))
     ((equal? (car Mtx) 'All)
			(if (not (pair? Input)) (set! Input (list Input)))
			(Addupsig
			  (map
			     (lambda (x)
			             (Outmapin1 (cadr Mtx) Dur x)) Input)))
     ((equal? (car Mtx) 'Map)
			(if (not (pair? Input)) (set! Input (list Input)))
			(map
			    (lambda (x y)
			             (Outmapin1 x Dur y)) (cdr Mtx) Input))
     ((equal? (car Mtx) 'struct)
     			(if (pair? (cadr Mtx))
     				(map
				  (lambda (x)
				      (Outmapin1 x Dur Input)) (cadr Mtx))
				(Outmapin1 (cadr Mtx) Dur Input)))
     ((equal? (car Mtx) 'inpstruct)
		(if (not (pair? Input)) 	
		    (Outmapin1 (cadr Mtx) Dur Input)
		    (map (lambda (x) (Outmapin1 (cadr Mtx) Dur x)) Input)))

      (#t
          (if (not (pair? Input))
	    (Addupsig (map (lambda (x) (Outmapin1 x Dur Input)) Mtx))
	    (Addupsig (map (lambda (x y) (Outmapin1 x Dur y)) Mtx Input))))))

  (if (and (pair? aux) (= (length aux) 1) (signal? (car aux))) (car aux) aux))

--- NEW FILE: sp-sndpack-type.foo ---
(define make-sndpack)
(define sndpack?)
(define sndpack.name)
(define sndpack.channel)
(define sndpack.region)
(define sndpack.reverse)

(let ((sndpack-tag (vector 'sndpack)))

    (set! sndpack?
	(lambda (obj)
	    (and (pair? obj) (eq? (car obj) sndpack-tag))))

    (define (check-name arg)
        (if (or (snd? arg)
		(procedure? arg)
	        (string? arg)
		(symbol? arg)) arg #f))
    (define (check-chan arg)
    	(if (or (null? arg)
		(number? arg)
		(numerical? arg)) arg #f))
    (define (check-regn arg)
        (if (or (null? arg)
		(string? arg)
		(symbol? arg)
		(number? arg)
		(and (pair? arg)
		     (= (length arg) 2)
		     (numerical? arg))) arg #f))
    (define (check-rvrs arg)
    	(if (and arg (not (null? arg))) #t #f))

    (define (check-sndpack-fields fields)
      (let ((fld1 (car fields)) (fld2 (cadr fields))
            (fld3 (caddr fields)) (fld4 (car (last-pair fields))))
	 
	 (set! fld1 (check-name fld1))
	 (set! fld2 (check-chan fld2))
	 (set! fld3 (check-regn fld3))
	 (set! fld4 (check-rvrs fld4))
	 (if (and fld1
	 	  (or fld2
		      (null? fld2))
		  (or fld3
		      (null? fld3))) (list fld1 fld2 fld3 fld4) #f)))

    (define (check-sndpack args)
      (let ((flg #t) (aux))
	(if (sndpack? args)
		(list (sndpack.name args) (sndpack.channel args)
		      (sndpack.region args) (sndpack.reverse args))
	(if (> (length args) 4)
	    #f
	    (set! args (append args (make-list (- 4 (length args)) '())))
	    (set! args (check-sndpack-fields args))
	    args))))

    (set! make-sndpack
	(lambda args
	   (if (and (= (length args) 1)
	   	    (sndpack? (car args))) (car args)
	    (define aux (check-sndpack args))
	    (if (not aux) (error 'sndpack-type "Wrong Data : ~s" args)
	    	 (cons sndpack-tag aux)))))

    (set! sndpack.name    (lambda (obj) (list-ref (cdr obj) 0)))
    (set! sndpack.channel (lambda (obj) (list-ref (cdr obj) 1)))
    (set! sndpack.region  (lambda (obj) (list-ref (cdr obj) 2)))
    (set! sndpack.reverse (lambda (obj) (list-ref (cdr obj) 3)))
)
--- NEW FILE: sp-sigpack-type.foo ---
(define make-sigpack)
(define sigpack?)
(define sigpack.rfr)
(define sigpack.env)
(define sigpack.mod)
(define sigpack.cal)

(define set-sigpack.rfr)
(define set-sigpack.env)
(define set-sigpack.mod)
(define set-sigpack.cal)

(let ((sigpack-tag (vector 'sigpack)))

    (set! sigpack?
	(lambda (obj)
	    (and (pair? obj) (eq? (car obj) sigpack-tag))))

    (define (gudComp? arg)
      (if (or (signal? arg)
      	      (procedure? arg)
      	      (node? arg)
	      (sigpack? arg)
	      (check-cmplx arg)
	      (null? arg)
              (and (pair? arg)
      	           (= (length arg) 2)
	           (gudtyps? (car arg))
	           (gudtyps? (cadr arg)))) #t #f))

    (define (gudtyps? arg)
     (if (or  (number? arg)
     	      (equal? 'Jitter arg)
 	      (signal? arg)
 	      (sigpack? arg)
 	      (procedure? arg)
 	      (node? arg)
	      (check-cmplx arg)
	      (check-sigpack arg)) #t #f))

    (define (check-cmplx arg) (if (and (pair? arg)
    				       (procedure? (car arg))) arg #f))

    (define (check-rfr arg)
	(cond
	    ((null? arg)	'n)
	    ((number? arg)	arg)
	    ((signal? arg)	arg)
	    ((sigpack? arg)	arg)
	    ((procedure? arg)	arg)
	    ((node? arg)	arg)
	    ((check-cmplx arg)	arg)
	    (#t			#f)))
 
     (define (check-env arg)

        (cond
	    ((null? arg)		     		'n)
	    ((signal? arg)				arg)
	    ((sigpack? arg)				arg)
	    ((envelope? arg)				arg)
	    ((bpf? arg)					arg)
	    ((and (pair? arg)
		  (or (equal? 'env (car arg))
		      (equal? 'line (car arg))
		      (equal? 'expon (car arg))
		      (equal? 'make-bpf (car arg))
		      (equal? 'read-bpf (car arg))
		      (equal? 'bpf (car arg)))
		  (numerical? (cdr arg)))		arg)
	    ((envlike-pair? arg)			arg)
	    ((procedure? arg)				arg)
	    ((node? arg)				arg)
	    ((check-cmplx arg)				arg)
	    ((and (pair? arg)
	    	  (or (equal? 'mod (car arg))
		      (equal? 'pmod (car arg))
		      (equal? 'rmod (car arg))))	#f)
;	    ((pair? arg)				arg)
	    (#t						#f)))

    (define (check-mod obj)
    	(cond
	
	  ((null? obj)					'n)
	  ((sigpack? obj)				(list 'mod obj '()))
	  ((signal? obj)				(list 'mod obj '()))
	  ((procedure? obj)				(list 'mod obj '()))
	  ((node? obj)					(list 'mod obj '()))
	  ((check-cmplx obj)				(list 'mod obj '()))
	  ((and (pair? obj)
	  	(= (length obj) 4)
		(gudComp? (list (car obj) (cadr obj)))
		(gudComp? (cddr obj)))
			 (list 'mod (list (car obj) (cadr obj)) (cddr obj)))
	  ((and (pair? obj)
	  	(= (length obj) 2)
		(gudComp? (car obj))
		(gudComp? (cadr obj)))	   (list 'mod (car obj) (cadr obj)))
	  ((and (pair? obj)
	  	(equal? (car obj) 'mod)
		(= (length obj) 5)
		(gudComp? (list (cadr obj) (caddr obj)))
		(gudComp? (cdddr obj)))
		      (list 'mod (list (cadr obj) (caddr obj)) (cdddr obj)))
	  ((and (pair? obj)
	  	(equal? (car obj) 'mod)
		(= (length obj) 3)
		(gudComp? (cadr obj))
		(gudComp? (caddr obj)))					obj)
	  ((and (pair? obj)
	  	(equal? (car obj) 'pmod)
		(= (length obj) 3)
		(gudtyps? (cadr obj))
		(gudtyps? (caddr obj)))		  (list 'mod (cdr obj) '()))
	  ((and (pair? obj)
	  	(equal? (car obj) 'rmod)
		(= (length obj) 3)
		(gudtyps? (cadr obj))
		(gudtyps? (caddr obj)))		  (list 'mod '() (cdr obj)))
	  ((and (pair? obj)
	  	(equal? (car obj) 'mod)
		(= (length obj) 3)
		(pair? (cadr obj))
		(pair? (caddr obj))
		(equal? (car (cadr obj)) 'pmod)
		(equal? (car (caddr obj)) 'rmod)
		(gudComp? (cdr (cadr obj)))
		(gudComp? (cdr (caddr obj))))						
				       (list 'mod (cdadr obj) (cdaddr obj)))
	  ((and (pair? obj)
	  	(equal? (car obj) 'mod)
		(= (length obj) 2)
		(pair? (cadr obj))
		(equal? (car (cadr obj)) 'pmod)
		(gudComp? (cdr (cadr obj))))    (list 'mod (cdadr obj) '()))
	  ((and (pair? obj)
	  	(equal? (car obj) 'mod)
		(= (length obj) 2)
		(pair? (cadr obj))
		(equal? (car (cadr obj)) 'rmod)
		(gudComp? (cdr (cadr obj))))    (list 'mod '() (cdadr obj)))
	  (#t								#f)))

    (define (check-cal arg)
	(cond
	    ((null? arg)			'n)
	    ((node? arg)			arg)
	    ((procedure? arg)			arg)
	    ((and (pair? arg)
	    	 (equal? 'cal (car arg))
		 (or (node? (cadr arg))
		     (procedure? (cadr arg))))	(cadr arg))
	    (#t					#f)))

    (define (check-sigpack-fields fields numb)
      (let ((fld1 (car fields)) (fld2 (cadr fields))
      	    (fld3 (caddr fields)) (fld4 (cadddr fields)))
	(cond
	   ((= numb 1)
	    (cond
	      ((not (null? (car fld1)))
	      	      (list (car fld1) (car fld2)  (car fld3)   (car fld4)))
	      ((not (null? (cadr fld1)))
	      	      (list (car fld2) (cadr fld1) (car fld3)   (car fld4)))
	      ((not (null? (caddr fld1)))
	      	      (list (car fld2) (car fld3)  (caddr fld1) (car fld4)))))
	   ((= numb 2)
	    (cond
	      ((and (not (null? (car fld1)))
	   	    (not (null? (cadr fld2))))
	      	      (list (car fld1) (cadr fld2) (car fld3)   (car fld4)))
	      ((and (not (null? (car fld1)))
	   	    (not (null? (caddr fld2))))
	      	      (list (car fld1) (car fld3)  (caddr fld2) (car fld4)))
	      ((and (not (null? (cadr fld1)))
	   	    (not (null? (caddr fld2))))
	      	      (list (car fld3) (cadr fld1) (caddr fld2) (car fld4)))))
	   ((= numb 3)
	    (cond
	      ((and (not (null? (car fld1)))
	   	    (not (null? (cadr fld2)))
		    (not (null? (caddr fld3))))
	      	      (list (car fld1) (cadr fld2) (caddr fld3)  (car fld4)))
	      ((and (not (null? (car fld1)))
	   	    (not (null? (cadr fld2)))
		    (not (null? (cadddr fld3))))
	      	      (list (car fld1) (cadr fld2) (car fld4) (cadddr fld3)))
	      ((and (not (null? (car fld1)))
	   	    (not (null? (caddr fld2)))
		    (not (null? (cadddr fld3))))
	      	      (list (car fld1) (car fld4) (caddr fld2) (cadddr fld3)))
	      ((and (not (null? (cadr fld1)))
	   	    (not (null? (caddr fld2)))
		    (not (null? (cadddr fld3))))
	      	    (list (car fld4) (cadr fld1) (caddr fld2) (cadddr fld3)))))
	   (#t	  (list (car fld1) (cadr fld2) (caddr fld3) (cadddr fld4))))))


    (define (check-sigpack-arg arg i n pul)
      (let ((aux) (sgpk.rfr) (sgpk.env) (sgpk.mod) (sgpk.cal))
        (cond
	  ((= n 4)
	     (cond
		((= i 0)    (set! sgpk.rfr (check-rfr arg))
			    (if sgpk.rfr (list 0 (list sgpk.rfr '() '() '()))
				    #f))
		((= i 1)    (set! sgpk.env (check-env arg))
			    (if sgpk.env (list 1 (list '() sgpk.env '() '()))
				    #f))
		((= i 2)    (set! sgpk.mod (check-mod arg))
			    (if sgpk.mod (list 2 (list '() '() sgpk.mod '()))
				    #f))
		((= i 3)    (set! sgpk.cal (check-cal arg))
			    (if sgpk.cal (list 3 (list '() '() '() sgpk.cal))
				    #f))))
	  ((= n 3)
	    (cond
		((= i 0)    (set! sgpk.rfr (check-rfr arg))
			    (if sgpk.rfr (list 0 (list sgpk.rfr '() '() '()))
			      (set! sgpk.env (check-env arg))
			      (if sgpk.env (list 1 (list '() sgpk.env '() '()))
				            #f)))
		((= i 1)    (set! sgpk.env (check-env arg))
			    (if (and (= pul 0) sgpk.env)
			      (list 1 (list '() sgpk.env '() '()))
			      (set! sgpk.mod (check-mod arg))
			      (if sgpk.mod (list 2 (list '() '() sgpk.mod '()))
				            #f)))
		((= i 2)    (set! sgpk.mod (check-mod arg))
			    (if (and (= pul 1) sgpk.mod)
			      (list 2 (list '() '() sgpk.mod '()))
			      (set! sgpk.cal (check-cal arg)) 
			      (if sgpk.cal (list 3 (list '() '() '() sgpk.cal))
				            #f)))
		(#t	     (list 5 (list 'n 'n 'n 'n)))))
	  ((= n 2)
	    (cond
		((= i 0)    (set! sgpk.rfr (check-rfr arg))
			    (if sgpk.rfr (list 0 (list sgpk.rfr '() '() '()))
			      (set! sgpk.env (check-env arg))
			      (if sgpk.env (list 1 (list '() sgpk.env '() '()))
				            #f)))
		((= i 1)    (set! sgpk.env (check-env arg))
			    (if (and (= pul 0) sgpk.env)
			      (list 1 (list '() sgpk.env '() '()))
			      (set! sgpk.mod (check-mod arg))
			      (if sgpk.mod (list 2 (list '() '() sgpk.mod '()))
				            #f)))
		(#t	     (list 5 (list 'n 'n 'n 'n)))))
	  ((= n 1)
	    (if (= i 0)
	        (begin
			(set! sgpk.rfr (check-rfr arg))
			(if sgpk.rfr (list 0 (list sgpk.rfr '() '() '()))
			   (set! sgpk.env (check-env arg))
			   (if sgpk.env (list 1 (list '() sgpk.env '() '()))
			      (set! sgpk.mod (check-mod arg))
			      (if sgpk.mod (list 2 (list '() '() sgpk.mod '())) 
				                #f))))
		(list 5 (list 'n 'n 'n 'n)))))))

    (define (check-sigpack args)
      (let ((flg #t) (aux) (i -1) (numb)
      	    (sgpk.rfr) (sgpk.env) (sgpk.mod) (sgpk.cal) (pul -1))
        (if (or (not (pair? args))
		(and (pair? args)
		     (symbol? (car args)))) (set! args (list args)))
	(if (sigpack? args)
		(list (sigpack.rfr args) (sigpack.env args)
		      (sigpack.mod args) (sigpack.cal args))
	(set! numb (length args))
	(if (> numb 4)
	    #f
	    (set! args (append args (make-list (- 4 (length args)) '())))
	    (set! args (map
	    	        (lambda (x)
	    		 (set! i (1+ i))
	    		 (set! aux (check-sigpack-arg x i numb pul))
	    		 (if (not aux)
	    		    (set! flg #f)
	    		    (set! pul (car aux)) (cadr aux))) args))
	    (if flg (set! args (check-sigpack-fields args numb)))
	    (if (and flg args)
	       (begin
	    	(set! args (map (lambda (x) (if (equal? x 'n) '() x)) args))
		args)
		#f)))))

    (set! make-sigpack
	(lambda args
	   (if (and (= (length args) 1)
	   	    (sigpack? (car args))) (car args)
	    (define aux (check-sigpack args))
	    (if (not aux) (error 'sigpack-type "Wrong Data : ~a" args)
	    	          (cons sigpack-tag aux)))))

    (set! sigpack.rfr
	(lambda (obj) (if (sigpack? obj) (list-ref (cdr obj) 0)
		      (error 'SigPack ": ~a is Not a sigpack"obj))))
    (set! sigpack.env 
	(lambda (obj) (if (sigpack? obj) (list-ref (cdr obj) 1)
		      (error 'SigPack ": ~a is Not a sigpack"obj))))
    (set! sigpack.mod 
	(lambda (obj) (if (sigpack? obj) (list-ref (cdr obj) 2)
		      (error 'SigPack ": ~a is Not a sigpack"obj))))
    (set! sigpack.cal 
	(lambda (obj) (if (sigpack? obj) (list-ref (cdr obj) 3)
		      (error 'SigPack ": ~a is Not a sigpack"obj))))


 (set! set-sigpack.rfr
    (lambda (obj val)
     (make-sigpack val (sigpack.env obj) (sigpack.mod obj) (sigpack.val obj))))
 (set! set-sigpack.env
    (lambda (obj val)
     (make-sigpack (sigpack.rfr obj) val (sigpack.mod obj) (sigpack.val obj))))
 (set! set-sigpack.mod
    (lambda (obj val)
     (make-sigpack (sigpack.rfr obj) (sigpack.env obj) val (sigpack.val obj))))
 (set! set-sigpack.cal
    (lambda (obj val)
     (make-sigpack (sigpack.rfr obj) (sigpack.env obj) (sigpack.mod obj) val)))

)

--- NEW FILE: sp-patchgen-funs.foo ---
(define (SP-Entity Vars . Input)
  (let ((Body) (s1)
        (Type   (car Vars))
  	(Off    (cadr Vars))
    	(Dur    (car (cddr Vars)))
    	(Amp    (cadr (cddr Vars)))
    	(Mtxout (car (cddr (cddr Vars))))
    	(Mtxin  (cadr (cddr (cddr Vars))))
    	(Args   (cddr (cddr (cddr Vars))))
    	(Input  (if (null? (flatout Input)) '() (flatout Input))))

    (if (and (not (null? Args)) (= (length Args) 1)) (set! Args (car Args)))		
    (time Off
	(if (not (null? Input))
		(set! Input (Outmapin Mtxin Dur Input)))
	(set! Body (SP-Uncode Type Dur Args))
	(set! s1 ((car Body) (cdr Body) Input))

	(set! s1 (Outmapin Mtxout Dur s1))
	(Atten (Sigpar-fun Amp Dur) s1))))

(define (Atten Amp Input)
  (cond
    ((pair? Input)	(map (lambda (x) (Atten Amp x)) Input))
    (#t			(mul~ Amp Input))))
     
(define (SP-Component Vars Input)
   (let* ((Type (car Vars))
    	  (Dur  (cadr Vars))
    	  (Args (cddr Vars)))
    (set! Args (SP-Discuss Type Args Input))
    (if (or (equal? (car Args) Noise)
	    (equal? (car Args) Sndread))
			(apply (car Args) (cdr Args))
			(apply (car Args) (append (list Dur) (cdr Args))))))

(define (SP-Serial Vars Input)
   (set! Vars (if (not (pair? (car Vars))) (list Vars)
   					   (reverse Vars)))
   (for-each (lambda (x) (set! Input (SP-Entity x Input))) Vars)
   Input)

(define (SP-Parallel Vars Input)
   (if (not (pair? (car Vars))) (set! Vars (list Vars)))
   (if (and (pair? Input)
   	    (= (length Vars) (length Input)))
		(map (lambda (x y) (SP-Entity x y)) Vars Input)
		(map (lambda (x) (SP-Entity x Input)) Vars)))

(define (SP-Transmit Dur Input)
	Input)

;
(define (SP-context-aux Off Dur Chans Mtxout Mtxin Sp-data Input . Pflg)
   (let ((i 1) (s1)
   	 (Input  (cond ((not (pair? Input)) (list Input))
	 	       ((null? (flatout Input)) '())
		       (#t			Input))))
  (if (and (not (null? Pflg))
  	   (boolean? (car Pflg))) (set! Input (append Pflg Input)))
  (apply SP-context (append (list Off Dur Chans Mtxout Mtxin Sp-data) Input))))
;
(define (SP-context Off Dur Chans Mtxout Mtxin Sp-data . Input)
 (let ((i 1) (s1) (Pflg #f))
  (if (null? (flatout Input))
     (set! Input '())
     (if (boolean? (car Input))
	(begin
	    (set! Pflg (car Input))
	    (set! Input (cdr Input)))))
  (context Chans
   (time Off
     (if (abstraction? Sp-data) (set! Sp-data (compute-abstraction Sp-data)))
     (if (procedure? Sp-data) (set! Sp-data (Sp-data)))
     (if (not (null? Input))
          (begin
	    (set! Input (map (lambda (x) (Input-fun x Dur)) Input))
	    (set! Input (Outmapin Mtxin Dur Input))))
;     (prn " Creation of the Kernel-Patch ........................")
     (set! s1
       (if (not (null? Input))
          (begin
	     (if (not (pair? Input)) (set! Input (list Input)))
             (if (or (compound? (car Sp-data))
		     (symbol? (car Sp-data)))
		 (apply SP-Entity (append (list Sp-data) Input))
	         (map (lambda (x y) (SP-Entity x y)) Sp-data Input)))
           (if (or (compound? (car Sp-data))
	           (symbol? (car Sp-data)))
	         (SP-Entity Sp-data)
	         (map (lambda (x) (SP-Entity x)) Sp-data))))
     (set! s1 (Outmapin Mtxout Dur s1))
     (if (not (pair? s1)) (set! s1 (list s1)))
     (while (and (<= i Chans) (< i (+ 1 (length s1))))
        (if Pflg (output~ i (print~ (Addupsig (list-ref s1 (- i 1)))))
	         (output~ i (Addupsig (list-ref s1 (- i 1)))))
	(set! i (+ 1 i)))))))
;

(define (ParseMode Mode)
   (if (symbol? Mode) (set! Mode (symbol->string Mode)))
   (cond
	((string-ci=? Mode "Undo")		'Undo)
	((string-ci=? Mode "Save")		'Save)
	((string-ci=? Mode "Write")		'Write)
	((string-ci=? Mode "Punch")		'punch)
	((string-ci=? Mode "Blend")		'blend)
	((string-ci=? Mode "Save&Blend")	'Save&Blend)
	((string-ci=? Mode "Modify")		'Modify)
	(#t	(error 'SP-run "Unknown Mode ~s" Mode))))

(define (ParseType Type)
   (if (symbol? Type) (set! Type (symbol->string Type)))
   (cond
	((string-ci=? Type "Incremental")	'incremental)
	((string-ci=? Type "Float")		'float)
	((string-ci=? Type "Short")		'short)
	((string-ci=? Type "Long")		'long)
	((string-ci=? Type "Double")		'double)
	((string-ci=? Type "Char")		'char)
	(#t	(error 'SP-run "Unknown Snd-Type ~s" Type))))

(define (putimx filnam)
   (let ((aux (string->list filnam)))
     (set! aux (list->string (list-tail aux (- (length aux) 4))))
     (if (equal? aux ".imx") filnam (format #f "~a.imx" filnam))))

(define (SPrun-Undo filnam num)
   (let* ((filnam (make-sndname (putimx filnam)))
          (num (number->string num))
	  (zeros (make-string (- 4 (string-length num)) #\0))
	  (name (string-append filnam "/mix" zeros num))
	  (context (with-input-from-file
		    (string-append name "c") read-context))
	  (header (with-input-from-file (string-append name "t") read)))
	(define (field name)
	    (cadr (assq name header)))
	(run-task
	    (make-task
		(/ (field 'reference) (field 'srate))
		(/ (field 'offset) (field 'srate))
		filnam context 'blend
		(field 'srate) (field 'blocksize))
	    (/ (field 'duration) (field 'srate)) (- (field 'factor)))))

(define (SPrun-Modify filnam Lst)
   (let* ((filnam (make-sndname (putimx filnam)))
   	  (num (car Lst))
	  (Ls2 (clean (cdr Lst)))
          (num (number->string num))
	  (zeros (make-string (- 4 (string-length num)) #\0))
	  (name (string-append filnam "/mix" zeros num))
	  (context) (context2)
	  (header)
	  (factor) (offset) (aux))
	(if (symbol? (car Ls2))
		(set! Ls2 (list (list-head Ls2 2) (clean (list-tail Ls2 2)))))
	(define (field name)
	    (cadr (assq name header)))
	(if (or (assq 'offset Ls2)
		(assq 'off Ls2)
		(assq 'Offset Ls2)) (SPrun-Undo filnam (car Lst)))
	(set! context (with-input-from-file (string-append name "c") 
					    read-context))
	(set! header (with-input-from-file (string-append name "t") read))
	(set! aux (assq 'offset Ls2))
	(if (not aux) (set! aux (assq 'Offset Ls2)))
	(if (not aux) (set! aux (assq 'off Ls2)))
	(if aux (set! offset (+ (/ (field 'offset) (field 'srate)) (cadr aux)))
	        (set! offset (/ (field 'offset) (field 'srate))))
	(set! aux (assq 'factor Ls2))
	(if (not aux) (set! aux (assq 'Factor Ls2)))
	(if (not aux) (set! aux (assq 'amp Ls2)))
	(if aux (set! factor (cadr aux))
	        (set! factor (field 'factor)))
	(set! context2 (copy-context context))
	(run-task
	      (make-task
		  (/ (field 'reference) (field 'srate))
		  offset filnam context2 'blend
		  (field 'srate) (field 'blocksize))
	          (/ (field 'duration) (field 'srate)) factor)))

(define (SP-run Data . Args)
  (let ((Args (clean Args))
  	(Blk (foo-default-bsize)) (Dur)
	(foo:name (string-append "foo" (number->string (getpid))))
	(Filename)
	(Workfile) (FileRS)
   	(Mode 'punch) (Off 0) (Ref 0) (Sclr 1) (Nfctr 1)
	(Chns) (Type 'float) (SRat) (SRc)  
	(Offctxt) (Durctxt) (Chnctxt) (Pflg #t)
	(aux) (ctxt) (DUM) (strm) (tsk) (flg #t)
	(com (make-string 511)))

    (set! Filename foo:name)

    (if (and (not (null? Args))
             (symbol? (car Args))) (set! Args (list Args)))

    (set! DUM (assq 'Blocksize Args))	(if DUM (set! Blk (cadr DUM)))
    (set! DUM (assq 'Duration Args))	(if DUM (set! Dur (cadr DUM)))
    (set! DUM (assq 'Factor Args))	(if DUM (set! Sclr (cadr DUM)))
    (set! DUM (assq 'Filename Args))	(if DUM (set! Filename (cadr DUM)))
    (set! DUM (assq 'Mode Args))	(if DUM (set! Mode (cadr DUM)))
    (set! DUM (assq 'Normfactor Args))	(if DUM (set! Nfctr (cadr DUM)))
    (set! DUM (assq 'Offset Args))	(if DUM (set! Off (cadr DUM)))
    (set! DUM (assq 'Reference Args))	(if DUM (set! Ref (cadr DUM)))
    (set! DUM (assq 'Snd-Chns Args))	(if DUM (set! Chns (cadr DUM)))
    (set! DUM (assq 'Snd-Type Args))	(if DUM (set! Type (cadr DUM)))
    (set! DUM (assq 'Snd-SR Args))	(if DUM (set! SRat (cadr DUM)))
    (set! DUM (assq 'Task-SR Args))	(if DUM (set! SRc (cadr DUM)))
    (set! DUM (assq 'Print Args))	(if DUM (set! Pflg (cadr DUM)))
    (if (symbol? Filename) (set! Filename (symbol->string Filename)))
    (set! Mode (ParseMode Mode))
    (set! Type (ParseType Type))
    (cond
      ((equal? Mode 'Undo)
           (if (number? Data) (SPrun-Undo Filename Data)
	   		(error 'SP-run "Cannot Undo with this data ~a"Data)))
      ((equal? Mode 'Modify)
       	   (cond
	     ((pair? Data)   (SPrun-Modify Filename Data))
	     ((number? Data)
		   (set! Off (assq 'Offset Args))
		   (set! Sclr (assq 'Factor Args))
		   (if (or Off Sclr)
		      (SPrun-Modify Filename (list Data Off Sclr))
		      (error 'SP-run "Cannot Modify with this data ~a" Data)))
	     (#t (error 'SP-run "Cannot Modify with this data ~a" Data))))
      ((task? Data)
	   (if (null? Dur)
	      (error 'SP-run "Cannot run a task without Duration")
	      (if Pflg
	         (prn " Synthesizing = <<Duration Factor>> ==> " Dur Sclr))
	      (run-task Data Dur Sclr) #t))
      (#t
	 (set! ctxt
	   (if (context? Data) Data
	     (if (or (string? Data)
		     (symbol? Data)) (with-input-from-file Data read-context)
				     (apply SP-context Data))))
	 (if (or (equal? Mode 'Write)
	    	 (equal? Mode 'Save)
		 (equal? Mode 'Save&Blend))
	    (begin
	       (set! Workfile (string-append Filename ".ctxt"))
	       (set! strm (open-output-file Workfile))
	       (with-output-to-file (string-append Filename ".ctxt")
				    (lambda () (write-context ctxt)))
		(if (equal? Mode 'Save) (set! Mode 'punch))
		(if (equal? Mode 'Save&Blend) (set! Mode 'blend))))

	 (if (equal? Mode 'Write) #t
	    (set! aux (context-interval ctxt))
	    (set! Offctxt (car aux))
	    (set! Durctxt (cdr aux))
	    (set! Chnctxt (context-channels ctxt))
	    (if Pflg
	       (begin
	         (newline)
	         (prn " Context : (Offset Duration) NumofChans :"aux Chnctxt)))
	    (if (null? Dur)
	       (if Durctxt (set! Dur Durctxt)
		     (error 'SP-run "Can't run this task without Duration")))
	    (if (null? Chns) (set! Chns Chnctxt))
	    (if (null? SRc)
	       (if (not (null? SRat)) (set! SRc  SRat)
				      (set! SRc  (foo-default-srate))
				      (set! SRat (foo-default-srate))))

	    (set! Workfile
	      (make-sndname
	    	(if (equal? Type 'incremental)
		   (begin (set! Mode 'blend) (string-append Filename ".imx"))
		   Filename)))
	    (if (file-exists? Workfile)
	       (if (not (equal? Mode 'blend))
	          (if (or (equal? Filename foo:name)
	       	          (SP-Demand Workfile))
		     (begin
		        (system (string-append "rm -rf "Workfile))
                        (make-soundfile Workfile Type Chns SRat))
                     (set! flg #f)))
		(make-soundfile Workfile Type Chns SRat))

	    (if flg
	      (begin
	        (if Pflg
	           (prn " Making Task == <<Ref Off SRc Blk>> ==> "
		   					Ref Off SRc Blk))
	        (set! tsk (make-task Ref Off Workfile ctxt Mode SRc Blk))
	        (if Pflg
	           (prn " Synthesizing = <<Duration Factor>> ==> "Dur Sclr))
	        (run-task tsk Dur Sclr)
	        (if (and (equal? Type 'float)
	       		 (not (equal? Mode 'blend)))
	          (begin
		     (set! FileRS (string-append Filename ".rs.snd"))
		     (set! FileRS (make-sndname FileRS))
		     (sndnorm Workfile FileRS Nfctr)
		     (system (string-append "mv -f " FileRS " "Workfile)))))))
	 (kill-context ctxt)
	 Workfile))))

(define (SP-Demand Name)
   (let ((answer))
       (format #t "~s exists.  Overwrite? [y/n] "Name)
       (set! answer (read))
       (if (or (equal? answer 'y)
       	       (equal? answer 'yes)) #t #f)))

(define (SP-Uncode Type Dur Args)
  (if (not (pair? Args)) (set! Args (list Args)))
  (cond
    ((or (equal? Type SP-Parallel)
	 (equal? Type 'SP-Parallel)) (cons SP-Parallel Args))
    ((or (equal? Type SP-Serial)
	 (equal? Type 'SP-Serial))   (cons SP-Serial Args))    
    ((or (equal? Type SP-Transmit)
	 (equal? Type 'SP-Transmit)) (list SP-Transmit Dur))
    ((or (equal? Type 'SP-Component)
	 (equal? Type SP-Component)) (set! Args (clean Args))
	     			     (append
					(list SP-Component (car Args) Dur)
					(cdr Args)))
    ((or (equal? Type sine~)
	 (equal? Type 'sine)
	 (equal? Type 'Sine)
	 (equal? Type Sine))	(append (list SP-Component Sine Dur) Args))
    ((or (equal? Type fof~)
	 (equal? Type 'fof)
	 (equal? Type 'FOF)
	 (equal? Type 'Fof)
	 (equal? Type Fof))	(append (list SP-Component Fof Dur) Args))
    ((or (equal? Type noise~)
	 (equal? Type 'noise)
	 (equal? Type 'Noise)
	 (equal? Type Noise))	(append (list SP-Component Noise Dur) Args))
    ((or (equal? Type read-snd~)
	 (equal? Type 'read-snd)
	 (equal? Type 'sndread)
	 (equal? Type 'Sndread)
	 (equal? Type Sndread))	(append (list SP-Component Sndread Dur) Args))
    ((or (equal? Type lookup-snd~)
	 (equal? Type 'lookup-snd)
	 (equal? Type 'lookup)
	 (equal? Type 'Lookup)
	 (equal? Type Lookup))	(append (list SP-Component Lookup Dur) Args))
    ((or (equal? Type transp-snd~)
	 (equal? Type 'transp-snd)
	 (equal? Type 'sampler)
	 (equal? Type 'Sampler)
	 (equal? Type Sampler))	(append (list SP-Component Sampler Dur) Args))
    ((or (equal? Type c2pf~)
	 (equal? Type 'c2pf)
	 (equal? Type 'cfilter)
	 (equal? Type 'Cfilter)
	 (equal? Type Cfilter))	(append (list SP-Component Cfilter Dur) Args))
    ((or (equal? Type v2pf~)
	 (equal? Type 'v2pf)
	 (equal? Type 'filter)
	 (equal? Type 'vfilter)
	 (equal? Type 'Vfilter)
	 (equal? Type 'Filter)
	 (equal? Type Vfilter))	(append (list SP-Component Vfilter Dur) Args))
    ((or (equal? Type fve~)
	 (equal? Type 'fve)
	 (equal? Type 'FVE)
	 (equal? Type 'fvefilter)
	 (equal? Type 'FVEfilter)
	 (equal? Type FVEfilter)) (append (list SP-Component FVEfilter Dur)
		 				      Args))
    ((or (equal? Type c2p2zf~)
	 (equal? Type 'c2p2zf)
	 (equal? Type 'c2p2zfilter)
	 (equal? Type 'C2P2Zfilter)
	 (equal? Type 'cpzfilter)
	 (equal? Type 'CPZfilter)
	 (equal? Type CPZfilter)) (append (list SP-Component CPZfilter Dur)
		 				      Args))
    ((or (equal? Type reverb~)
	 (equal? Type 'reverb)
	 (equal? Type 'Reverb)
	 (equal? Type Reverb))	(append (list SP-Component Reverb Dur) Args))
    ((or (equal? Type 'Reverb8)
	 (equal? Type 'reverb8)
	 (equal? Type 'Revrb8)
	 (equal? Type Revrb8))	(append (list SP-Component Revrb8 Dur) Args))
    ((or (equal? Type 'Reverb12)
	 (equal? Type 'reverb12)
	 (equal? Type 'Revrb12)
	 (equal? Type Revrb12))	(append (list SP-Component Revrb12 Dur) Args))
    ((or (equal? Type 'Reverb16)
	 (equal? Type 'reverb16)
	 (equal? Type 'Revrb16)
	 (equal? Type Revrb16))	(append (list SP-Component Revrb16 Dur) Args))
    ((or (equal? Type bln~)
	 (equal? Type 'bln)
	 (equal? Type 'Bln)
	 (equal? Type Bln))	(append (list SP-Component Bln Dur) Args))
    ((or (equal? Type 'Module)
	 (equal? Type Module))	(append (list SP-Component Module Dur) Args))
    (#t		    	      (error 'SP-Patch "Unknwon SP-Element ~s"Type))))


(define (SP-Discuss Type Args Inp)
    (if (sigpack? Args) (set! Args (list Args)))
    (if (sndpack? Args) (set! Args (list Args)))
    (cond
	((or (equal? Type  sine~)
	     (equal? Type 'sine)
	     (equal? Type 'Sine)
	     (equal? Type  Sine))	(append (list Sine) Args))
	((or (equal? Type  fof~)
	     (equal? Type 'fof)
	     (equal? Type 'Fof)
	     (equal? Type 'FOF)
	     (equal? Type  Fof))	(append (list Fof) Args))
	((or (equal? Type noise~)
	     (equal? Type 'noise)
	     (equal? Type 'Noise)
	     (equal? Type Noise))	(list Noise Args))
	((or (equal? Type read-snd~)
	     (equal? Type 'read-snd)
	     (equal? Type 'sndread)
	     (equal? Type 'Sndread)
	     (equal? Type Sndread))	(if (not (null? Args))
	     					 (append (list Sndread) Args)
	    				 	 (append (list Sndread) Inp)))
	((or (equal? Type lookup-snd~)
	     (equal? Type 'lookup-snd)
	     (equal? Type 'lookup)
	     (equal? Type 'Lookup)
	     (equal? Type Lookup))	(append (list Lookup) Args))
	((or (equal? Type transp-snd~)
	     (equal? Type 'transp-snd)
	     (equal? Type 'sampler)
	     (equal? Type 'Sampler)
	     (equal? Type Sampler))	(append (list Sampler) Args))
	((or (equal? Type c2pf~)
	     (equal? Type 'c2pf)
	     (equal? Type 'cfilter)
	     (equal? Type 'Cfilter)
	     (equal? Type Cfilter)) (append (list Cfilter) Args (list Inp)))
	((or (equal? Type v2pf~)
	     (equal? Type 'v2pf)
	     (equal? Type 'filter)
	     (equal? Type 'vfilter)
	     (equal? Type 'Vfilter)
	     (equal? Type 'Filter)
	     (equal? Type Vfilter)) (append (list Vfilter) Args (list Inp)))
	((or (equal? Type fve~)
	     (equal? Type 'fve)
	     (equal? Type 'FVE)
	     (equal? Type 'fvefilter)
	     (equal? Type 'FVEfilter)
	     (equal? Type FVEfilter)) (append (list FVEfilter) Args
	     						      (list Inp)))
	((or (equal? Type c2p2zf~)
	     (equal? Type 'c2p2zf)
	     (equal? Type 'c2p2zfilter)
	     (equal? Type 'C2P2Zfilter)
	     (equal? Type 'cpzfilter)
	     (equal? Type 'CPZfilter)
	     (equal? Type CPZfilter))   (append (list CPZfilter) Args
	     							(list Inp)))
	((or (equal? Type reverb~)
	     (equal? Type 'reverb)
	     (equal? Type 'Reverb)
	     (equal? Type Reverb))	(append (list Reverb) Args (list Inp)))
	((or (equal? Type 'Reverb8)
	     (equal? Type 'reverb8)
	     (equal? Type 'Revrb8)
	     (equal? Type Revrb8))    (append (list Revrb8) Args (list Inp)))
	((or (equal? Type 'Reverb12)
	     (equal? Type 'reverb12)
	     (equal? Type 'Revrb12)
	     (equal? Type Revrb12))   (append (list Revrb12) Args (list Inp)))
	((or (equal? Type 'Reverb16)
	     (equal? Type 'reverb16)
	     (equal? Type 'Revrb16)
	     (equal? Type Revrb16))   (append (list Revrb16) Args (list Inp)))
	((or (equal? Type bln~)
	     (equal? Type 'bln)
	     (equal? Type 'Bln)
	     (equal? Type Bln))		(append (list Bln) Args))
	((or (equal? Type 'Module)
	     (equal? Type Module)) (if (not (null? Inp))
					(append (list Module) Args (list Inp))
					(append (list Module) Args)))
	(#t	(error 'SP-Component "Do not know this function ~s" Type))))


--- NEW FILE: sp-datapack-funs.foo ---
;==============================================================================
;	Sigpack Evaluation Functions
;==============================================================================

;
;;
;;;	Main Functionalities
;;
;

(define (Sigpar-fun Pack Dur)
  (let ((Dur (if (number? Dur) Dur 1)))

     (cond
	((null? Pack)       		(~ 0))
	((signal? Pack)     		Pack)
	((number? Pack)     		(~ Pack))

	((envelope? Pack)		(Envpack Pack Dur))
	((bpf? Pack)			(Envpack Pack Dur))
	((bpflike-pair? Pack)		(Envpack Pack Dur))
	((envlike-pair? Pack)		(Envpack Pack Dur))

	((procedure? Pack)		(Pack))
	((node? Pack)			(compute-node Pack))
	((and (pair? Pack)
	      (procedure? (car Pack)))	(Decode-spk Pack Dur))

	((sigpack? Pack)    		(Eval-sigpack Pack Dur))

	((pair? Pack)	 	(Eval-sigpack (apply make-sigpack Pack) Dur))

	(#t		(error 'Sigpar-fun "Wrong argument : ~s"Pack)))))

(define (Eval-sigpack Pack Dur)
  (let ((Rfr (Rfrpack (sigpack.rfr Pack) Dur))
  	(Env (Envpack (sigpack.env Pack) Dur))
	(Mod (Modpack (sigpack.mod Pack) Dur))
	(Cal (sigpack.cal Pack)))
    (if (not (null? Cal))
	(if (node? Cal) (apply compute-node (list Cal Rfr Env Mod))
	   		(apply Cal (list Rfr Env Mod)))
	(if (null? Mod) (set! Mod (~ 0)))
	(cond
	     ((and (null? Rfr)
		   (null? Env))	Mod)
	     ((null? Rfr)	(mul~ Env (add~ (~ 1) Mod)))
	     ((null? Env)	(mul~ Rfr (add~ (~ 1) Mod)))
	     (#t		(mul~ Rfr Env (add~ (~ 1) Mod)))))))

;
;;
;;;	Element Functionalities
;;
;


(define (Rfrpack Rfr Dur)
  (let ((aux))
    (cond
	((or (null? Rfr)
	     (signal? Rfr))	Rfr)
	((number? Rfr)		(~ Rfr))
	((sigpack? Rfr)		(Sigpar-fun Rfr Dur))
	((procedure? Rfr)	(Rfr))
	((node? Rfr)		(compute-node Rfr))
	((pair? Rfr)		(set! aux (Decode-spk Rfr Dur))
				(if aux aux '()))
	(#t			'()))))

(define (strch env dur)
  (let ((x0 (caar env)))
      (map (lambda (x) (cons (+ x0 (* dur (- (car x) x0))) (cdr x))) env)))

(define (Envpack Env Dur)
 (let ((aux))
  (if (or (null? Dur)
  	  (and (not (number? Dur))
	       (not (signal? Dur)))) (set! Dur 1.))
  (cond
    ((or (null? Env)
	 (signal? Env))		Env)
    ((sigpack? Env)		(Sigpar-fun Env Dur))
    ((procedure? Env)		(Env))
    ((node? Env)		(compute-node Env))
    ((signal? Dur)		(Envpack0 Env Dur))
    ((bpf? Env)			(transp-bpf~ Env (~ (/ 1 Dur))))
    ((envelope? Env)	  (send Env 'stretch Dur)
    			  (set! aux (read-bpf~ (make-bpf (send Env 'get-bpf))))
    			  (send Env 'stretch (/ 1 Dur)) 
    			  aux)
    ((envlike-pair? Env)  (set! Env (make-envelope Env))
    			  (send Env 'stretch Dur)
    			  (set! aux (read-bpf~ (make-bpf (send Env 'get-bpf))))
    			  (send Env 'stretch (/ 1 Dur)) 
    			  aux)
    ((and (pair? Env)
    	  (or (equal? (car Env) 'bpf)
	      (equal? (car Env) make-bpf)
	      (equal? (car Env) 'make-bpf)
	      (equal? (car Env) 'env)))
	  			(read-bpf~ (make-bpf (strch (cadr Env)  Dur))))
    ((and (pair? Env)
    	  (equal? (car Env) read-bpf~)
	  (bpf? (cadr Env)))	(transp-bpf~ Env (~ (/ 1. Dur))))
    ((and (pair? Env)
    	  (or (equal? (car Env) read-bpf~)
    	      (equal? (car Env) 'read-bpf)))
	  			(read-bpf~ (make-bpf (strch (cadr Env)  Dur))))
    ((and (pair? Env)
    	  (or (equal? 'line  (car Env))
	      (equal? line~  (car Env))))
;	  (= (length Env) 4)
;(;	  (numerical? (cdr Env)))
	  		  (line~ (cadr Env) (caddr Env) (* (cadddr Env) Dur)))
    ((and (pair? Env)
    	   (or (equal? 'expon  (car Env))
    	       (equal? expon~  (car Env))))
;	  (= (length Env) 4)
;(;	  (numerical? (cdr Env)))
	  		  (expon~ (cadr Env) (caddr Env) (* (cadddr Env) Dur)))
    ((bpflike-pair? Env)	  (read-bpf~ (make-bpf (strch Env  Dur))))

    ((pair? Env)		  (set! aux (Decode-spk Env Dur))
				  (if aux aux '()))
    (#t			          '()))))

(define (Envpack0 Env Dur)
  (set! Dur (div~ (~ 1) Dur))
  (cond
    ((bpf? Env)		(transp-bpf~ Env Dur))
    ((envelope? Env)	(transp-bpf~ (make-bpf (send Env 'get-bpf)) Dur))
    (#t		  	(transp-bpf~ (make-bpf Env) Dur))))

(define (Modpack Mod Dur)
    (cond
    	((or (null? Mod)
	     (signal? Mod))		Mod)
	((sigpack? Mod)			(Sigpar-fun Mod Dur))
	((procedure? Mod)		(Mod))
	((node? Mod)			(compute-node Mod))
	((and (pair? Mod)
	     (equal? (car Mod) 'mod)
	     (= (length Mod) 3))	(add~ (Perdmod (cadr Mod) Dur)
					      (Randmod (caddr Mod) Dur)))
	((and (pair? Mod)
	     (equal? (car Mod) 'mod)
	     (= (length Mod) 2))
	     	(cond
		   ((or (null? (cadr Mod))
	                (signal? (cadr Mod)))	(cadr Mod))
		   ((sigpack? (cadr Mod)) 	(Sigpar-fun (cadr Mod) Dur))
		   ((procedure? (cadr Mod)) 	((cadr Mod)))
		   (#t			    (let ((aux (Decode-spk Mod Dur)))
							  (if aux aux '())))))
	((pair? Mod)			(let ((aux (Decode-spk Mod Dur)))
							(if aux aux '())))
	(#t			'())))

(define (Perdmod Pack Dur)
    (cond
    	((null? Pack)		(~ 0))
	((signal? Pack) 	Pack)
	((number? Pack) 	(sine~ Pack))
	((sigpack? Pack)	(sine~ (Sigpar-fun Pack Dur)))
	((procedure? Pack)	(Pack))
	((node? Pack)		(compute-node Pack))
	((and (pair? Pack)
	      (procedure? (car Pack)))	(let ((aux (Decode-spk Pack Dur)))
					     (if aux aux '())))
	(#t			(let ((Amp (Sigpar-fun (car Pack)  Dur))
			      	      (Frq (Sigpar-fun (cadr Pack) Dur)))
				   (mul~ Amp (sine~ Frq))))))

(define (Randmod Pack Dur)
    (cond
    	((null? Pack)		(~ 0))
	((signal? Pack) 	Pack)
	((number? Pack) 	(bln~ Pack))
	((sigpack? Pack)	(bln~ (Sigpar-fun Pack Dur)))
	((procedure? Pack)	(Pack))
	((node? Pack)		(compute-node Pack))
	((and (pair? Pack)
	      (procedure? (car Pack)))	(let ((aux (Decode-spk Pack Dur)))
					     (if aux aux '())))
	((and (pair? Pack)
	      (equal? 'Jitter (cadr Pack))) (Jittermod Pack Dur))
	(#t			(let ((Amp (Sigpar-fun (car Pack) Dur))
			      	      (Frq (Sigpar-fun (cadr Pack) Dur)))
				   (mul~ Amp  (bln~ Frq 4 1993))))))

(define (Jittermod Pack Dur)
   (let ((Amp (Sigpar-fun (car Pack) Dur)))
       (mul~ Amp (~ 2.13) (div~ (add~ (bln~ (~ 20.134) 4 1993)
       				      (bln~ (~ 9.109) 4 1994)
       				      (bln~ (~ 0.821) 4 1995)) (~ 3)))))

(define (Decode-spk arg Dur)
  (let ((aux) (aux1) (aux0) (flg #t))
     (cond
	((equal? 'mod (car arg))    (apply Modpack (list arg Dur)))
	((equal? 'pmod (car arg))   (apply Modpack (list (list 'mod (cdr arg)) 
							Dur)))
	((equal? 'rmod (car arg))   (apply Modpack (list (cons 'mod
							(list '() (cdr arg)))
							  Dur)))
	((or (envelope? (car arg))
	     (bpf? (car arg))
	     (envlike-pair? (car arg))
	     (equal? 'env (car arg))
	     (equal? 'envelope (car arg))
	     (equal? 'bpf  (car arg))
	     (equal? make-bpf  (car arg))
	     (equal? read-bpf~  (car arg))
	     (equal? 'line (car arg))
	     (equal?  line~ (car arg))
	     (equal? 'expon (car arg))
	     (equal?  expon~ (car arg))) (apply Envpack (list arg Dur)))
	((or (equal? 'gate (car arg))
	     (equal? gate~ (car arg)))   (gate~ (Sigpar-fun (cadr arg) Dur)
	    				        (* (caddr arg) Dur)))
	((sigpack? arg)		    (Sigpar-fun arg Dur))
	((sndpack? arg)		    (Input-fun arg Dur))

     	((procedure? (car arg))	 (set! aux (map
				            (lambda (x)
				             (Decode-spk-sb x Dur)) (cdr arg)))
				 (apply (car arg) aux))
     	((node? (car arg))	 (set! aux (map
				            (lambda (x)
				             (Decode-spk-sb x Dur)) (cdr arg)))
				 (apply compute-node (cons (car arg) aux)))
	(#t			    #f))))

(define (Decode-spk-sb arg Dur)
     (cond
	((signal? arg)		arg)
	((number? arg)		arg)
;	((number? arg)		(~ arg))
	((envelope? arg)        (apply Envpack (list arg Dur)))
	((bpf? arg)	        (apply Envpack (list arg Dur)))
	((envlike-pair? arg)	(apply Envpack (list arg Dur)))
	((procedure? arg)	(arg))
	((node? arg)		(compute-node arg))
	((sigpack? arg)		(Sigpar-fun arg Dur))
	((sndpack? arg)		(Input-fun arg Dur))
	((pair? arg)		(Decode-spk arg Dur))
	(#t			arg)))

;==============================================================================
;	Sndpack Evaluation Functions
;==============================================================================
					   
(define (Sndpar-fun Pack)
   (cond
   	((snd? Pack)	    	Pack)
	((or (string? Pack)
	     (symbol? Pack)) 	(open-snd Pack))
	((procedure? Pack)	(Pack))
	((node? Pack)		(compute-node Pack))
	((sndpack? Pack)	(Eval-sndpack Pack))
	((pair? Pack)	     	(Eval-sndpack (apply make-sndpack Pack)))
	(#t		     (error 'Sndpar-fun "Wrong argument : ~s"Pack))))

(define (get-Sound Pack)
  (let ((Snd  (sndpack.name Pack))
  	(Chnl (sndpack.channel Pack)))

    (set! Snd
	    (cond
	        ((procedure? Snd)		(Snd))
		((or (string? Snd)
		     (symbol? Snd))		(open-snd Snd))
		((snd? Snd)			Snd)))
    (set! Chnl
	    (cond
		((number? Chnl)			Chnl)
		((and (pair? Chnl)
		      (numerical? Chnl))	Chnl)))

    (cond
	((number? Chnl)		(snd-extract Snd Chnl))
	((pair? Chnl)		(map (lambda (x) (snd-extract Snd x)) Chnl))
	(#t			Snd))))

(define (get-Region Region Segments)
  (let ((i -1))
    (cond
      ((and (pair? Region)
	    (numerical? Region)) (set! Region (cleanlist Region))
				 (list (car Region) (cadr Region)))
      ((string? Region)	         (for-each 
				   (lambda (x) 
				     (if (and (string? Region)
				     	      (equal? (car x) Region))
					      (set! Region (cdr x)))) Segments)
				 Region)
      ((number? Region)	         (for-each
				   (lambda (x)
				     (set! i (+ i 1))
				     (if (and (number? Region)
				     	      (= i Region))
					      (set! Region (cdr x)))) Segments)
				 Region)
      (#t			 '()))))

(define (Eval-sndpack Pack)
  (let* ((Snd (get-Sound Pack))
  	 (Region)
	 (Rvrsflg (sndpack.reverse Pack)))

   (set!  Region
   	(if (pair? Snd)
		(get-Region (sndpack.region Pack) (snd-segments (car Snd)))
		(get-Region (sndpack.region Pack) (snd-segments Snd))))

   (cond
      ((and  (null? Region)
      	     (not Rvrsflg)) Snd)
      ((not Rvrsflg)	    (if (snd? Snd)
				(apply snd-region
				    (cons Snd
					    (map (lambda (x) (abs x)) Region)))
				(map
				  (lambda (x)
				    (apply snd-region
				       (cons x
					  (map
					    (lambda (y)
					    	(abs y)) Region)))) Snd)))
      ((null? Region)	    (if (snd? Snd)
      				(snd-reverse Snd)
				(map (lambda (x) (snd-reverse x)) Snd)))
      (#t 
      	   (if (snd? Snd)
	   	(if (< (car Region) 0)
			(apply snd-region
				(cons (snd-reverse Snd)
					(map (lambda (y) (abs y)) Region)))
			(snd-reverse
			    (apply snd-region
			    	  (cons Snd
     					  (map (lambda (y) (abs y)) Region)))))
	   	(if (< (car Region) 0)
		    (map
		      (lambda (x)
		      	 (apply snd-region
			    (cons (snd-reverse x)
				    (map (lambda (y) (abs y)) Region)))) Snd)
		    (map
		      (lambda (x)
		      	(snd-reverse
			  (apply snd-region
			    (cons x
			      (map (lambda (y) (abs y)) Region))))) Snd)))))))

;==============================================================================
;	Inputpack Evaluation Functions
;==============================================================================
	      
(define (Input-fun Pack Dur)
  (let ((Snd))
    (cond
      ((signal? Pack)			Pack)
      ((sigpack? Pack)			(Sigpar-fun Pack Dur))
      ((procedure? Pack)		(Pack))
      ((node? Pack)			(compute-node Pack))
      ((and (pair? Pack)
      	    (procedure? (car Pack)))	(Decode-spk Pack Dur))

      ((and (pair? Pack)
            (or  (equal? 'dirac (car Pack))
      	         (equal? dirac~ (car Pack)))
	    (number? (cadr Pack)))		(dirac~ (cadr Pack)))
      ((and (pair? Pack)
      	    (or (equal? 'noise (car Pack))
      	        (equal? noise~ (car Pack)))
	    (number? (cadr Pack)))		(noise~ (cadr Pack)))
      ((or (equal? 'noise Pack)
      	   (equal? 'Noise Pack)
           (equal? noise~ Pack))		(noise~))

      ((snd? Pack)	(read-snd~ Pack))
      ((sndpack? Pack)	(set! Snd (Sndpar-fun Pack))
      			(if (pair? Snd)
			    (apply add~ (map (lambda (x) (read-snd~ x)) Snd))
			    (read-snd~ Snd)))
      ((string? Pack)   (read-snd~ (Sndpar-fun Pack)))
      ((symbol? Pack)	(read-snd~ (Sndpar-fun Pack)))
      ((and (pair? Pack)
      	    (or (snd? (car Pack))
	    	(string? (car Pack))
		(symbol? (car Pack)))) (set! Snd (Sndpar-fun Pack))
				       (if (pair? Snd)
			    		  (apply add~ 
					    (map
					       (lambda (x) (read-snd~ x)) Snd))
			    		  (read-snd~ Snd)))

      ((pair? Pack)	(Addupsig (map (lambda (x) (Input-fun x Dur)) Pack)))
      (#t		(~ 0)))))

[foo-cvs] foo/elkfoo/scm/control/envelope Makefile.am,NONE,1.1 envelope-functionalities.foo,NONE,1.1 envelope.foo,NONE,1.1

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

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

Added Files:
	Makefile.am envelope-functionalities.foo envelope.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/envelope/Makefile.am
# 2004 rumori

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

NULL = 

pkgenvelope_DATA = $(ELKFOO_ENVELOPE_FILES)

pkgenvelopedir = $(pkgdatadir)/control/envelope

ELKFOO_ENVELOPE_FILES = \
	envelope-functionalities.foo \
	envelope.foo \
	$(NULL)

--- NEW FILE: envelope-functionalities.foo ---
(define (envelope? obj)
    (if (and (instance? obj)
    	     (equal? (class-name obj) 'Envelope)) #t #f))


(define (make-envelope . args) 
  (let ((env (make-instance Envelope))  (i -1) (aux))
     (if (not (null? args))
       (for-each
	(lambda (x)
	 (set! i (+ 1 i))
	 (cond
	    ((and (pair? x) (equal? (car x) 'Descriptor))
				(send env 'set-Descriptor (cadr x)))
	    ((and (pair? x) (equal? (car x) 'Quantum))
				(send env 'set-Quantum (cadr x)))
	    ((and (pair? x) (or (equal? (car x) 'NumResults)
	    			(equal? (car x) 'Env-Node-NResults)))
				(send env 'set-Env-Node-NResults (cadr x)))
	    ((and (pair? x) (equal? (car x) 'transpose))
				(send env 'transpose (cadr x) (caddr x)))
	    ((and (pair? x) (equal? (car x) 'stretch))
				(send env 'stretch (cadr x)))
	    ((and (pair? x) (equal? (car x) 'Xrange))
				(send env 'set-Xrange (cadr x) (caddr x)))
	    ((and (pair? x) (or (equal? (car x) 'Length)
	    			(equal? (car x) 'Duration)))
				(send env 'set-Length (cadr x)))
	    ((or (equal? x 'xnorm)
	    	 (equal? x 'X-norm)) (send env 'X-norm))

	   ((and (pair? x)
	   	 (= i 0))	(send env 'set-Descriptor x))
	   ((and (number? x)
	   	 (= i 1))	(send env 'set-Quantum x))
	   ((and (number? x)
	   	 (= i 2))	(send env 'set-Env-Node-NResults x)))) args))
     env))

(define (Env-read env x . args)
   (if (envelope? env)
	(begin
	    (if (and (not (null? args))
	    	     (number? (car (flatten args))))
		     (send env 'set-Env-Node-NResults (car (flatten args))))
	    (send env 'Envread x))))

(define (Env-next env . args)
   (if (envelope? env)
	(begin
	    (if (and (not (null? args))
	    	     (number? (car (cleanlist args))))
		     (send env 'set-Env-Node-NResults (car (flatten args))))
	    (send env 'Envnext))))

(define (Env-bpf env . args)
   (if (envelope? env)
	(begin
	    (if (and (not (null? args))
	    	     (number? (car (cleanlist args))))
		     (send env 'set-Quantum (car (flatten args))))
	    (send env 'get-bpf))))

(define (Env-transpose env interval factor)
   (if (and (envelope? env)
   	    (number? interval)
	    (number? factor)) (begin (send env 'transpose interval factor)
	    			     env)
			      #f))

(define (Env-Xrange env xmin xmax)
   (if (and (envelope? env)
   	    (number? xmin)
	    (number? xmax)) (begin (send env 'set-Xrange xmin xmax)
	    			     env)
			      #f))

(define (Env-stretch env factor)
   (if (and (envelope? env)
	    (number? factor)) (begin (send env 'stretch factor) env)
			      #f))

(define (Env-length env lenz)
   (if (and (envelope? env)
	    (number? lenz)) (begin (send env 'set-Length lenz) env)
			      #f))

(define Env-duration Env-length)

(define (Env-xnorm env) (if (envelope? env) (begin (send env 'X-norm) env) #f))

;
;;
;;;
;;
;
(define (envlike-pair? lst)
  (if (not (pair? lst)) #f
     (let ((flg #t) (lnz (length lst)) (el))
        (if (= lnz 1) #f
	  (do ((c 0)) ((= c lnz) flg)
	      (set! el (nth lst c))
	      (if (or (not (pair? el))
	      	      (< (length el) 2))
	         (begin
	            (set! flg #f)
		    (set! c lnz))
	            (if (not (envelopelike-element? el c lnz))
		    	(begin (set! flg #f)
			       (set! c lnz))
			(set! c (1+ c)))))))))
;
(define (envelopelike-element? el indx lnz)
  (let ((elaux (Env-Decode (car el))))
    (if (and elaux
    	     (envelopelike-Xval? elaux indx lnz)
    	     (envelopelike-Yval? (cdr el) indx)) #t #f)))
;
(define (envelopelike-Xval? el indx lnz)
  (let ((val (car el))
    	(tip (cadr el))
	(limit (cddr el))
	(limit1) (limit2) (limval1) (limval2) (limtip1) (limtip2))

    (if (not (null? limit))
       (begin
     	(set! limit1 (car limit))
	(set! limit2 (cadr limit))
	(if (not (null? limit1)) (begin (set! limval1 (car limit1))
			  (set! limtip1 (cadr limit1))))
	(if (not (null? limit2)) (begin (set! limval2 (car limit2))
			  (set! limtip2 (cadr limit2))))))

     (cond
     	((= indx 0)	(if (and (number? val)
				 (equal? tip 'prop)
				 (null? limit))		#t #f))
	((= indx lnz)
	     (if (and (number? val)
		      (or (equal? tip 'abs+)
			  (equal? tip 'abs)
			  (equal? tip 'prop))
		      (or (null? limit)
			  (or (null? limit1)
			      (and (number? limval1)
				   (or (equal? limtip1 'abs+)
				       (equal? limtip1 'abs)
				       (equal? limtip1 'prop))))
			  (and (number? limval2)
			       (or (equal? limtip2 'abs+)
				   (equal? limtip2 'abs)
				   (equal? limtip2 'prop))))) #t #f))
	(#t		(if (and (number? val)
				 (or (null? limit)
				     (or (null? limit1)
				     	 (number? limval1))
				     (or (null? limit2)
				         (number? limval2)))) #t #f)))))

(define (envelopelike-Yval? el indx)
  (let ((Fdb (send (make-instance Node-Env) 'get-Function-db)))

    (cond
      ((not el)					#f)
      ((= indx 0)				#t)
      ((= (length el) 1)			#t)
      ((and (= (length el) 2)
	    (or (procedure? (cadr el))
	    	(number? (cadr el))
		(member (cadr el) Fdb)))	#t)
      (#t					#f))))

--- NEW FILE: envelope.foo ---
(require 'oops)

;
;;
;;;	Making the Node Subclass for the Envelope
;
;;;	Reassuring the two default functions
;;
;
(define (Env-linint xi xa ya xz yz)
    (cond
       ((= xi xa)	ya)
       ((= xi xz)	yz)
       (#t		(+ ya (* (- yz ya) (/ (- xi xa) (- xz xa)))))))

(define (Env-expint xi xa ya xz yz pnd)
    (cond
       ((= xi xa)	ya)
       ((= xi xz)	yz)
[...963 lines suppressed...]
	     ((or (equal? tipo 'abs+)
		  (equal? tipo 'abs-)
		  (pair? tipo)
		  (equal? tipo 'rel+)
		  (equal? tipo 'rel-)) (if (not (null? tip2)) (list z tip2)
			 		      (list (abs z) 'prop)))))) xilim))
      xival)))

(define (Env-get-tipo elem)
    (let ((xi (car elem)) (resl '()))
	(for-each
	    (lambda (x)
		(if (symbol? x)
		        (set! resl (cons x resl))
			(if (pair? x)
			    (if (symbol? (car x))
			    	(set! resl (cons x resl))
			        (set! resl (cons (cadr x) resl))))))
	    (Env-Decode xi))
	(reverse resl)))

[foo-cvs] foo/elkfoo/scm next-compat.foo,NONE,1.1 oops-patch.scm,NONE,1.1 Makefile.am,1.1,1.2 toplevel.foo.in,1.1,1.2

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

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

Modified Files:
	Makefile.am toplevel.foo.in 
Added Files:
	next-compat.foo oops-patch.scm 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: oops-patch.scm ---
(require 'oops)

;;;
;;; the following code fixes a problem with oops related
;;; to directly calling methods in a method body without
;;; employing send (something usefull to make the code
;;; more readable)
;;;
;;; the bug consisted in the fact that a directly called
;;; method would not be invoked with the proper, i.e.
;;; the particular instance's environment
;;;
;;; simple examples *seemed* to work properly since the
;;; hack-procedure-environment function used in the send
;;; function permanently changes the procedure environment
;;; of a method - but also most strange bugs were observed
;;; due to this behavior of the original implementation
;;; (instances got seemingly confused, because the directly
;;; called method held still an environment of the instance
;;; it was sent to last!)
;;;
;;; Gerhard Eckel, Frank Hasenbrink, GMD, August 6th, 1998
;;;

;;;
;;; global variable used to store an environment stack
;;; enabling nested direct method invokation
;;;
;;; used by define-method and send (see below)
;;;

(define oops-environment-stack (list))

;;;
;;; redefine define-method
;;;
;;; methods are encapsulated by a function with the same
;;; signature as the method, this function uses the top 
;;; environment of the environment stack as environment
;;; to call the actual method (with the hacked environment)
;;; this makes sure that no method can ever be called without
;;; an explicitly hacked environment
;;;

(define-macro (define-method class lambda-list . body)
  (if (not (pair? lambda-list))
      (error 'define-method "bad lambda list"))
  `(begin (check-class 'define-method ,class)
	  (let ((env (class-env ,class))
		(method (car ',lambda-list))
		(args (cdr ',lambda-list))
		(forms ',body))
	    (eval `(define ,method
		     (lambda ,args
		       (apply (hack-procedure-environment!
			       (lambda ,args ,@forms)
			       (car oops-environment-stack))
			      (list ,@args))))
		  env))))

;;;
;;; redefine send
;;;
;;; invoking a method involves now to push the instance's
;;; environment on the environment stack and to simply
;;; apply the method looked up in the class environment
;;; care has to be taken that the environment stack is
;;; properly popped after method invokation
;;;

(define (send instance msg . args)
  (check-instance 'send instance)
  (let ((class (eval (class-name instance))))
    (if (not (method-known? msg class))
	(error 'send
	       "message not understood: ~s"
	       `(,msg ,@args))
	(unwind-protect
	 (begin
	   ; first push the environment stack
	   (set! oops-environment-stack 
		 (cons (instance-env instance) oops-environment-stack))
	   ; invoke the method
	   (apply (lookup-method msg class) args))
	 ; always (also in case of an error in the apply) pop the stack
	 (set! oops-environment-stack (cdr oops-environment-stack))))))

;;;
;;; redefine call-init-methods 
;;;
;;; invokation of the initialize-instance method had to be
;;; adapted to new invokation style
;;;

(define (call-init-methods class instance args)
  (let ((called '()))
    (let loop ((class class))
      (if (not (null? (class-super class)))
	  (loop (eval (class-super class))))
	  (if (method-known? 'initialize-instance class)
	      (let ((method (lookup-method 'initialize-instance class)))
		(if (not (memq method called))
		    (begin
		      (unwind-protect
		       (begin
			 ; first push the environment stack
			 (set! oops-environment-stack 
			       (cons (instance-env instance) oops-environment-stack))
			 ; invoke the method
			 (apply method args))
		       ; always (also in case of an error in the apply) pop the stack
		       (set! oops-environment-stack (cdr oops-environment-stack)))
		      (set! called (cons method called)))))))))


;;;
;;; example
;;;
;;; this code doesn't work with the original implementation because
;;; the instance variable x could not be seen in the method bar
;;; because it was called with the environment it was defined
;;; in and not with the one of i1 (since send is not used)
;;;

;(define-class c1 (instance-vars (x 10)))

;(define-method c1 (initialize-instance . args)
;  (print args))

;(define-method c1 (foo)
;  (print 'foo)
;  (bar)) ; instead of (send self 'bar)

;(define-method c1 (bar)
;  (print 'bar)
;  (print x))

;(define i1 (make-instance c1 (x 11)))

;(send i1 'foo)

Index: toplevel.foo.in
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/toplevel.foo.in,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** toplevel.foo.in	7 Aug 2004 21:25:05 -0000	1.1
--- toplevel.foo.in	7 Aug 2004 22:53:00 -0000	1.2
***************
*** 180,207 ****
        (exit)))
  
! ;; load init
! ; (if (feature? 'context)
! ;     (begin
! ;       (load "initialize.foo")
  
! ;       ;; system wide defaults
! ;       (if (file-exists? "/etc/foo/init.foo")
! ; 	  (load "/etc/foo/init.foo"))
  
! ;       ;; user defaults (backwards compat)
! ;       (if (file-exists? (tilde-expand "~/.initfoo"))
! ; 	  (load "~/.initfoo"))
! ;       ;; wd defaults (backwards compat)
! ;       (if (and (not (string=? (getenv "HOME") (getwd)))
! ;  	       (file-exists? ".initfoo"))
! ; 	  (load ".initfoo"))
  
! ;       ;; user defaults
! ;       (if (file-exists? (tilde-expand "~/.foo/init.foo"))
! ; 	  (load "~/.foo/init.foo"))
! ;       ;; wd defaults
! ;       (if (file-exists? ".init.foo")
! ; 	  (load ".init.foo"))))
  
  (if (not (null? (command-line-args)))
      (if (file-exists? (car (command-line-args)))
--- 180,215 ----
        (exit)))
  
! ;; std list of initialization files
! (define foo-init-files
!   (list "tools/foo-tools.foo"
! 	"control/foo-control.foo"))
  
! ;; load customization files
! (if (feature? 'elkfoo)
!     (begin
  
!       ;; system wide defaults
!       (if (file-exists? "/etc/foo/init.foo")
! 	  (load "/etc/foo/init.foo"))
  
!       ;; user defaults (backwards compat)
!       (if (file-exists? (tilde-expand "~/.initfoo"))
! 	  (load "~/.initfoo"))
!       ;; wd defaults (backwards compat)
!       (if (and (not (string=? (getenv "HOME") (getwd)))
!  	       (file-exists? ".initfoo"))
! 	  (load ".initfoo"))
! 
!       ;; user defaults
!       (if (file-exists? (tilde-expand "~/.foo/init.foo"))
! 	  (load "~/.foo/init.foo"))
!       ;; wd defaults
!       (if (file-exists? ".init.foo")
! 	  (load ".init.foo"))))
  
+ ;; load init files
+ (map load foo-init-files)
+ 
+ ;; scripting
  (if (not (null? (command-line-args)))
      (if (file-exists? (car (command-line-args)))
***************
*** 215,217 ****
--- 223,229 ----
  	  (exit))))
  
+ (provide 'foo)
+ 
  (the-top-level)
+ 
+ ;; EOF

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/Makefile.am,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Makefile.am	7 Aug 2004 21:25:05 -0000	1.1
--- Makefile.am	7 Aug 2004 22:53:00 -0000	1.2
***************
*** 6,10 ****
  NULL = 
  
! SUBDIRS = kernel # control
  
  pkgdata_DATA = $(FOO_FILES)
--- 6,10 ----
  NULL = 
  
! SUBDIRS = kernel tools control
  
  pkgdata_DATA = $(FOO_FILES)
***************
*** 12,15 ****
--- 12,17 ----
  FOO_FILES = \
  	toplevel.foo \
+ 	next-compat.foo \
+ 	oops-patch.scm \
  	$(NULL)
  

--- NEW FILE: next-compat.foo ---
;; foo-2.1 (NeXTStep) compatability for foo

(define foo-default-soundfile-format 'short)
(define foo-default-soundfile-filetype 'snd)
(define foo-default-soundfile-extension ".snd")

(define (create-soundfile name format channels samplingrate . commentary)
  (set! name (tilde-expand name))
  (if (file-exists? name)
      (system (string-append "rm -rf " name)))
  (foo:make-soundfile name format channels samplingrate foo-default-soundfile-filetype))
 
(define (make-soundfile name format channels samplingrate . commentary)
  (set! name (tilde-expand name))
  (foo:make-soundfile name format channels samplingrate foo-default-soundfile-filetype))

(define-macro (synt c d s n f . e)
  `(foo:synthesize ,c ,d ,s ,n ,f foo-default-soundfile-filetype (lambda () ,@e)))

(provide 'next-compat)

[foo-cvs] foo/elkfoo/scm/control Makefile.am,NONE,1.1 init-control.foo,NONE,1.1

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

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

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

--- NEW FILE: init-control.foo ---
;;; -*-Scheme-*-
;;;

;; init-control.foo

(define (global-load file)
  (load file (global-environment)))

(require 'oops)
(require 'struct)

(if (not (feature? 'foo-tools))
    (global-load "tools/init-tools.foo"))

;; need this?
(global-load "oops-patch.scm")

(global-load "control/interface-lib/sp-sigpack-type.foo")
(global-load "control/interface-lib/sp-sndpack-type.foo")
(global-load "control/interface-lib/sp-datapack-funs.foo")
(global-load "control/interface-lib/sp-components.foo")
(global-load "control/interface-lib/sp-inoutmatrix.foo")
(global-load "control/interface-lib/sp-patchgen-funs.foo")

(global-load "control/abstraction/var-type.foo")
(global-load "control/abstraction/funx-type.foo")
(global-load "control/abstraction/hier-type.foo")
(global-load "control/abstraction/comp-type.foo")
(global-load "control/abstraction/abstraction.foo")
(global-load "control/abstraction/abstr-functlity.foo")
    
(global-load "control/node/node.foo")
(global-load "control/node/node-functionalities.foo")
(global-load "control/node/node-function-database.foo")

(global-load "control/envelope/envelope.foo")
(global-load "control/envelope/envelope-functionalities.foo")

(global-load "control/processes/process.foo")
(global-load "control/processes/scheduler.foo")

(provide 'foo-control)

;; EOF

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

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

NULL = 

SUBDIRS = \
	abstraction \
	envelope \
	interface-lib \
	node \
	processes \
	$(NULL)

pkgcontrol_DATA = $(ELKFOO_CONTROL_FILES)

pkgcontroldir = $(pkgdatadir)/control

ELKFOO_CONTROL_FILES = \
	init-control.foo \
	$(NULL)

[foo-cvs] foo/elkfoo/scm/control/processes - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/control/processes added to the repository

[foo-cvs] foo/elkfoo/scm/control/node - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/control/node added to the repository

[foo-cvs] foo/elkfoo/scm/control/interface-lib - New directory

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

Update of /cvsroot/foo/foo/elkfoo/scm/control/interface-lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6276/interface-lib

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/control/interface-lib added to the repository

[foo-cvs] foo/elkfoo/scm/control/envelope - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/control/envelope added to the repository

[foo-cvs] foo/elkfoo/scm/control/abstraction - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/control/abstraction added to the repository

[foo-cvs] foo/elkfoo/scm/control - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/control added to the repository

[foo-cvs] foo/elkfoo/scm/tools/util - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/tools/util added to the repository

[foo-cvs] foo/elkfoo/scm/tools/mixsnd - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/tools/mixsnd added to the repository

[foo-cvs] foo/elkfoo/scm/tools - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/tools added to the repository

[foo-cvs] foo/elkfoo/include Makefile.am,1.2,1.3

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

Update of /cvsroot/foo/foo/elkfoo/include
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27469

Modified Files:
	Makefile.am 
Log Message:
cleaned up

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/include/Makefile.am,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Makefile.am	5 Aug 2004 18:57:41 -0000	1.2
--- Makefile.am	7 Aug 2004 21:35:11 -0000	1.3
***************
*** 6,25 ****
  NULL = 
  
  pkgincludedir = @ELK_INC_DIR@
  extensionsdir = $(pkgincludedir)/extensions
  
- # we should have a complete elkfoo.h here
  extensions_HEADERS = \
  	elkfoo.h
  	$(NULL)
- 
- # noinst_HEADERS = \
- # 	bpf.h \
- # 	context.h \
- # 	module.h \
- # 	pointer.h \
- # 	signals.h \
- # 	snd.h \
- # 	task.h \
- # 	tell.h \
- # 	$(NULL)
--- 6,15 ----
  NULL = 
  
+ # integrate with elk?
  pkgincludedir = @ELK_INC_DIR@
+ 
  extensionsdir = $(pkgincludedir)/extensions
  
  extensions_HEADERS = \
  	elkfoo.h
  	$(NULL)

[foo-cvs] foo/elkfoo/scm/kernel Makefile.am,NONE,1.1 elkfoo.scm,NONE,1.1

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

Update of /cvsroot/foo/foo/elkfoo/scm/kernel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26305

Added Files:
	Makefile.am elkfoo.scm 
Log Message:
initial checkin: now belongs to elkfoo.la.  install paths dependent on --xxxable-elk-integration option

--- NEW FILE: elkfoo.scm ---
;;; -*-Scheme-*-
;;;
;;; The Scheme layer of the elkfoo extension.

(require 'elkfoo.la)

;;;
;;; time-orig
;;;
(unless (bound? '*time-orig*)
	(define *time-orig* seconds)
	(define seconds *time-orig*))

;;;
;;; bpf
;;;

(define bpf? foo:bpf?)
(define make-bpf foo:make-bpf)
(define bpf-offset foo:bpf-offset)
(define bpf-length foo:bpf-length)
(define bpf-reversed? foo:bpf-reversed?)
(define bpf-type foo:bpf-type)
(define bpf-context foo:bpf-context)
(define bpf-pointer foo:bpf-pointer)
;; (define bpf-region foo:bpf-region)
;; (define bpf-reverse foo:bpf-reverse)

;;;
;;; context
;;;

(define context? foo:context?)
(define make-context foo:make-context)
(define debug-context foo:debug-context)
(define kill-context foo:kill-context)
(define kill-all-contexts foo:kill-all-contexts)
(define context-channels foo:context-channels)
(define context-locked? foo:context-locked?)

(define (current-context)
  (if (not foo:current-context)
      (error 'current-context "there is no current context")
      foo:current-context))

(define (with-context context thunk)
  (fluid-let ((foo:current-context context)) (thunk)))

(define-macro (context channels . expressions)
  `(if (not (integer? ,channels))
       (error 'context "wrong argument type ~s (expected integer)"
	      (type ,channels))
       (with-context (make-context ,channels)
		     (lambda () ,@expressions (current-context)))))

(define write-context foo:write-context)
(define read-context foo:read-context)
(define copy-context foo:copy-context)
(define context-interval foo:context-interval)

;;;
;;; defaults
;;;

(define foo-default-taps foo:default-taps)
(define set-foo-default-taps! foo:set-default-taps!)
(define foo-default-srate foo:default-srate)
(define set-foo-default-srate! foo:set-default-srate!)
(define foo-default-bsize foo:default-bsize)
(define set-foo-default-bsize! foo:set-default-bsize!)

(define foo-default-soundfile-format 'short)
(define foo-default-soundfile-filetype 'aiff)
(define foo-default-soundfile-extension ".aiff")

(define foo-default-play-command "sndfile-play")
(define foo-default-edit-command "snd")

;;;
;;; foofun
;;;

(define shelfing-coefs foo:shelfing-coefs)

;;;
;;; module
;;;

(define module? foo:module?)
(define make-module foo:make-module)
(define module-type foo:module-type)
(define module-context foo:module-context)
(define module-pointer foo:module-pointer)

;;;
;;; modules
;;;

(define add~ foo:make-add)
(define bln~ foo:make-bln)
(define c2pf~ foo:make-c2pf)
(define c2p2zf~ foo:make-c2p2zf)
(define cbiquad~ foo:make-cbiquad)
(define ~ foo:make-constant)
(define diff~ foo:make-diff)
(define dirac~ foo:make-dirac)
(define div~ foo:make-div)
(define expon~ foo:make-expon)
(define fof~ foo:make-fof)
(define fve~ foo:make-fve)
(define gate~ foo:make-gate)
(define integ~ foo:make-integ)
(define line~ foo:make-line)
(define lookup-snd~ foo:make-lookup-snd)
(define mul~ foo:make-mul)
(define neg~ foo:make-neg)
(define noise~ foo:make-noise)
(define sine~ foo:make-sine)
(define osc~ foo:make-osc)
(define output~ foo:make-output)
(define play~ foo:make-play)
(define read-bpf~ foo:make-read-bpf)
(define read-snd~ foo:make-read-snd)
(define sqrt~ foo:make-sqrt)
(define reverb~ foo:make-reverb)
(define reverb8~ foo:make-reverb8)
(define revout~ foo:make-revout)
(define sub~ foo:make-sub)
(define transp-bpf~ foo:make-transp-bpf)
(define transp-snd~ foo:make-transp-snd)
(define v2pf~ foo:make-v2pf)

(define (print~ s . commentary)
  (tell (foo:context-pointer (current-context)) 'invalidatePrint)
  (if (not (null? commentary))
      (format #t "~a:~%" (car commentary)))
  (tell (foo:module-pointer (signal-module s)) 'print) s)

;;;
;;; math modules
;;;

(define abs~ foo:make-abs)
(define exp~ foo:make-exp)
(define log~ foo:make-log)
(define log10~ foo:make-log10)
(define sqrt~ foo:make-sqrt)
(define pow~ foo:make-pow)
(define min~ foo:make-min)
(define max~ foo:make-max)

;;;
;;; signal
;;;

(define signal? foo:signal?)
(define signal foo:signal)
(define signal-length foo:signal-length)
(define signal-ref foo:signal-ref)
(define signal->list foo:signal->list)
(define signal-terminal? foo:signal-terminal?)
(define signal-mono? foo:signal-mono?)
(define signal-constant? foo:signal-constant?)
(define signal-constant-value foo:signal-constant-value)
(define signal-module foo:signal-module)
(define signal-make-terminal foo:signal-make-terminal)

;;;
;;; snd
;;;

(define snd? foo:snd?)
(define open-snd foo:open-snd)
(define snd-name foo:snd-name)
(define snd-format foo:snd-format)
(define snd-channels foo:snd-channels)
(define snd-channel foo:snd-channel)
(define snd-srate foo:snd-srate)
(define snd-offset foo:snd-offset)
(define snd-length foo:snd-length)
(define snd-reversed? foo:snd-reversed?)
(define snd-type foo:snd-type)
(define snd-context foo:snd-context)
(define snd-pointer foo:snd-pointer)
(define snd-segments foo:snd-segments)
(define snd-region foo:snd-region)
(define snd-reverse foo:snd-reverse)
(define snd-extract foo:snd-extract)
(define snd-minimum foo:snd-minimum)
(define snd-maximum foo:snd-maximum)
(define snd-absolute-maximum foo:snd-absolute-maximum)
(define snd-filetype foo:snd-filetype)

(define (snd-info s)
  (format #t "name     : ~a~%" (snd-name s))
  (format #t "format   : ~a~%" (snd-format s))
  (format #t "srate    : ~a~%" (snd-srate s))
  (format #t "filetype : ~a~%" (snd-filetype s))
  (if (> (snd-channels s) 1)
      (format #t "channels : ~a~%" (snd-channels s))
      (format #t "channel  : ~a~%" (snd-channel s)))
  (if (not (= 0 (snd-offset s)))
      (format #t "offset   : ~a~%" (snd-offset s)))
  (format #t "length   : ~a~%" (snd-length s)))

(define (number-of-open-soundfiles)
  (display "FIXME: this function is not yet implemented"))
;;    (tell 'FileHandle 'descriptorCount))


;;;
;;; soundfile
;;;


(define soundfile-format foo:soundfile-format)
(define soundfile-channels foo:soundfile-channels)
(define soundfile-srate foo:soundfile-srate)
(define soundfile-length foo:soundfile-length)
(define soundfile-filetype foo:soundfile-filetype)
(define soundfile-play foo:soundfile-play)


(define (make-soundfile name format channels samplingrate . filetype)
  (set! name (tilde-expand name))
  (if (null? filetype)
      (set! filetype foo-default-soundfile-filetype)
      (set! filetype (car filetype)))
  (foo:make-soundfile name format channels samplingrate filetype))


(define (create-soundfile name format channels samplingrate . filetype)
  (set! name (tilde-expand name))
  (if (file-exists? name)
      (system (string-append "rm -rf " name)))
  (if (null? filetype)
      (set! filetype foo-default-soundfile-filetype)
      (set! filetype (car filetype)))
  (foo:make-soundfile name format channels samplingrate filetype))


;;;
;;; system
;;;

(define (foo:test-file-dir)
  (let ((dir (getenv "SFDIR")))
    (if dir
	dir
	(string-append "/tmp/" (getenv "USER")))))

(define (foo:test-file-name)
  (string-append
   (foo:test-file-dir)
   "/foo"
   (number->string (getpid))
   foo-default-soundfile-extension))

(define (foo:cleanup)
  (let ((test-file (foo:test-file-name)))
    (if (file-exists? test-file)
	(begin
					;(format #t "removing ~a~%" test-file)
	  (system (string-append "rm " test-file))))))

(define (quit)
  (foo:cleanup)
  (exit))

(define test-file-dir foo:test-file-dir)
(define test-file-name foo:test-file-name)

(define (foo:string-index aString aCharacter)
  (let ((len (string-length aString)))
    (define (loop n)
      (if (>= n len)
	  #f
	  (if (eq? (string-ref aString n) aCharacter)
	      n
	      (loop (1+ n)))))
    (loop 0)))

(define (foo:string-rindex aString aCharacter)
  (let ((len (string-length aString)))
    (define (loop n)
      (if (< n 0)
	  #f
	  (if (eq? (string-ref aString n) aCharacter)
	      n
	      (loop (1- n)))))
    (loop (1- len))))


(define (foo:synthesize channels duration srate filename fileformat filetype thunk)
    (let ((c (make-context channels))
	  (d (substring filename 0 (foo:string-rindex filename #\/))))
	(if (not (file-exists? d))
	    (system (string-append "mkdir -p " d)))
	(if (file-exists? filename)
	    (system (string-append "rm " filename)))
	(make-soundfile filename fileformat channels srate filetype)
	(with-context c thunk)
	(let ((start 0) (finish 0) (done 0))
	    (define (pf filename n)
		(let ((s (number->string filename)))
		    (substring s 0 (min (string-length s) n))))
	    (set! start (seconds))
	    (set! done (run-task (make-task 0 0 filename c 'punch srate) duration))
	    (set! finish (seconds))
	    (format #t
		"len: ~as, tim: ~as, rtf: ~a, sr: ~aHz~%fil: ~a, fmt: ~a, typ: ~a"
		(pf done 7)
		(pf (- finish start) 7)
		(pf (/ (- finish start) done) 7)
		(pf srate 7) filename fileformat filetype))) #v)


(define-macro (syn c d . e)
  `(foo:synthesize ,c
		   ,d
		   (foo-default-srate)
		   (foo:test-file-name)
		   foo-default-soundfile-format
		   foo-default-soundfile-filetype
		   (lambda () ,@e)))

(define-macro (synt c d s n f t . e)
  `(foo:synthesize ,c ,d ,s ,n ,f ,t (lambda () ,@e)))

(define (play . name)
  (define (helper args)
    (if (null? args)
	'()
	(cons
	 " "
	 (cons
	  (if (string? (car args))
	      (car args)
	      (symbol->string (car args)))
	  (helper (cdr args))))))
  (system
   (apply
    string-append
    (cons
     (string-append foo-default-play-command " ")
     (if (null? name)
	 (list (foo:test-file-name))
	 (helper name))))))

(define (save file)
  (system (string-append "cp " (foo:test-file-name) " " file)))

(define (edit . name)
  (define (helper args)
    (if (null? args)
	""
	(string-append
	 " "
	 (if (string? (car args))
	     (car args)
	     (symbol->string (car args)))
	 (helper (cdr args)))))
  (system
   (string-append
    foo-default-edit-command
    " "
    (if (null? name)
	(foo:test-file-name)
	(helper name))
    " &")))

;;(define (edit)
;;  (system (string-append "open " (foo:test-file-name))))

;;;
;;; task
;;;

(define task? foo:task?)
(define make-task foo:make-task)
(define run-task foo:run-task)

;;;
;;; time
;;;

(define (current-time)
  (foo:context-time (current-context)))

(define (with-time offset thunk)
  (if (not (number? offset))
      (error 'with-time
	     "wrong argument type ~a (expected number)" (type offset)))
  (if (not (procedure? thunk))
      (error 'with-time
	     "wrong argument type ~a (expected procedure)" (type thunk)))
  (let ((context (current-context)))
    (dynamic-wind
	(lambda () (foo:context-push-time-frame context offset))
	thunk
	(lambda () (foo:context-pop-time-frame context)))))

(define-macro (time offset . expressions)
  `(with-time ,offset (lambda () ,@expressions)))

;;;
;;; testing
;;;

(define (sweep)
  (syn 2 3
       (output~ 1 (sine~ (expon~ 20 20000 3)))
       (output~ 2 (sine~ (expon~ 20000 20 3))))
  (play))

;;;
;;; misc
;;;

(define about foo:about)
(define version foo:version)

(provide 'elkfoo)

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

# $Id: Makefile.am,v 1.1 2004/08/07 21:26:11 rumori Exp $

NULL = 

pkgdata_DATA = $(ELKFOO_KERNEL_FILES)

# depending on elk-integration
pkgdatadir = @ELK_SCM_DIR@

ELKFOO_KERNEL_FILES = \
	elkfoo.scm \
	$(NULL)

[foo-cvs] foo/elkfoo/scm/kernel - New directory

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

Update of /cvsroot/foo/foo/elkfoo/scm/kernel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26124/kernel

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm/kernel added to the repository

[foo-cvs] foo/elkfoo/scm Makefile.am,NONE,1.1 toplevel.foo.in,NONE,1.1

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

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

Added Files:
	Makefile.am toplevel.foo.in 
Log Message:
initial checkin

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

# $Id: Makefile.am,v 1.1 2004/08/07 21:25:05 rumori Exp $

NULL = 

SUBDIRS = kernel # control

pkgdata_DATA = $(FOO_FILES)

FOO_FILES = \
	toplevel.foo \
	$(NULL)

# generate toplevel.foo
replace = sed \
	-e 's,@datadir\@,$(pkgdatadir),g' \
	-e 's,@ELKFOO_LIB_DIR\@,$(ELKFOO_LIB_DIR),g'

toplevel.foo: toplevel.foo.in
	rm -f toplevel.foo.tmp toplevel.foo
	$(replace) \
	    -e 's,@edited_input\@,toplevel.foo: generated from toplevel.foo.in by Makefile.am,' \
	    $(srcdir)/toplevel.foo.in > toplevel.foo.tmp
	mv toplevel.foo.tmp toplevel.foo

EXTRA_DIST = toplevel.foo.in

CLEANFILES = \
	toplevel.foo \
	toplevel.foo.tmp \
	$(NULL)

--- NEW FILE: toplevel.foo.in ---
;;; -*-Scheme-*-
;;;

;; @edited_input@

;; set load path according to installation
(begin
  (define foo-scm-path "@datadir@")
  (define foo-lib-path "@ELKFOO_LIB_DIR@")

  (define (add-to-load-path path)
    ;; don't add if not expanded by autoconf
    (if (> (string-length path) 1)
	;; if ./ at the beginning of load-path, keep it there
	(if (string=? (car load-path) ".")
	    (set! load-path
		  (cons (car load-path)
			(cons path
			      (cdr load-path))))
	    (set! load-path
		  (cons path load-path)))))

  (add-to-load-path foo-lib-path)
  (add-to-load-path foo-scm-path))

;;; requirements
(require 'unix)
(require 'oops)
(require 'struct)

(require 'elkfoo) ;; load the foo library

(autoload 'pp 'pp.scm)
(autoload 'apropos 'apropos.scm)
(autoload 'sort 'qsort.scm)
(autoload 'define-structure 'struct.scm)
(autoload 'describe 'describe.scm)
(autoload 'backtrace 'debug.scm)
(autoload 'inspect 'debug.scm)

;; readline support (depending on environment var)
(if (string? (getenv "ELK_READLINE"))
    (if (> (string-length (getenv "ELK_READLINE")) 1)
        (require 'readline.la)))

(if (feature? 'readline.la)
    (define foo-prompt-base "foo> "))

;; foo scripting
(define foo-script-file "") 
(define load-foo-script-file #f) 

;;; Read-eval-print loop and error handler (readline extension support)
(define ?)
(define ??)
(define ???)
(define !)
(define !!)
(define !!!)
(define &)

(define (rep-loop env)
  (define input)
  (define value)
  (let loop ()
    (set! ??? ??)
    (set! ?? ?)
    (set! ? &)
    ;;; X Windows hack
    (if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy))
	(display-flush-output dpy))

    (if (feature? 'readline.la)
	(if (> rep-level 0)
	    (readline-set-prompt (string-append
				  (format #f "~a-" rep-level)
				  foo-prompt-base))
	    (readline-set-prompt foo-prompt-base))
	(begin
	  (if (> rep-level 0)
	      (format #t "~a-" rep-level))
	  (display "foo> ")))

    (if load-foo-script-file
	(begin
	  (set! load-foo-script-file #f)
	  (load foo-script-file))
	(begin
	  (if (feature? 'readline.la)
	      (set! input (readline-read))
	      (set! input (read)))
	  (set! & input)
	  (if (not (eof-object? input))
	      (begin
		(set! value (eval input env))
		(set! !!! !!)
		(set! !! !)
		(set! ! value)
		(write value)
		(newline)
		(loop)))))))

(define rep-frames)
(define rep-level)

(set! interrupt-handler
  (lambda ()
    (format #t "~%\7Interrupt!~%")
    (let ((next-frame (car rep-frames)))
      (next-frame #t))))

(define-macro (push-frame control-point)
  `(begin
     (set! rep-frames (cons ,control-point rep-frames))
     (set! rep-level (1+ rep-level))))

(define-macro (pop-frame)
  '(begin
     (set! rep-frames (cdr rep-frames))
     (set! rep-level (1- rep-level))))

(define (error-print error-msg)
  (format #t "~s: " (car error-msg))
  (apply format `(#t ,@(cdr error-msg)))
  (newline))

(set! error-handler
  (lambda error-msg
    (error-print error-msg)
    (let loop ((intr-level (enable-interrupts)))
      (if (positive? intr-level)
	  (loop (enable-interrupts))))
    (let loop ()
      (if (call-with-current-continuation
	   (lambda (control-point)
	     (push-frame control-point)
	     (rep-loop (the-environment))
	     #f))
	  (begin
	    (pop-frame)
	    (loop))))
    (newline)
    (pop-frame)
    (let ((next-frame (car rep-frames)))
      (next-frame #t))))

(define top-level-environment (the-environment))

(define (top-level)
  (let loop ()
    ;;; Allow GC to free old rep-frames when we get here on "reset":
    (set! rep-frames (list top-level-control-point))
    (if (call-with-current-continuation
	 (lambda (control-point)
	   (set! rep-frames (list control-point))
	   (set! top-level-control-point control-point)
	   (set! rep-level 0)
	   (rep-loop top-level-environment)
	   #f))
	(loop))))

(define (the-top-level)
  (top-level)
  (newline)
  (if (feature? 'foo)
      (if (> (string-length foo-script-file) 0)
	  (begin
	    (if (bound? 'foo:cleanup)
		(foo:cleanup))
	    (exit))
	  (begin
	    (format #t "do you really want to exit foo? [ny] (n): ")
	    (if (equal? (read-char) #\y)
		(begin
		  (format #t "bye~%")
		  (if (bound? 'foo:cleanup)
		      (foo:cleanup))
		  (exit))
		(the-top-level))))
      (exit)))

;; load init
; (if (feature? 'context)
;     (begin
;       (load "initialize.foo")

;       ;; system wide defaults
;       (if (file-exists? "/etc/foo/init.foo")
; 	  (load "/etc/foo/init.foo"))

;       ;; user defaults (backwards compat)
;       (if (file-exists? (tilde-expand "~/.initfoo"))
; 	  (load "~/.initfoo"))
;       ;; wd defaults (backwards compat)
;       (if (and (not (string=? (getenv "HOME") (getwd)))
;  	       (file-exists? ".initfoo"))
; 	  (load ".initfoo"))

;       ;; user defaults
;       (if (file-exists? (tilde-expand "~/.foo/init.foo"))
; 	  (load "~/.foo/init.foo"))
;       ;; wd defaults
;       (if (file-exists? ".init.foo")
; 	  (load ".init.foo"))))

(if (not (null? (command-line-args)))
    (if (file-exists? (car (command-line-args)))
	(begin
	  (set! foo-script-file (car (command-line-args)))
	  (set! load-foo-script-file #t))
	(begin
	  (format #t "couldn't load foo script ~s\n" (car (command-line-args)))
	  (if (bound? 'foo:cleanup)
	      (foo:cleanup))
	  (exit))))

(the-top-level)

[foo-cvs] foo/elkfoo/scm - New directory

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

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

Log Message:
Directory /cvsroot/foo/foo/elkfoo/scm added to the repository

[foo-cvs] foo/elkfoo/src main.c,1.2,1.3

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

Update of /cvsroot/foo/foo/elkfoo/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25460

Modified Files:
	main.c 
Log Message:
readline support now via env variable, not different toplevel file

Index: main.c
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/src/main.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** main.c	6 Aug 2004 02:52:59 -0000	1.2
--- main.c	7 Aug 2004 21:20:42 -0000	1.3
***************
*** 35,40 ****
--- 35,42 ----
  #endif
  
+ #include <stdlib.h>
  #include <limits.h>
  #include <string.h>
+ #include <strings.h>
  
  #ifdef HAVE_FOOELK_SCHEME_H
***************
*** 59,71 ****
        char **argv)
  {
!   int i, nr = 0;
    char toplevel[PATH_MAX] = ELKFOO_SCM_PATH;
  
!   /* determine toplevel-file */
    for (i = 0; i < argc; ++i)
      {
        if (! strcmp(argv[i], ELKFOO_NO_READLINE_OPTION))
  	{
! 	  nr = 1;
  	  /* tweak argv so that elk sees nothing */
  	  for (; i < argc; ++i)
--- 61,77 ----
        char **argv)
  {
!   int i, rl = 1;
    char toplevel[PATH_MAX] = ELKFOO_SCM_PATH;
+   char *elk_rl;
  
!   /* toplevel filename */
!   strcat(toplevel, "/toplevel.foo");
! 
!   /* readline extension? */
    for (i = 0; i < argc; ++i)
      {
        if (! strcmp(argv[i], ELKFOO_NO_READLINE_OPTION))
  	{
! 	  rl = 0;
  	  /* tweak argv so that elk sees nothing */
  	  for (; i < argc; ++i)
***************
*** 79,89 ****
      }
  
!   if (nr)
      {
!       strcat(toplevel, "/toplevel-no-rl.foo");
      }
    else
!     {
!       strcat(toplevel, "/toplevel.foo");
      }
  
--- 85,98 ----
      }
  
!   if (rl
!       && ((elk_rl = getenv("ELK_READLINE"))
! 	  && (strlen(elk_rl) && strcasecmp(elk_rl, "NO"))
! 	  || (! elk_rl)))
      {
!       setenv("ELK_READLINE", "YES", 1);
      }
    else
!     { /* --no-rl */
!       unsetenv("ELK_READLINE");
      }
  

[foo-cvs] fooelk README.FOO,1.1.1.1,1.2

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

Update of /cvsroot/foo/fooelk
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19406

Modified Files:
	README.FOO 
Log Message:
added few info

Index: README.FOO
===================================================================
RCS file: /cvsroot/foo/fooelk/README.FOO,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -d -r1.1.1.1 -r1.2
*** README.FOO	6 Aug 2004 20:56:42 -0000	1.1.1.1
--- README.FOO	7 Aug 2004 09:10:20 -0000	1.2
***************
*** 36,37 ****
--- 36,42 ----
  
  2004-03-04 martin rumori fo...@ru...
+ 2004-08-07 rumori release 0.0.8
+ 
+ - fixed bug yielding GC crash
+ - improved readline extension
+ - heapsize now 4096k