;; collection/list

;; srfi-1

(define iota
  (lambda (n)
    (enum-from-to 0 (- n 1))))

;; filter variant that return a sub-list of `l' containing only those
;; elements at indices for which the procedure `predicate' evaluates
;; to '#t'.

(define filter-index
  (lambda (f l)
    (map1 (lambda (i) (list-ref l i))
	  (filter f (iota (length l))))))

;; [sclang] Elements at `l' are spliced into a list.  This is a
;; non-recursive flatten operation.

(define splice
  (lambda (l)
    (let ((f (lambda (a b)
	       (if (list? a)
		   (append2 a b)
		   (cons a b)))))
      (foldr f nil l))))

;; [sclang] Return a list of `n' places.  If `l' is a list with fewer
;; than `n' elements returns the circular expansion of `l', if `l' is
;; a list with more than `n' elements returns only first `n' elements
;; of `l', if `l'is a list of `n' elements returns `l'.  If `l' is not
;; a list returns a list of `n' elements each being `l'.

(define extend
  (lambda (l n)
    (if (and (list? l) (not (null? l)))
	(let ((z (length l)))
	  (cond ((= z n) l)
		((> z n) (take n l))
		(else (extend (append2 l l) n))))
	(replicate n l))))

;; Extend all lists at `l' to be equal in length to the longest list
;; at `l'.  If any element is not a list it is replaced with a list of
;; itself of that length.

(define (extend-all l)
  (let ((f (lambda (x) (if (list? x) (length x) 1)))
        (n (maximum (map1 f l))))
    (map1 (lambda (e) (extend e n)) l)))

;; Return a rotation of `l' by `n' places.

(define (rotate l n)
  (let ((ll (length l)))
    (map1 (lambda (index) (list-ref l (modulo (+ n index) ll)))
          (iota ll))))

;; Return a <list> containing every `n'th element of the list `l' in
;; sequence.

(define (take-cycle n l)
  (filter-index (lambda (i) (= 0 (modulo i n))) l))

;; Return a <list> of <list>s, each containing a cycle generated by
;; 'take-cycle'.

(define (cycles l n)
  (map1 (lambda (i)
          (take-cycle n (drop i l)))
        (iota n)))



;; n element segments at intervals of k from l
(define segment
  (lambda (n k l)
    (let ((s (take n l)))
      (if (null? s)
	  s
	  (cons s (segment n k (drop k l)))))))


;; collection/series

;; Predicate to determine if `l' is a one element list.

(define (singleton? l)
  (and (list? l) (null? (cdr l))))

;; The sequence of intervals between the elements of the series `s'.

(define (d->dx s)
  (d->dx** s -))

;; Variant that considers the interval from the first to last element.

(define (d->dx* s)
  (d->dx (append2 s (list (car s)))))

;; Variant allowing function other than '-'.

(define (d->dx** s f)
  (unfoldr
   (lambda (b)
     (if (null? (tail b))
         #f
         (tuple2 (f (head (tail b)) (head b)) (tail b))))
   s))

;; A series, the first element being `n', and subsequent elements
;; summing the previous element with the interval from the interval
;; series `i'.

(define (dx->d n i)
  (if (null? i)
      (list n)
      (cons n (dx->d (+ (car i) n) (cdr i)))))


;; collection/tree

;; A not entirely naive flatten - ie. does not use append.

(define flatten
  (letrec ((f (lambda (t r)
		(cond ((null? t) r)
		      ((pair? t) (f (head t) (f (tail t) r)))
		      (else (cons t r))))))
    (lambda (t)
      (f t nil))))

;; Map f over the leaf nodes of t.

(define (mapt f t)
  (cond ((null? t) nil)
        ((list? t) (map1 (lambda (e) (mapt f e)) t))
        (else      (f t))))


;; buffer/signal

;; A Signal is half the size of a Wavetable, each element is the sum
;; of two adjacent elements of the Wavetable.

(define (wavetable->signal l)
  (concat-map sum (segment 2 2 l)))

;; A Wavetable is twice the size of a Signal.  Each element 'e0'
;; expands to {2*e0-e1, e1-e0} where e1 is the next element.

(define (signal->wavetable l)
  (let ((f (lambda (e0 e1) (list (- (* 2.0 e0) e1) (- e1 e0)))))
    (concat-map f (segment 1 2 (append2 l (list1 (head l)))))))


;; math

;; Clip `n' between a and b.

(define (clip a b n)
  (if (< n a) a (if (> n b) b n)))

(define (clipu n)
  (clip 0 1 n))

;; Clip real and imaginary components of z.

(define (clipz a b z)
  (make-rectangular (clip a b (real-part z))
                    (clip a b (imag-part z))))

(define (squared n)
  (* n n))

(define (cubed n)
  (* n n n))

(define (recip n)
  (/ 1 n))

(define e (exp 1.0))
(define pi (* 4 (atan 1)))
(define two-pi (* 2 pi))
(define half-pi (/ pi 2))

;; SuperCollider names.

(define pi2 half-pi)
(define pi32   (* pi 1.5))
(define twopi  two-pi)
(define rtwopi (/ 1.0 two-pi))
(define log001 (log 0.001))
(define log01  (log 0.01))
(define log1   (log 0.1))
(define rlog2  (/ 1.0 (log 2.0)))
(define sqrt2  (sqrt 2.0))
(define rsqrt2 (/ 1.0 sqrt2))

;; +inf.0 does not write to UGen graph files...

(define inf 1073741824.0)

;; Exact integer constructors and predicate.

(define (floor-exact n)
  (inexact->exact (floor n)))

(define (ceiling-exact n)
  (inexact->exact (ceiling n)))

(define (truncate-exact n)
  (inexact->exact (truncate n)))

(define (round-exact n)
  (inexact->exact (round n)))

;;(define (exact-integer? x) (and (integer? x) (exact? x)))

;; Convert a linear rms gain value to a decibel value and the inverse.
;; Zero decibels is unity gain.  These algorithms are from SC3.

(define (ampdb amp)
  (* (log10 amp) 20))

(define (dbamp db)
  (expt 10 (* db 0.05)))

(define (powdb pow)
  (* (log10 pow) 10))

(define (dbpow db)
  (expt 10 (* db 0.1)))

(define (log* n)
  (if (zero? n) n (log n)))

(define (log2 x)
  (/ (log (abs x)) (log 2)))

(define (log10 x)
  (/ (log x) (log 10)))

(define (midicps note)
  (* 440.0 (expt 2.0 (* (- note 69.0) 0.083333333333))))

(define (cpsmidi freq)
  (+ (* (log2 (* freq 0.0022727272727)) 12.0) 69.0))

(define (midiratio midi)
  (expt 2.0 (* midi 0.083333333333)))

(define (ratiomidi ratio)
  (* 12.0 (log2 ratio)))

(define (octcps note)
  (* 440.0 (expt 2.0 (- note 4.75))))

(define (cpsoct freq)
  (+ (log2 (* freq 0.0022727272727)) 4.75))

(define (degree->key degree scale steps)
  (let ((scale-n (length scale)))
    (+ (* steps (quotient degree scale-n))
       (list-ref scale (modulo degree scale-n)))))


;; ntp

;; NTP is the Network Time Protocol.  NTP time is represented by a 64
;; bit fixed point number. The first 32 bits specify the number of
;; seconds since midnight on January 1, 1900, and the last 32 bits
;; specify fractional parts of a second to a precision of about 200
;; picoseconds. This is the representation used by Internet NTP
;; timestamps.

;; The number of seconds from the start of 1900 to the start of 1970.
;; NTP is measured from the former, UTC from the latter.  There are 17
;; leap years in this period.

;; 2^32 = 4294967296

(define seconds-from-1900-to-1970 (+ (* 70 365 24 60 60) (* 17 24 60 60)))
(define (ntpr->ntp i)             (round-exact (* i 4294967296)))
(define (ntp-to-seconds i)        (/ i 4294967296))
(define (ntp-to-seconds. i)       (/ i 4294967296.0))
(define (nanoseconds-to-ntp i)    (round-exact (* i (/ 4294967296 (expt 10 9)))))
(define (ntp-to-nanoseconds i)    (* i (/ (expt 10 9) 4294967296)))

;; Convert between time intervals in seconds and NTP intervals.

(define (time-interval->ntp-interval interval)
  (ntpr->ntp interval))

(define (ntp-interval->time-interval ntp-interval)
  (ntp-to-seconds ntp-interval))

(define (ntp-interval->time-interval. ntp-interval)
  (ntp-to-seconds. ntp-interval))

;; Evaluate to an <real> representing the NTP time of the UTC time of
;; the <real> number `n'.

(define (utc->ntpr n)
  (+ n seconds-from-1900-to-1970))

;; Evaluate to an <integer> representing the NTP time of the UTC time
;; of the <real> number `n'.

(define (utc->ntp n)
  (ntpr->ntp (+ n seconds-from-1900-to-1970)))

;; Evaluate to a <real> number representing the UTC time of the
;; <integer> NTP time `ntp'.

(define (ntp->utc ntp)
  (- (ntp-to-seconds ntp) seconds-from-1900-to-1970))

(define (ntp->utc. ntp)
  (- (ntp-to-seconds. ntp) seconds-from-1900-to-1970))


;; osc

;; OSC strings are C strings padded to a four byte boundary.

(define (read-ostr)
  (let* ((s (read-cstr))
         (n (modulo (cstring-length s) 4))
         (p (- 4 (modulo n 4))))
    (if (not (= n 0))
        (read-bstr p)
        #f)
    s))

;; OSC byte strings are length prefixed.

(define (read-obyt)
  (let* ((n (read-i32))
         (b (read-bstr n))
         (p (- 4 (modulo n 4))))
    (if (not (= n 0))
        (read-bstr p)
        #f)
    b))

;; Evaluates to the object, described by the OSC type character
;; `type', encoded at the OSC byte stream `p'.

(define (read-value t)
  (cond
   ((eq? t oI32) (read-i32))
   ((eq? t oI64) (read-i64))
   ((eq? t oU64) (read-u64))
   ((eq? t oF32) (read-f32))
   ((eq? t oF64) (read-f64))
   ((eq? t oStr) (read-ostr))
   ((eq? t oByt) (read-obyt))
   (else         (error 'read-value "bad type" t))))

;; Evaluate to the list of objects encoded at the OSC byte stream
;; `p', conforming to the types given in the OSC character type
;; list `types'.

(define (read-arguments types)
  (if (null? types)
      nil
      (cons (read-value (car types))
            (read-arguments (cdr types)))))

;; Evaluate to the scheme representation of the OSC message at the OSC
;; byte stream `p'.  The first object is the 'address' of the
;; message, any subsequent objects are arguments for that address.

(define (read-message)
  (let* ((address (read-ostr))
         (types (read-ostr)))
    (cons address
          (read-arguments (cdr (string->list types))))))

;; Evaluate to a scheme representation of the OSC bundle encoded at
;; the OSC stream `p'.  The bundle ends at the end of the byte
;; stream.  The first object is the <real> UTC 'timetag' of the
;; bundle, any subsequent objects are either OSC messages or embedded
;; OSC bundles.

(define (read-bundle)
  (let ((bundletag (read-ostr))
        (timetag (ntp->utc. (read-u64)))
        (parts nil))
    (if (not (equal? bundletag "#bundle"))
        (error 'read-bundle "illegal bundle tag" bundletag)
        (cons timetag
              (let loop ((parts nil))
                (if (eof-object? (lookahead-u8 (current-input-port)))
                    (reverse parts)
                    (begin
                      ;; We have no use for the message size...
                      (read-i32)
                      (loop (cons (read-packet) parts)))))))))

;; Evaluate to the scheme representation of the OSC packet encoded at
;; the OSC byte stream `p'. An OSC packet is either an OSC message
;; or an OSC bundle.

(define hash-u8 (char->integer #\#))

(define (read-packet)
  (if (eq? (lookahead-u8 (current-input-port)) hash-u8)
      (read-bundle)
      (read-message)))

(define (with-input-from-bytevector b f)
  (parameterize
   ((current-input-port (open-bytevector-input-port b)))
   (f)))

(define (decode-osc b)
  (with-input-from-bytevector b read-packet))

;; Write a text representation of the OSC u8l `l'.  The format is that
;; used throughout the OSC specification.

(define (osc-display l)
  (for-each
   (lambda (b n)
     (display (format "~a (~a)" (number->string b 16) (integer->char b)))
     (if (= 3 (modulo n 4))
         (newline)
         (display #\space)))
   l
   (iota (length l))))

(define (padding-of n) (replicate n (encode-u8 0)))

;; OSC strings are C strings padded to a four byte boundary.

(define (cstring-length s)
  (+ 1 (string-length s)))

(define (encode-string s)
  (let ((n (modulo (cstring-length s) 4)))
    (list (encode-cstr s)
          (if (= n 0)
              nil
              (padding-of (- 4 n))))))

;; OSC byte strings are length prefixed?

(define (encode-bytes b)
  (let* ((n (bytevector-length b))
         (n* (modulo n 4)))
    (list (encode-i32 n)
          b
          (if (= n* 0)
              nil
              (padding-of (- 4 n*))))))

;; Allowable types are <integer>, <real>, <string>, or <u8l>.  Note
;; further that determining if a <real> should be written as a float
;; or a double is non-trivial and not undertaken here, all <real>s are
;; written as floats.

(define (exact-integer? n)
  (and (integer? n) (exact? n)))

(define (encode-value e)
  (cond ((exact-integer? e)   (encode-i32 e))
        ((real? e)            (encode-f32 e))
        ((string? e)          (encode-string e))
        ((bytevector? e)      (encode-bytes e))
        (else                 (error 'encode-value "illegal value" e))))

;; Encode the type string for the Evaluates to the OSC <u8v>
;; indicating the types of the elements of the list `l'.

(define (encode-types l)
  (encode-string
   (list->string
    (cons #\,
          (map1 (lambda (e)
                  (cond ((exact-integer? e) #\i)
                        ((real? e)          #\f)
                        ((string? e)        #\s)
                        ((bytevector? e)    #\b)
                        (else               (error 'encode-types "type?" e))))
                l)))))

;; Encode OSC message.

(define (encode-message m)
  (list (encode-string (car m))
        (encode-types (cdr m))
        (map1 encode-value (cdr m))))

;; Encode OSC bundle. The first element is a <real> valued UTC
;; 'time-tag', each subsequent element must be an OSC 'message'.

(define (encode-bundle-ntp b)
  (list (encode-string "#bundle")
        (encode-u64 (ntpr->ntp (car b)))
        (map1 (lambda (e)
		(if (message? e)
		    (encode-bytes (encode-osc e))
		    (error 'encode-bundle "illegal value" e)))
	      (cdr b))))

(define (encode-bundle b)
  (encode-bundle-ntp (cons (utc->ntpr (car b)) (cdr b))))

;; An OSC packet is either an OSC message or an OSC bundle.

(define (osc->u8t p)
  (if (bundle? p)
      (encode-bundle p)
      (encode-message p)))

(define (encode-osc p)
  (u8t->bytevector (osc->u8t p)))

;; Evaluates to a type-correct form of the OSC data `e'.  This
;; procedure does not verify that `e' is syntactically correct.
;; Boolean values are rewritten as integers, zero for '#f' and one for
;; '#t'.  Symbols are rewritten as the strings given by
;; 'symbol->string'.  An error is raised if `e' cannot be rewritten.
;; Note that R5RS does not require symbols to be case sensitive
;; although most interpreters will have an option to set this.

(define (purify e)
  (cond ((or (number? e) (string? e) (bytevector? e)) e)
        ((list? e) (map1 purify e))
        ((symbol? e) (symbol->string e))
        ((boolean? e) (if e 1 0))
        (else (error 'purify "illegal input" e))))

(define oI32 #\i)
(define oI64 #\h)
(define oU64 #\t)
(define oF32 #\f)
(define oF64 #\d)
(define oStr #\s)
(define oByt #\b)

;; Validating constructors.

(define (message c . l)
  (if (string? c)
      (cons c l)
      (error 'message "illegal command" c)))

(define (bundle t . l)
  (if (number? t)
      (cons t l)
      (error 'bundle "illegal timestamp" t)))

;; Predicates for OSC packet types.

(define (message? p)
  (string? (car p)))

(define (bundle? p)
  (number? (car p)))

;; Evaluates to '#t' iff `m' is a correct OSC message.  The first
;; element must be a string 'address', subsequent elements are
;; arguments of types integer, real or string.

(define (verify-message m)
  (and (string? (car m))
       (not (find-tail (lambda (e) (not (or (integer? e)
                                            (real? e)
                                            (string? e))))
                       (cdr m)))))

;; Evaluates to '#t' iff `b' is a correct OSC bundle.  The first
;; element must be an integer 'timetag', subsequent elements may be OSC
;; messages or OSC bundles.  The timetags of embedded bundles must be
;; greater than or equal to the timetag of the containing bundle.

(define (verify-bundle b)
  (and (integer? (car b))
       (not (find-tail (lambda (e) (not (or (verify-message e)
                                            (and (verify-bundle e)
                                                 (>= (car e) (car b))))))
                       (cdr b)))))

;; Evaluates to '#t' iff `p' is a correct OSC packet.  An OSC packet
;; is either an OSC message or an OSC bundle.

(define (verify-packet p)
  (or (verify-message p)
      (verify-bundle p)))


;; osc/transport

(define-record-type transport (fields type ip op))

(define (tcp-transport? t)
  (eq? (transport-type t) 'tcp))

(define (udp-transport? t)
  (eq? (transport-type t) 'tcp))

(define (open-tcp h p)
  (let-values (((op ip) (tcp-connect h p)))
	      (make-transport 'tcp ip op)))

(define (close-transport t)
  (close-input-port (transport-ip t))
  (close-output-port (transport-op t)))

(define (put-bytevector* p v)
  (let ((n (bytevector-length v)))
    (let loop ((i 0))
      (if (= i n)
          #f
          (let ((b (bytevector-u8-ref v i)))
            (put-u8 p b)
            (loop (+ i 1)))))))

(define (osc-send t m)
  (let ((p (transport-op t))
        (v (encode-osc m)))
    (cond ((tcp-transport? t)
           (put-bytevector* p (encode-i32 (bytevector-length v)))
           (put-bytevector* p v))
          (else
           (error 'osc-send "unknown transport")))))

(define (osc-recv t _)
  (error 'osc-recv "unknown transport"))

(define (osc-request u r m t)
  (osc-send u m)
  (let ((p (osc-recv u t)))
    (if (and p (string=? (car p) r)) p #f)))


;; random

(define (random)
  (let ((n (expt 2 32)))
    (/ (i:random n) n)))

;; Linearly distributed in [0,1) with a mean value of 0.2929.  The
;; density function is given by 'f(x) = 2 * (1 - x)'.

(define (random-linear) (min (random) (random)))

;; Linearly distributed in [0,1) with a mean value of 0.6969.  The
;; density function is given by 'f(x) = 2 * (x - 1)'.

(define (random-inverse-linear) (max (random) (random)))

;; Triangularly distributed in [0,1) with a mean value of 0.5.

(define (random-triangular) (* 0.5 (+ (random) (random))))

;; Exponentialy distributed with a mean value of '0.69315 / l'.  There
;; is no upper limit on the value however there is only a one in
;; one-thousand chance of generating a number greater than '6.9078 /
;; l'.  The density function is given by: 'f(x) = l ^ (-l * x)'.

(define (random-exponential l)
  (let ((u (random)))
    (if (zero? u)
        (random-exponential l)
        (/ (- (log u)) l))))

;; Clamped 'random-exponential' in [0,1).

(define (random-exponential*)
  (clip 0.0 1.0 (random-exponential 6.9078)))

;; Bilinear exponentialy distributed with a mean value of 0 and where
;; half of the results lie between '+- 1 / l'.  The density function
;; is given by: 'f(x) = 0.5 * l * (e ^ (-l * |x|))'.

(define (random-bilinear-exponential l)
  (let ((u (* 2 (random))))
    (if (zero? u)
        (random-bilinear-exponential l)
        (* (if (> u 1) -1 1) (log (if (> u 1) (- 2 u) u))))))

;; Guassian distributed with a mean value of `mu' and where 68.26% of
;; values will occur within the interval +-`sigma' and 99.75% within
;; the interval +-(3 * `sigma').  The density function is given by:
;; 'f(x) = (1 / SQRT (2 * pi * sigma)) EXP - ((x - u) ^ 2) / (s *
;; (sigma ^ 2))'.

(define (random-guassian sigma mu)
  (let* ((n 12)
         (half-n (/ n 2))
         (scale (/ 1 (sqrt (/ n 12)))))
    (let ((s (sum (lambda (ignored) (random)) (iota n))))
      (+ (* sigma scale (- s half-n)) mu))))

;; Clamped 'random-guassian' in [0,1).

(define (random-guassian*)
  (clip 0.0 1.0 (random-guassian (/ 1.0 6.0) 0.5)))

;; Cauchy-distributed with a mean value of 0.0 where half of the
;; results lie in the interval +-alpha, and 99.9% fall within
;; +-318.3alpha.  The density function is given by: 'f(x) = alpha /
;; (pi * (alpha ^ 2 + x ^ 2))'.

(define (random-cauchy alpha)
  (let ((u (random)))
    (if (= u 0.5)
        (random-cauchy alpha)
        (* alpha (tan (* u pi))))))

;; Beta-distributed in [0,1).

(define (random-beta a b)
  (let ((u1 (random)))
    (if (zero? u1)
        (random-beta a b)
        (let ((u2 (random)))
          (if (zero? u2)
              (random-beta a b)
              (let* ((y1 (expt u1 (/ 1 a)))
                     (y2 (expt u2 (/ 1 b)))
                     (sum (+ y1 y2)))
                (if (> sum 1.0)
                    (random-beta a b)
                    (/ y1 sum))))))))

;; Weibull-distributed.

(define (random-weibull s t)
  (let ((u (random)))
    (if (or (zero? u)
            (= u 1.0))
        (random-weibull s t)
        (let ((a (/ 1.0 (- 1.0 u))))
          (* s (expt (log a) (/ 1.0 t)))))))

;; Poisson-distributed.

(define (random-poisson l)
  (let loop ((v (exp (- l)))
             (u (random))
             (n 0))
    (if (>= u v)
        (loop v (* u (random)) (+ n 1))
        n)))

;; Parameter to control distribution.

(define current-rand (make-parameter random))

;; Evaluates to a random number with range [a,b) with the distribution
;; determined by `r'.

(define (rand a b) (+ (* ((current-rand)) (- b a)) a))

;; Zero to `n' variant, named for SC3 operator, which is so named due
;; to conflict with SC3 UGen.

(define (_rand n)
  (rand 0 n))

;; -`n' to `n' variant, SC3 naming.

(define (rand2 n)
  (rand (- n) n))

;; List generating variant of rand.

(define (randl n l r)
  (map1 (lambda (i) (rand l r)) (iota n)))

;; Integer variant.

(define (randi a b) (floor-exact (rand a b)))

;; Complex variant.

(define (randc a b d e) (make-rectangular (rand a b) (rand d e)))

;; Exponential variant, very common in music work.

(define (randx minima maxima)
  (let ((ratio (/ maxima minima)))
    (* (expt ratio (rand 0.0 1.0)) minima)))

;; List generating variant of randx.

(define (randxl n l r)
  (map1 (lambda (i) (randx l r)) (iota n)))

;; Boolean variant.

(define (randb) (> 0.5 (rand 0.0 1.0)))

;; Evaluates to a number that lies within deviation from `center'
;; calculated by multiplying `perturbation' by `center'.

(define (randp center perturbation)
  (let ((deviation (* center perturbation)))
    (rand (- center deviation) (+ center deviation))))

;; Return a randomly selected element of the <list> 'l'.

(define (choose l)
  (list-ref l (randi 0 (length l))))

;; Return a randomly selected element of the <list> 'l'.

(define (choosel n l)
  (map1 (lambda (_) (choose l)) (iota n)))

;; Weighted choose, w must sum to 1.

(define (windex w n)
  (list-index (lambda (e) (< n e)) (cdr (dx->d 0 w))))

(define (wchoose l w)
  (list-ref l (windex w (rand 0.0 1.0))))

;; Proportional choose, p will be normalized and then wchoosen.

(define (normalize-sum l)
  (let ((n (foldl1 + l)))
    (map1 (lambda (e) (/ e n)) l)))

(define (pchoose l p)
  (wchoose l (normalize-sum p)))

;; Evaluates to a random element from the proper list `l' as if it
;; were a list distributed with the proportions at `proportions'.
;; This is pchoose with reversed arguments...

(define (choose/proportions proportions l)
  (let* ((p-sum (cdr (dx->d 0 proportions)))
         (n     (rand 0 (last p-sum))))
    (list-ref l (list-index (lambda (e) (< n e)) p-sum))))

;; Return a randomly selected element of the <string> 's'.

(define (string-choose v)
  (string-ref v (randi 0 (string-length v))))

;; Return a randomly selected element of the <vector> 'v'.

(define (vector-choose v)
  (vector-ref v (randi 0 (vector-length v))))

;; Return a random permutation of the <list> `l'.  This is not a
;; mutation operation.  For a critique of this method see
;; http://okmij.org/ftp/Haskell/perfect-shuffle.txt.

(define (shuffle l)
  (let ((q (map1 (lambda (e) (cons (rand 0 1) e)) l))
        (c (lambda (a b) (> (car a) (car b)))))
    (map1 cdr (list-sort q c))))

;; sclang name for shuffle.

(define scramble shuffle)


;; structure

(define-syntax define-structure
  (syntax-rules ()
    ((_ name field ...)
     (define-record-type name (fields field ...)))))


;; server/add-action

;; The addAction values are interpreted as follows:
;; 0 - add the new node to the the head of the group specified by the
;;     add target ID.
;; 1 - add the new node to the the tail of the group specified by the
;;     add target ID.
;; 2 - add the new node just before the node specified by the add
;;     target ID.
;; 3 - add the new node just after the node specified by the add
;;     target ID.
;; 4 - the new node replaces the node specified by the add target
;;     ID. The target node is freed.

(define addToHead  0)
(define addToTail  1)
(define addBefore  2)
(define addAfter   3)
(define addReplace 4)


;; server/command

(define with-reply list)

(define /quit
  (with-reply
   "/done"
   (message "/quit")))

(define (/notify code)
  (with-reply
   "/done"
   (message "/notify" code)))

(define /status
  (with-reply
   "status.reply"
   (message "/status")))

(define (/dumpOSC code)
  (message "/dumpOSC" code))

(define (/sync id)
  (with-reply
   "/synced"
   (message "/sync" id)))

(define /clearSched
  (message "/clearSched"))

(define (/d_recv data)
  (with-reply
   "/done"
   (message "/d_recv" data)))

(define (/d_load path)
  (with-reply
   "/done"
   (message "/d_load" path)))

(define (/d_loadDir path)
  (with-reply
   "/done"
   (message "/d_loadDir" path)))

(define (/d_free name)
  (message "/d_free" name))

(define (/n_free id)
  (message "/n_free" id))

(define (/n_run id flag)
  (message "/n_run" id flag))

(define (/n_set id index value)
  (message "/n_set" id index value))

(define (/n_setn id index n . values)
  (apply message "/n_setn" id index n values))

(define (/n_fill id index n value)
  (message "/n_fill" id index n value))

(define (/n_map id index bus)
  (message "/n_map" id index bus))

(define (/n_mapn id index bus n)
  (message "/n_mapn" id index bus n))

(define (/n_before a b)
  (message "/n_before" a b))

(define (/n_query id)
  (with-reply "n_info"
              (message "/n_query" id)))

(define (/n_trace id)
  (message "/n_trace" id))

(define (/s_new name id action target . initialize)
  (apply message "/s_new" name id action target initialize))

(define (/s_get id index)
  (with-reply
   "n_set"
   (message "/s_get" id index)))

(define (/s_getn id index n)
  (with-reply
   "n_setn"
   (message "/s_getn" id index n)))

(define (/s_noid id)
  (message "/s_noid" id))

(define (/g_new id action target)
  (message "/g_new" id action target))

(define (/g_head group node)
  (message "/g_head" group node))

(define (/g_tail group node)
  (message "/g_tail" group node))

(define (/g_freeAll id)
  (message "/g_freeAll" id))

(define (/g_deepFree id)
  (message "/g_deepFree" id))

(define (/b_alloc id frames channels)
  (with-reply
   "/done"
   (message "/b_alloc" id frames channels)))

(define (/b_allocRead id path frame n)
  (with-reply
   "/done"
   (message "/b_allocRead" id path frame n)))

(define (/b_read id path frame n bframe flag)
  (with-reply
   "/done"
   (message "/b_read" id path frame n bframe flag)))

(define (/b_write id path header type frames start flag)
  (with-reply
   "/done"
   (message "/b_write" id path header type frames start flag)))

(define (/b_free id)
  (with-reply
   "/done"
   (message "/b_free" id)))

(define (/b_zero id)
  (with-reply
   "/done"
   (message "/b_zero" id)))

(define (/b_set id index value)
  (message "/b_set" id index value))

(define (/b_setn id index n . values)
  (apply message "/b_setn" id index n values))

(define (/b_setn* id n l)
  (apply /b_setn id n (length l) l))

(define (/b_fill id index n value)
  (message "/b_fill" id index n value))

(define (/b_close id)
  (with-reply
   "/done"
   (message "/b_close" id)))

(define (/b_query id)
  (with-reply
   "/b_info"
   (message "/b_query" id)))

(define (/b_get id index)
  (with-reply
   "/b_set"
   (message "/b_get" id index)))

(define (/b_getn id index n)
  (with-reply
   "/b_setn"
   (message "/b_getn" id index n)))

(define (/b_gen id cmd . values)
  (with-reply
   "/done"
   (apply message "/b_gen" id cmd values)))

(define (/b_gen* id cmd . l)
  (apply /b_gen id cmd (splice l)))

(define (/c_set id value)
  (message "/c_set" id value))

(define (/c_setn id n . values)
  (apply message "/c_setn" id n values))

(define (/c_setn* n l)
  (apply /c_setn n (length l) l))

(define (/c_fill id n value)
  (message "/c_fill" id n value))

(define (/c_get id)
  (with-reply
   "/c_set"
   (message "/c_get" id)))

(define (/c_getn id n)
  (with-reply
   "/c_setn"
   (message "/c_getn" id n)))


;; server/done-action

;; The doneAction values are interpreted as follows:
;;  0 - do nothing when the envelope has ended
;;  1 - pause the synth, it is still resident
;;  2 - remove the synth and deallocate it
;;  3 - remove and deallocate both this synth and the preceeding node
;;  4 - remove and deallocate both this synth and the following node
;;  5 - remove and deallocate this synth and if the preceeding node is a
;;      group then do g_freeAll on it, else n_free it
;;  6 - remove and deallocate this synth and if the following node is a
;;      group then do g_freeAll on it, else n_free it
;;  7 - remove and deallocate this synth and all preceeding nodes in this
;;      group
;;  8 - remove and deallocate this synth and all following nodes in this
;;      group
;;  9 - remove and deallocate this synth and pause the preceeding node
;; 10 - remove and deallocate this synth and pause the following node
;; 11 - remove and deallocate this synth and if the preceeding node is a
;;      group then do g_deepFree on it, else n_free it
;; 12 - remove and deallocate this synth and if the following node is a
;;      group then do g_deepFree on it, else n_free it

(define doNothing   0)
(define pauseSynth  1)
(define removeSynth 2)


;; server/gen

(define genNormalize 1)
(define genWavetable 2)
(define genClear     4)


;; server/server

(define -> osc-send)

(define <- osc-recv)

(define (<-* s t)
  (let loop ((r nil))
    (let ((p (<- s t)))
      (if p (loop (cons p r)) (reverse r)))))

(define timeout (make-parameter 1.0))

(define (->< s l)
  (let ((r (car l))
        (m (cadr l)))
    (-> s m)
    (let ((p (<- s (timeout))))
      (cond
       ((not p)                    (error '->< "timed out"))
       ((not (string=? (car p) r)) (error '->< "bad return packet" p r))
       (else                       p)))))

(define (reset s)
  (-> s (bundle -1
                (/g_freeAll 0)
                /clearSched
                (/g_new 1 0 0))))

(define (with-sc3 f)
  (let* ((t (open-tcp "127.0.0.1" "57110"))
         (r (f t)))
    (close-transport t)
    r))


;; server/status

(define status-fields
  (list "# UGens                     "
        "# Synths                    "
        "# Groups                    "
        "# Instruments               "
        "% CPU (Average)             "
        "% CPU (Peak)                "
        "Sample Rate (Nominal)       "
        "Sample Rate (Actual)        "))

(define (status-info r)
  (map1 number->string (cddr r)))

(define (status-format r)
  (cons "***** SuperCollider Server Status *****"
        (map1 string-append status-fields (status-info r))))

;; Collect server status information.

(define (server-status s)
  (let ((r (->< s /status)))
    (status-format r)))

(define (display-server-status s)
  (newline)
  (for-each display (intersperse "\n" (server-status s)))
  (newline))

;; Accessors

(define (server-status-field s n)
  (let ((r (->< s /status)))
    (list-ref r n)))

(define (server-sample-rate/nominal s)
  (server-status-field s 8))

(define (server-sample-rate/actual s)
  (server-status-field s 9))


;; supercollider/envelope

;; A curve specification is either a <string> or a <number>.  If it is
;; a string it must name a known curve type.  For numerical valued
;; curves the shape '5' indicates the actual curve input value is to
;; be used.

(define (curve->shape curve)
  (cond ((string? curve)
         (let ((f (lambda (s) (string=? s curve))))
           (cond
            ((f "step")        0.0)
            ((f "linear")      1.0)
            ((f "exponential") 2.0)
            ((f "sin")         3.0)
            ((f "cos")         4.0)
            ((f "squared")     6.0)
            ((f "cubed")       7.0)
            (else              (error "curve->shape:" curve)))))
        ((number? curve)
         5.0)
        (else
         (error "curve->shape: illegal curve" curve))))

;; If the curve is a number the value is that number, else the value
;; will be ignored and is here set to zero.

(define (curve->value curve)
  (if (number? curve) curve 0.0))

;; Make a <list> for use with the EnvGen UGen. `levels' is a <list>
;; containing the left to right gain values for the envelope, it has
;; one more element than the <list> `times', having the delta times
;; for each envelope segment.  `curve' is either a string or a number
;; or a <list> of such, in either case it is expanded to a list of the
;; same length as `times'.  `release-node' is the index of the
;; 'release' stage of the envelope, `loop-node' is the index of the
;; 'loop' stage of the envelope.  These indices are set as invalid, by
;; convention -1, to indicate there is no such node.

(define (env levels times curve release-node loop-node)
  (make-mce
   (append2
    (list (car levels) (length times) release-node loop-node)
    (splice (zip-with3 (lambda (l t c)
			 (list l
			       t
			       (curve->shape c)
			       (curve->value c)))
		       (cdr levels) 
		       times 
		       (extend curve (length times)))))))

;; Co-ordinate based static envelope generator.

(define (env/bp* bp dur amp curve)
  (env (map1 (lambda (e) (Mul e amp)) (take-cycle 2 (cdr bp)))
       (map1 (lambda (e) (Mul e dur)) (d->dx** (take-cycle 2 bp) Sub))
       curve
       -1
       -1))

(define (env/bp bp dur amp)
  (env/bp* bp dur amp "linear"))

;; Design a standard trapezoidal envelope.  `shape' determines the
;; sustain time as a proportion of `dur', zero is a triangular
;; envelope, one a rectangular envelope.  `skew' determines the
;; attack/decay ratio, zero is an immediate attack and a slow decay,
;; one a slow attack and an immediate decay.  This implementation
;; builds a zero one breakpoint data set and calls env/bp.

(define (env/trapezoid shape skew dur amp)
  (let* ((x1 (* skew (- 1.0 shape)))
         (bp (list 0
                   (if (<= skew 0.0) 1.0 0.0)
                   x1
                   1.0
                   (+ shape x1)
                   1.0
                   1.0
                   (if (>= skew 1.0) 1.0 0.0))))
    (env/bp bp dur amp)))

;; SC3 envelope generators.

(define (env/triangle dur level)
  (let ((half-dur (Mul dur 0.5)))
    (env (list 0.0 level 0.0)
         (list half-dur half-dur)
         "linear"
         -1
         -1)))

(define (env/sine dur level)
  (let ((half-dur (Mul dur 0.5)))
    (env (list 0.0 level 0.0)
         (list half-dur half-dur)
         "sin"
         -1
         -1)))

(define (env/perc attackTime releaseTime level curve)
  (env (list 0.0 level 0.0)
       (list attackTime releaseTime)
       curve
       -1
       -1))

(define (env/adsr attackTime
                  decayTime
                  sustainLevel
                  releaseTime
                  peakLevel
                  curve
                  bias)
  (env (map1 (lambda (e) (Mul e bias))
	     (list 0.0 peakLevel (Mul peakLevel sustainLevel) 0.0))
       (list attackTime decayTime releaseTime)
       curve
       2
       -1))

(define (env/asr attackTime sustainLevel releaseTime curve)
  (env (list 0.0 sustainLevel 0.0)
       (list attackTime releaseTime)
       curve
       1
       -1))

(define (env/linen attackTime sustainTime releaseTime level curve)
  (env (list 0.0 level level 0.0)
       (list attackTime sustainTime releaseTime)
       curve
       -1
       -1))


;; /fft

(define (packfft-data m p)
  (make-mce
   (cons (* 2 (length m))
	 (splice (zip-with list2 m p)))))


;; /in

;; Audio input.  Does not support MulAdd.

(define (consecutive? l)
  (let ((x (car l))
        (xs (cdr l)))
    (or (null? xs)
        (and (= (+ x 1) (car xs))
             (consecutive? xs)))))

(define (audio-in n)
  (let ((offset (Sub NumOutputBuses 1)))
    (if (mce? n)
        (let ((l (mce-channels n)))
          (if (consecutive? l)
              (In (length l) ar (Add offset (car l)))
              (In 1 ar (Add offset n))))
        (In 1 ar (Add offset n)))))


;; /klang

;; Generate a 'spec' list for a Klang UGen.  `freqs' is a list that
;; determines the number of partials, `amps' and `phases' are possibly
;; abbreviated lists subject to expansion by 'extend' to the length of
;; `freqs'.

(define (klang-data freqs amps phases)
  (let ((n (length freqs)))
    (make-mce
     (concat
      (transpose
       (list freqs
	     (extend amps n)
	     (extend phases n)))))))

;; Variant to generate a 'spec' list for a Klank UGen, the last
;; argument is `ring-time', not `phases'.

(define klank-data klang-data)

(define (dyn-klank i fs fo ds s)
  (letrec ((gen (lambda (l)
                  (if (null? l)
                      0
                      (let ((f (car l))
                            (a (cadr l))
                            (d (caddr l)))
                        (Add (Mul (Ringz i (MulAdd f fs fo) (Mul d ds)) a)
                             (gen (cdddr l))))))))
    (gen (mce-channels s))))

;; Frequency shifter, in terms of Hilbert UGen.

(define (freq-shift i f p)
  (let ((o (SinOsc ar f (Mce (Add p (* 0.5 pi)) p)))
        (h (Hilbert i)))
    (mix (Mul h o))))

;; PMOsc

(define (pm-osc r cf mf pm mp)
  (SinOsc r cf (Mul (SinOsc r mf mp) pm)))


;; /mix

;; Mix the UGen at `inputs'.  This is an idiom over the binary math
;; operator 'Add'.

(define (mix u)
  (cond
   ((mce? u) (foldl1 Add (mce-channels u)))
   (else     u)))

;; Use the unary procedure `f' to build an mce value of `n' places.

(define (mce/fill n f)
  (make-mce (map1 f (iota n))))

;; mix . mce/fill

(define (mix/fill n f)
  (mix (mce/fill n f)))


;; /name

(define unary-operator-names '(Neg Not IsNil NotNil BitNot Abs
				   AsFloat AsInt Ceil Floor Frac Sign Squared Cubed Sqrt Exp Recip
				   MIDICPS CPSMIDI MIDIRatio RatioMIDI DbAmp AmpDb OctCPS CPSOct Log Log2
				   Log10 Sin Cos Tan ArcSin ArcCos ArcTan SinH CosH TanH _Rand Rand2
				   _LinRand BiLinRand Sum3Rand Distort SoftClip Coin DigitValue Silence
				   Thru RectWindow HanWindow WelchWindow TriWindow _Ramp SCurve))

(define (unary-operator-name special)
  (list-ref unary-operator-names special))

(define binary-operator-names '(Add Sub Mul IDiv FDiv Mod EQ NE LT GT
				    LE GE Min Max BitAnd BitOr BitXor LCM GCD Round RoundUp Trunc Atan2
				    Hypot Hypotx Pow ShiftLeft ShiftRight UnsignedShift Fill Ring1 Ring2
				    Ring3 Ring4 DifSqr SumSqr SqrSum SqrDif AbsDif Thresh AMClip ScaleNeg
				    Clip2 Excess Fold2 Wrap2 FirstArg RandRange ExpRandRange))

(define (binary-operator-name special)
  (list-ref binary-operator-names special))

(define (ugen-name/operator name special)
  (cond
   ((string=? name "BinaryOpUGen") (binary-operator-name special))
   ((string=? name "UnaryOpUGen")  (unary-operator-name special))
   (else                           name)))


;; /play

;; Play the graph rooted at the <ugen> `u' at the server `s'.

(define (play s u)
  (let ((g (if (graphdef? u)
               u
               (ugen->graphdef/out u))))
    (->< s (/d_recv (encode-graphdef g)))
    (->  s (/s_new (graphdef-name g) -1 1 1))))

(define (audition u)
  (with-sc3
   (lambda (fd)
     (play fd u))))


;; /

;; Quantize `n' to the nearest multiple of `quanta'.

(define (quantize quanta n)
  (* (round-exact (/ n quanta)) quanta))


;; /range

(define (unipolar? u)
  (if (mce? u)
      (all unipolar? (mce-channels u))
      (member (ugen-name u)
              (list "LFPulse" "Impulse" "TPulse" "Trig1" "Dust"))))

(define (range u l r)
  (if (unipolar? u)
      (MulAdd u (Sub r l) l)
      (let* ((m (Mul (Sub r l) 0.5))
             (a (Add m l)))
        (MulAdd u m a))))

;; Note: uses LinExp so `l' and `r' are i-rate.

(define (exprange u l r)
  (if (unipolar? u)
      (LinExp u  0 1 l r)
      (LinExp u -1 1 l r)))


;; /score

;; A score is a list of OSC bundles.  The timestamps are given in
;; seconds where zero is the start of the score.  An OSC file is a
;; binary file format understood by the SC3 synthesis server, and
;; consists of a sequence of length prefixed OSC bundles.

;; Generate the <u8t> for the score `data'.

(define (score->u8t bundles)
  (map1 (lambda (bundle)
	  (let ((v (encode-bundle-ntp bundle)))
	    (list (encode-i32 (bytevector-length v))
		  v)))
	bundles))

(define (encode-score s)
  (u8t->bytevector (score->u8t s)))


;; /sndfile

(define au-magic #x2e736e64)

(define au-unspecified 0)
(define au-mulaw8      1)
(define au-linear8     2)
(define au-linear16    3)
(define au-linear24    4)
(define au-linear32    5)
(define au-float       6)
(define au-double      7)

(define (au-size-of e)
  (cond ((= e au-unspecified) (error 'au-size-of "unspecified encoding"))
        ((= e au-mulaw8)      1)
        ((= e au-linear8)     1)
        ((= e au-linear16)    2)
        ((= e au-linear24)    3)
        ((= e au-linear32)    4)
        ((= e au-float)       4)
        ((= e au-double)      8)
        (else                 (error "au-size-of: illegal encoding"))))

(define (au-mk-hdr nf enc sr nc)
  (let ((nb (* nf nc (au-size-of enc))))
    (concat-map encode-i32 (list au-magic 28 nb enc sr nc 0))))

(define au-f32 (list au-float  encode-f32))
(define au-f64 (list au-double encode-f64))

(define (write-snd-file e sr nc fn d)
  (let ((enc   (car e))
        (encdr (cadr e))
        (nf    (/ (length d) nc)))
    (with-output-to-file fn
      (lambda ()
        (for-each put-u8 (au-mk-hdr nf enc sr nc))
        (for-each put-u8 (concat-map encdr d))))))


;; /spec

;; An interface to the warp procedures.

(define-record-type spec (fields minima maxima warp range ratio))

(define (make-spec* minima maxima warp)
  (let ((w (if (symbol? warp) (symbol->warp warp) warp)))
    (make-spec minima maxima (w minima maxima)
               (- maxima minima) (/ maxima minima))))

(define (spec-map s value)
  ((spec-warp s) 'map (clip 0.0 1.0 value)))

(define (spec-unmap s value)
  (clip 0.0 1.0 ((spec-warp s) 'unmap value)))

(define (symbol->spec s)
  (case s
    ((unipolar)       (make-spec  0.0 1.0     'linear))
    ((bipolar pan)    (make-spec -1.0 1.0     'linear))
    ((freq frequency) (make-spec 20.0 20000.0 'linear))
    ((phase)          (make-spec  0.0 two-pi  'linear))
    (else             (error 'symbol->spec "illegal value" s))))


;; /synthdef

;; Transform a <ugen> into a <graphdef>.

(define synthdef graph->graphdef)

;; If ugen has output ports encapsulate it.

(define (with-out u)
  (if (or (mce? u)
          (and (ugen? u) (not (null? (ugen-outputs u)))))
      (letc ((bus 0.0)) (Out bus u))
      u))

(define (send-synth s n u)
  (->< s (/d_recv (encode-graphdef (synthdef n (with-out u))))))

(define (ugen->graphdef/out u)
  (synthdef "Anonymous" (with-out u)))

;; A large positive integer that can be used as an argument to
;; synthdefs.

(define inf.sc 9.0e8)


;; /warp

;; A warp is a procedure of two arguments.  The first is the <symbol>
;; direction of the warp, which should be either 'map' or 'unmap'.
;; The second is a <real> number.  Warps map from the space [0,1] to a
;; user defined space [minima,maxima].  A warp generator takes the
;; arguments `minima' and `maxima', even if it then ignores these
;; values.

;; Returns true iff the <symbol> `s' is 'map'.

(define (warp-fwd? s) (eq? s 'map))

;; A linear real value map.

(define (warp-linear minima maxima)
  (let ((range (- maxima minima)))
    (lambda (direction value)
      (if (warp-fwd? direction)
          (+ (* value range) minima)
          (/ (- value minima) range)))))

;; A linear integer value map.

(define (warp-linear-integer minima maxima)
  (let ((w (warp-linear minima maxima)))
    (lambda (direction value)
      (round-exact (w direction value)))))

;; The minima and maxima must both be non zero and have the same sign.

(define (warp-exponential minima maxima)
  (let ((ratio (/ maxima minima)))
    (lambda (direction value)
      (if (warp-fwd? direction)
          (* (expt ratio value) minima)
          (/ (log (/ value minima)) (log ratio))))))

;; Evaluates to a warp generator for warps with an exponetial curve
;; given by `curve'.

(define (warp-make-warp-curve curve)
  (lambda (minima maxima)
    (let ((range (- maxima minima)))
      (if (< (abs curve) 0.001)
          (warp-linear minima range)
          (let* ((grow (exp curve))
                 (a (/ range (- 1.0 grow)))
                 (b (+ minima a)))
            (lambda (direction value)
              (if (warp-fwd? direction)
                  (- b (* a (expt grow value)))
                  (/ (log (/ (- b value) a)) curve))))))))

(define (warp-cosine minima maxima)
  (let* ((range (- maxima minima))
         (linear (warp-linear minima range)))
    (lambda (direction value)
      (if (warp-fwd? direction)
          (linear 'map (- 0.5 (* (cos (* pi value)) 0.5)))
          (/ (acos (- 1.0 (* (linear 'unmap value) 2))) pi)))))

(define (warp-sine minima maxima)
  (let* ((range (- maxima minima))
         (linear (warp-linear minima range)))
    (lambda (direction value)
      (if (warp-fwd? direction)
          (linear 'map (sin (* half-pi value)))
          (/ (asin (linear 'unmap value)) half-pi)))))

;; The minima and maxima values are ignored, they are implicitly zero
;; and one.

(define (warp-fader minima maxima)
  (lambda (direction value)
    (if (warp-fwd? direction)
        (* value value)
        (sqrt value))))

;; The minima and maxima values are ignored, they are implicitly
;; negative infinity and zero.  An input value of zero gives -180.

(define (warp-db-fader minima maxima)
  (lambda (direction value)
    (if (warp-fwd? direction)
        (if (zero? value)
            -180
            (ampdb (* value value)))
        (sqrt (dbamp value)))))

;; Translate a symbolic warp name to a warp procedure.

(define (symbol->warp s)
  (case s
    ((lin linear) warp-linear)
    ((exp exponential) warp-exponential)
    ((sin) warp-sine)
    ((cos) warp-cosine)
    ((amp) warp-fader)
    ((db) warp-db-fader)
    (else (error 'symbol->warp "unknown symbol" s))))

;; Translate a number to a warp.

(define (number->warp n) (warp-make-warp-curve n))


;; ugen/constructor

;; name = <string> | <symbol>
;; rate? = <rate> | #f
;; inputs = <list> of <input*>
;; mce? = <input*> | #f
;; outputs = <integer>
;; special = <integer>

;; It is significant whether MCE or Proxing occurs first, the ordering
;; here follows that in sclang.

(define (construct-ugen name rate? inputs mce? outputs special id)
  (let* ((inputs* (if mce?
                      (append2 inputs (mce-l mce?))
                      inputs))
         (rate (if rate?
                   rate?
                   (rate-select (map1 rate-of inputs*))))
         (u (make-ugen
             (if (symbol? name)
                 (symbol->string name)
                 name)
             rate
             inputs*
             (make-outputs outputs rate)
             special
             id)))
    (proxied (mced u))))


;; ugen/filter

(define-syntax define-filter
  (syntax-rules ()
    ((_ n (i ...) o)
     (define (n i ...)
       (construct-ugen 'n #f (list i ...) #f o 0 (make-uid 0))))))

(define-filter AllpassC (in maxdelaytime delaytime decaytime) 1)
(define-filter AllpassL (in maxdelaytime delaytime decaytime) 1)
(define-filter AllpassN (in maxdelaytime delaytime decaytime) 1)
(define-filter AmpComp (freq root exp) 1)
(define-filter AmpCompA (freq root minAmp rootAmp) 1)
(define-filter APF (in freq radius) 1)
(define-filter Balance2 (left right pos level) 1)
(define-filter Ball (in g damp friction) 1)
(define-filter BiPanB2 (inA inB azimuth gain) 3)
(define-filter BPF (in freq rq) 1)
(define-filter BPZ2 (in) 1)
(define-filter BRF (in freq rq) 1)
(define-filter BRZ2 (in) 1)
(define-filter BufAllpassC (buf in delaytime decaytime) 1)
(define-filter BufAllpassL (buf in delaytime decaytime) 1)
(define-filter BufAllpassN (buf in delaytime decaytime) 1)
(define-filter BufCombC (buf in delaytime decaytime) 1)
(define-filter BufCombL (buf in delaytime decaytime) 1)
(define-filter BufCombN (buf in delaytime decaytime) 1)
(define-filter BufDelayC (buf in delaytime) 1)
(define-filter BufDelayL (buf in delaytime) 1)
(define-filter BufDelayN (buf in delaytime) 1)
(define-filter Clip (in lo hi) 1)
(define-filter CombC (in maxdelaytime delaytime decaytime) 1)
(define-filter CombL (in maxdelaytime delaytime decaytime) 1)
(define-filter CombN (in maxdelaytime delaytime decaytime) 1)
(define-filter Compander (in control thresh slopeBelow slopeAbove clampTime relaxTime) 1)
(define-filter CompanderD (in thresh slopeBelow slopeAbove clampTime relaxTime) 1)
(define-filter Decay2 (in attackTime decayTime) 1)
(define-filter Decay (in decayTime) 1)
(define-filter DegreeToKey (bufnum in octave) 1)
(define-filter Delay1 (in) 1)
(define-filter Delay2 (in) 1)
(define-filter DelayC (in maxdelaytime delaytime) 1)
(define-filter DelayL (in maxdelaytime delaytime) 1)
(define-filter DelayN (in maxdelaytime delaytime) 1)
(define-filter DetectSilence (in amp time doneAction) 1)
(define-filter Done (src) 1)
(define-filter Fold (in lo hi) 1)
(define-filter Formlet (in freq attacktime decaytime) 1)
(define-filter FOS (in a0 a1 b1) 1)
(define-filter Free (in nodeID) 1)
(define-filter FreeVerb (in mix room damp) 1)
(define-filter FreeVerb2 (in1 in2 mix room damp) 2)
(define-filter FreeSelf (in) 1)
(define-filter FreeSelfWhenDone (in) 1)
(define-filter Gate (in trig) 1)
(define-filter Hasher (in) 1)
(define-filter Hilbert (in) 2)
(define-filter HPF (in freq) 1)
(define-filter HPZ1 (in) 1)
(define-filter HPZ2 (in) 1)
(define-filter ImageWarp (pic x y interpolationType) 1)
(define-filter Index (bufnum in) 1)
(define-filter InRange (in lo hi) 1)
(define-filter InRect (x y rect) 1)
(define-filter Integrator (in coef) 1)
(define-filter Lag2 (in lagTime) 1)
(define-filter Lag3 (in lagTime) 1)
(define-filter Lag (in lagTime) 1)
(define-filter LagControl () 1)
(define-filter LastValue (in diff) 1)
(define-filter Latch (in trig) 1)
(define-filter LeakDC (in coef) 1)
(define-filter LeastChange (a b) 1)
(define-filter Limiter (in level dur) 1)
(define-filter Linen (gate attackTime susLevel releaseTime doneAction) 1)
(define-filter LinExp (in srclo srchi dstlo dsthi) 1)
(define-filter LinLin (in srclo srchi dstlo dsthi) 1)
(define-filter LinPan2 (in pos level) 2)
(define-filter LinXFade2 (inA inB pan level) 1)
(define-filter LPF (in freq) 1)
(define-filter LPZ1 (in) 1)
(define-filter LPZ2 (in) 1)
(define-filter MantissaMask (in bits) 1)
(define-filter Median (length in) 1)
(define-filter MidEQ (in freq rq db) 1)
(define-filter MoogFF (in freq gain reset) 1)
(define-filter MostChange (a b) 1)
(define-filter MulAdd (a b c) 1)
(define-filter Normalizer (in level dur) 1)
(define-filter OnePole (in coef) 1)
(define-filter OneZero (in coef) 1)
(define-filter Pan2 (in pos level) 2)
(define-filter Pan4 (in xpos ypos level) 4)
(define-filter PanAz (numChans in pos level width orientation) 1)
(define-filter PanB2 (in azimuth gain) 3)
(define-filter PanB (in azimuth elevation gain) 3)
(define-filter Pause (in nodeID) 1)
(define-filter PauseSelf (in) 1)
(define-filter PauseSelfWhenDone (in) 1)
(define-filter Peak (trig reset) 1)
(define-filter PeakFollower (in decay) 1)
(define-filter PitchShift (in windowSize pitchRatio pitchDispersion timeDispersion) 1)
(define-filter Pluck (in trig maxdelaytime delaytime decaytime coef) 1)
(define-filter PulseCount (trig reset) 1)
(define-filter PulseDivider (trig div start) 1)
(define-filter Ramp (in lagTime) 1)
(define-filter Resonz (in freq bwr) 1)
(define-filter RHPF (in freq rq) 1)
(define-filter Ringz (in freq decaytime) 1)
(define-filter RLPF (in freq rq) 1)
(define-filter Rotate2 (x y pos) 2)
(define-filter RunningMax (in trig) 1)
(define-filter RunningMin (in trig) 1)
(define-filter RunningSum (in numsamp) 1)
(define-filter Schmidt (in lo hi) 1)
(define-filter SendTrig (in id value) 0)
(define-filter SetResetFF (trig reset) 1)
(define-filter Shaper (bufnum in) 1)
(define-filter Slew (in up dn) 1)
(define-filter Slope (in) 1)
(define-filter SOS (in a0 a1 a2 b1 b2) 1)
(define-filter Spring (in spring damp) 1)
(define-filter Stepper (trig reset min max step resetval) 1)
(define-filter Sweep (trig rate) 1)
(define-filter TBall (in g damp friction) 1)
(define-filter TDelay (in dur) 1)
(define-filter Timer (trig) 1)
(define-filter ToggleFF (trig) 1)
(define-filter TPulse (trig freq width) 1)
(define-filter Trapezoid (in a b c d) 1)
(define-filter Trig1 (in dur) 1)
(define-filter Trig (in dur) 1)
(define-filter TwoPole (in freq radius) 1)
(define-filter TwoZero (in freq radius) 1)
(define-filter Vibrato (freq rate depth delay onset rateVariation depthVariation iphase) 1)
(define-filter Wrap (in lo hi) 1)
(define-filter WrapIndex (bufnum in) 1)
(define-filter XFade2 (inA inB pan level) 1)
(define-filter XY (xscale yscale xoff yoff rot rate) 1)
(define-filter ZeroCrossing (in) 1)

(define-syntax define-filter/n
  (syntax-rules ()
    ((_ n (i ...))
     (define (n nc i ...)
       (if (not (integer? nc))
           (error "illegal channel count" 'n nc)
           #f)
       (let ((l (list i ...)))
         (construct-ugen 'n #f l #f nc 0 (make-uid 0)))))))

(define-filter/n DecodeB2 (w x y orientation))
(define-filter/n Silent ())
(define-filter/n TGrains (trigger bufnum rate centerPos dur pan amp interp))

(define-syntax define-filter*
  (syntax-rules ()
    ((_ n (i ... v) o)
     (define (n i ... v)
       (construct-ugen 'n #f (list i ...) v o 0 (make-uid 0))))))

(define-filter* BufWr (bufnum phase loop inputArray) 1)
(define-filter* Klank (input freqscale freqoffset decayscale specificationsArrayRef) 1)
(define-filter* Poll (trig in trigId label) 0)
(define-filter* RecordBuf (bufnum offset recLevel preLevel run loop trigger inputArray) 1)
(define-filter* Select (which array) 1)
(define-filter* TWindex (in normalize array) 1)

(define-filter* DiskOut (bufnum channelsArray) 0)
(define-filter* LocalOut (channelsArray) 0)
(define-filter* OffsetOut (bus channelsArray) 0)
(define-filter* Out (bus channelsArray) 0)
(define-filter* ReplaceOut (bus channelsArray) 0)
(define-filter* ScopeOut (inputArray bufnum) 0)
(define-filter* XOut (bus xfade channelsArray) 0)

(define-syntax define-filter/id
  (syntax-rules ()
    ((_ n (i ...) o)
     (define (n i ...)
       (construct-ugen 'n #f (list i ...) #f o 0 (unique-uid))))))

(define-filter/id CoinGate (prob in) 1)
(define-filter/id TExpRand (lo hi trig) 1)
(define-filter/id TIRand (lo hi trig) 1)
(define-filter/id TRand (lo hi trig) 1)

;; Keyed filter, rate is determined by a known input.

(define-syntax define-filter/k
  (syntax-rules ()
    ((_ n (i ...) o k)
     (define (n i ...)
       (let ((l (list i ...)))
         (construct-ugen 'n (rate-of (list-ref l k)) l #f o 0 (make-uid 0)))))))

(define-filter/k Demand (trig reset demandUGens) 1 0)

;; JITLIB

(define (TChoose trig array)
  (Select (TIRand 0 (length (mce-channels array)) trig) array))

(define (TWChoose trig array weights normalize)
  (Select (TWindex trig normalize weights) array))


;; ugen/graph

;; Return the <list> of all elements of the UGen graph rooted at `u'.
;; Nodes are values of type <ugen>|<proxy>|<control*>|<number>.

(define (graph-nodes u)
  (cond
   ((ugen? u)       (cons u (splice (map1 graph-nodes (ugen-inputs u)))))
   ((proxy? u)      (cons u (graph-nodes (proxy-ugen u))))
   ((control*? u)   (list u))
   ((number? u)     (list u))
   ((mce? u)        (concat (map1 graph-nodes (mce-channels u))))
   ((mrg? u)        (concat (map1 graph-nodes (mrg-roots u))))
   (else            (error "graph-nodes: illegal value" u))))

;; Depth first traversal

(define (graph-traverse f u)
  (let ((f* (lambda (u) (graph-traverse f u))))
    (cond
     ((ugen? u)  (f (make-ugen (ugen-name u)
                               (ugen-rate u)
                               (map1 f* (ugen-inputs u))
                               (ugen-outputs u)
                               (ugen-special u)
                               (ugen-id u))))
     ((proxy? u) (f (make-proxy (graph-traverse f (proxy-ugen u))
                                (proxy-port u))))
     ((mce? u)   (f (make-mce (map1 f* (mce-channels u)))))
     ((mrg? u)   (f (make-mrg (map1 f* (mrg-roots u)))))
     (else       u))))

;; Filters over nodes.

(define (graph-constants u)
  (delete-duplicates
   (filter number? (graph-nodes u))
   equal?))

(define (graph-controls* u)
  (delete-duplicates
   (filter control*? (graph-nodes u))
   equal?))

;; Ordering is *essential* - the antecedents of `u' are depth first,
;; `u' is the last element.

(define (graph-ugens u)
  (delete-duplicates
   (reverse (filter ugen? (graph-nodes u)))
   equal?))

(define (ugen-close u nn cc uu)
  (if (not (ugen-validate u))
      (error "ugen-close: ugen invalid" u)
      (make-ugen (ugen-name u)
                 (ugen-rate u)
                 (map1 (lambda (i)
			 (input*->input i nn cc uu))
		       (ugen-inputs u))
                 (ugen-outputs u)
                 (ugen-special u)
                 (ugen-id u))))

(define (graph->graphdef name u)
  (let* ((nn  (graph-constants u))
         (cc  (graph-controls* u))
         (uu  (graph-ugens u))
         (uu* (if (null? cc) uu (cons (implicit-ugen cc) uu))))
    (make-graphdef
     name
     nn
     (map1 control*-default cc)
     (map1 (lambda (c) (control*->control c cc)) cc)
     (map1 (lambda (u) (ugen-close u nn cc uu*)) uu*))))


;; ugen/implicit

;; Gloss, k-rate only, no lag.

(define (implicit-ugen cc)
  (make-ugen "Control"
             kr
             nil
             (map1 make-output (make-list (length cc) kr))
             0
             (make-uid 0)))


;; ugen/input

;; In the context of graphdef serialization <ugen> inputs must be
;; re-written into an <input> form.

(define (calculate-index n nn)
  (let ((i (list-index (lambda (e) (equal? e n)) nn)))
    (if (not i)
        (error "calculate-index: not located" n nn)
        i)))

(define (number->input n nn)
  (make-input -1 (calculate-index n nn)))

(define (control*->control c cc)
  (make-control (control*-name c) (calculate-index c cc)))

(define (control*->input c cc)
  (make-input 0 (calculate-index c cc)))

(define (ugen->input u uu)
  (make-input (calculate-index u uu) 0))

(define (proxy->input p uu)
  (make-input (calculate-index (proxy-ugen p) uu)
              (proxy-port p)))

(define (input*->input i nn cc uu)
  (cond
   ((number? i)   (number->input i nn))
   ((control*? i) (control*->input i cc))
   ((ugen? i)     (ugen->input i uu))
   ((proxy? i)    (proxy->input i uu))
   ((mce? i)      (error "input*->input: mce?" i))
   ((mrg? i)      (error "input*->input: mrg?" i))
   (else          (error "input*->input: illegal input" i))))


;; ugen/mce

(define (mce-degree m)
  (length (mce-channels m)))

(define (mce-ref m n)
  (list-ref (mce-channels m) n))

(define (mce-reverse u)
  (make-mce (reverse (mce-channels u))))

(define (mce-required? u)
  (not (null? (filter mce? (ugen-inputs u)))))

(define (mce-extend n i)
  (if (mce? i)
      (extend (mce-channels i) n)
      (make-list n i)))

(define (mce-transform u)
  (ugen-transform
   u
   (lambda (n r i o s d)
     (let* ((f (lambda (i*) (make-ugen n r i* o s d)))
            (m (maximum (map1 mce-degree (filter mce? i))))
            (e (lambda (i) (mce-extend m i)))
            (i* (transpose (map1 e i))))
       (make-mce (map1 f i*))))))

(define (mced u)
  (if (mce-required? u)
      (mce-transform u)
      u))

(define (mce-l u)
  (if (mce? u)
      (mce-channels u)
      (list u)))


;; ugen/operator

;; Operators may, when applied to numbers, yield numbers.

(define-syntax define-unary-operator
  (syntax-rules ()
    ((_ n s f)
     (define (n a)
       (if (and (number? a) f)
           (f a)
           (construct-ugen 'UnaryOpUGen #f (list a) #f 1 s (make-uid 0)))))))

(define-unary-operator Neg 0 -)
(define-unary-operator Not 1 #f)
(define-unary-operator IsNil 2 #f)
(define-unary-operator NotNil 3 #f)
(define-unary-operator BitNot 4 #f)
(define-unary-operator Abs 5 abs)
(define-unary-operator AsFloat 6 #f)
(define-unary-operator AsInt 7 #f)
(define-unary-operator Ceil 8 ceiling)
(define-unary-operator Floor 9 floor)
(define-unary-operator Frac 10 #f)
(define-unary-operator Sign 11 #f)
(define-unary-operator Squared 12 squared)
(define-unary-operator Cubed 13 cubed)
(define-unary-operator Sqrt 14 sqrt)
(define-unary-operator Exp 15 #f)
(define-unary-operator Recip 16 recip)
(define-unary-operator MIDICPS 17 midicps)
(define-unary-operator CPSMIDI 18 cpsmidi)
(define-unary-operator MIDIRatio 19 midiratio)
(define-unary-operator RatioMIDI 20 ratiomidi)
(define-unary-operator DbAmp 21 dbamp)
(define-unary-operator AmpDb 22 ampdb)
(define-unary-operator OctCPS 23 octcps)
(define-unary-operator CPSOct 24 cpsoct)
(define-unary-operator Log 25 log)
(define-unary-operator Log2 26 log2)
(define-unary-operator Log10 27 log10)
(define-unary-operator Sin 28 sin)
(define-unary-operator Cos 29 cos)
(define-unary-operator Tan 30 tan)
(define-unary-operator ArcSin 31 asin)
(define-unary-operator ArcCos 32 acos)
(define-unary-operator ArcTan 33 atan)
(define-unary-operator SinH 34 #f)
(define-unary-operator CosH 35 #f)
(define-unary-operator TanH 36 #f)
(define-unary-operator _Rand 37 #f) ;;_rand
(define-unary-operator Rand2 38 #f) ;;rand2
(define-unary-operator _LinRand 39 #f)
(define-unary-operator BiLinRand 40 #f)
(define-unary-operator Sum3Rand 41 #f)
(define-unary-operator Distort 42 #f)
(define-unary-operator SoftClip 43 #f)
(define-unary-operator Coin 44 #f)
(define-unary-operator DigitValue 45 #f)
(define-unary-operator Silence 46 #f)
(define-unary-operator Thru 47 #f)
(define-unary-operator RectWindow 48 #f)
(define-unary-operator HanWindow 49 #f)
(define-unary-operator WelchWindow 50 #f)
(define-unary-operator TriWindow 51 #f)
(define-unary-operator _Ramp 52 #f)
(define-unary-operator SCurve 53 #f)

(define-syntax define-binary-operator
  (syntax-rules ()
    ((_ n s f)
     (define (n a b)
       (if (and (number? a)
                (number? b)
                f)
           (f a b)
           (construct-ugen 'BinaryOpUGen #f (list a b) #f 1 s (make-uid 0)))))))

(define-binary-operator Add 0 +)
(define-binary-operator Sub 1 -)
(define-binary-operator Mul 2 *)
(define-binary-operator IDiv 3 #f)
(define-binary-operator FDiv 4 /)
(define-binary-operator Mod 5 #f)
(define-binary-operator EQ 6 #f)
(define-binary-operator NE 7 #f)
(define-binary-operator LT 8 #f)
(define-binary-operator GT 9 #f)
(define-binary-operator LE 10 #f)
(define-binary-operator GE 11 #f)
(define-binary-operator Min 12 min)
(define-binary-operator Max 13 max)
(define-binary-operator BitAnd 14 #f)
(define-binary-operator BitOr 15 #f)
(define-binary-operator BitXor 16 #f)
(define-binary-operator LCM 17 #f)
(define-binary-operator GCD 18 #f)
(define-binary-operator Round 19 #f)
(define-binary-operator RoundUp 20 #f)
(define-binary-operator Trunc 21 #f)
(define-binary-operator Atan2 22 #f)
(define-binary-operator Hypot 23 #f)
(define-binary-operator Hypotx 24 #f)
(define-binary-operator Pow 25 #f)
(define-binary-operator ShiftLeft 26 #f)
(define-binary-operator ShiftRight 27 #f)
(define-binary-operator UnsignedShift 28 #f)
(define-binary-operator Fill 29 #f)
(define-binary-operator Ring1 30 #f)
(define-binary-operator Ring2 31 #f)
(define-binary-operator Ring3 32 #f)
(define-binary-operator Ring4 33 #f)
(define-binary-operator DifSqr 34 #f)
(define-binary-operator SumSqr 35 #f)
(define-binary-operator SqrSum 36 #f)
(define-binary-operator SqrDif 37 #f)
(define-binary-operator AbsDif 38 #f)
(define-binary-operator Thresh 39 #f)
(define-binary-operator AMClip 40 #f)
(define-binary-operator ScaleNeg 41 #f)
(define-binary-operator Clip2 42 #f)
(define-binary-operator Excess 43 #f)
(define-binary-operator Fold2 44 #f)
(define-binary-operator Wrap2 45 #f)
(define-binary-operator FirstArg 46 #f)
(define-binary-operator RandRange 47 #f)
(define-binary-operator ExpRandRange 48 #f)

;; N-ary variants

(define (Mul* . l) (foldl Mul 1 l))
(define (Add* . l) (foldl Add 0 l))


;;


(define-syntax define-oscillator
  (syntax-rules ()
    ((_ n (i ...) o)
     (define (n r i ...)
       (construct-ugen (quote n) r (list i ...) #f o 0 (make-uid 0))))))

(define-oscillator Amplitude (in attackTime releaseTime) 1)
(define-oscillator Blip (freq numharm) 1)
(define-oscillator COsc (bufnum freq beats) 1)
(define-oscillator Crackle (chaosParam) 1)
(define-oscillator CuspL (freq a b xi) 1)
(define-oscillator CuspN (freq a b xi) 1)
(define-oscillator DemandEnvGen (level dur shape curve gate reset levelScale levelBias timeScale doneAction) 1)
(define-oscillator FBSineC (freq im fb a c xi yi) 1)
(define-oscillator FBSineL (freq im fb a c xi yi) 1)
(define-oscillator FBSineN (freq im fb a c xi yi) 1)
(define-oscillator Formant (fundfreq formfreq bwfreq) 1)
(define-oscillator FSinOsc (freq iphase) 1)
(define-oscillator GbmanL (freq xi yi) 1)
(define-oscillator GbmanN (freq xi yi) 1)
(define-oscillator Gendy1 (ampdist durdist adparam ddparam minfreq maxfreq ampscale durscale initCPs knum) 1)
(define-oscillator Gendy2 (ampdist durdist adparam ddparam minfreq maxfreq ampscale durscale initCPs knum a c) 1)
(define-oscillator Gendy3 (ampdist durdist adparam ddparam freq ampscale durscale initCPs knum) 1)
(define-oscillator HenonC (freq a b x0 x1) 1)
(define-oscillator HenonL (freq a b x0 x1) 1)
(define-oscillator HenonN (freq a b x0 x1) 1)
(define-oscillator Impulse (freq phase) 1)
(define-oscillator KeyState (key min max lag) 1)
(define-oscillator LatoocarfianC (freq a b c d xi yi) 1)
(define-oscillator LatoocarfianL (freq a b c d xi yi) 1)
(define-oscillator LatoocarfianN (freq a b c d xi yi) 1)
(define-oscillator LinCongC (freq a c m xi) 1)
(define-oscillator LinCongL (freq a c m xi) 1)
(define-oscillator LinCongN (freq a c m xi) 1)
(define-oscillator LFCub (freq iphase) 1)
(define-oscillator LFPar (freq iphase) 1)
(define-oscillator LFPulse (freq iphase width) 1)
(define-oscillator LFSaw (freq iphase) 1)
(define-oscillator LFTri (freq iphase) 1)
(define-oscillator Line (start end dur doneAction) 1)
(define-oscillator Logistic (chaosParam freq) 1)
(define-oscillator LorenzL (freq s r b h xi yi zi) 1)
(define-oscillator Osc (bufnum freq phase) 1)
(define-oscillator OscN (bufnum freq phase) 1)
(define-oscillator Phasor (trig rate start end resetPos) 1)
(define-oscillator PSinGrain (freq dur amp) 1)
(define-oscillator Pulse (freq width) 1)
(define-oscillator QuadC (freq a b c xi) 1)
(define-oscillator QuadL (freq a b c xi) 1)
(define-oscillator QuadN (freq a b c xi) 1)
(define-oscillator Saw (freq) 1)
(define-oscillator SinOsc (freq phase) 1)
(define-oscillator SinOscFB (freq feedback) 1)
(define-oscillator StandardL (freq k xi yi) 1)
(define-oscillator StandardN (freq k xi yi) 1)
(define-oscillator SyncSaw (syncFreq sawFreq) 1)
(define-oscillator VarSaw (freq iphase width) 1)
(define-oscillator VOsc3 (bufpos freq1 freq2 freq3) 1)
(define-oscillator VOsc (bufpos freq phase) 1)
(define-oscillator XLine (start end dur doneAction) 1)

(define-oscillator MouseButton (minval maxval lag) 1)
(define-oscillator MouseX (min max warp lag) 1)
(define-oscillator MouseY (min max warp lag) 1)
(define-oscillator SharedIn () 1)

(define-oscillator BufChannels (buf) 1)
(define-oscillator BufDur (buf) 1)
(define-oscillator BufFrames (buf) 1)
(define-oscillator BufRateScale (buf) 1)
(define-oscillator BufSampleRate (buf) 1)
(define-oscillator BufSamples (buf) 1)

(define (without n l)
  (append2 (take l n) (drop l (+ n 1))))

(define-syntax define-oscillator/n
  (syntax-rules ()
    ((_ n (i ...))
     (define (n nc r i ...)
       (if (not (integer? nc))
           (error "illegal channel count:" 'n nc)
           #f)
       (let ((l (list i ...)))
         (construct-ugen 'n r l #f nc 0 (make-uid 0)))))))

(define-oscillator/n BufRd (bufnum phase loop interpolation))
(define-oscillator/n DiskIn (bufnum))
(define-oscillator/n In (bus))
(define-oscillator/n LocalIn ())
(define-oscillator/n TrigControl ())

(define (BufRdN nc r b p l) (BufRd nc r b p l 1))
(define (BufRdL nc r b p l) (BufRd nc r b p l 2))
(define (BufRdC nc r b p l) (BufRd nc r b p l 4))

(define-syntax define-oscillator*
  (syntax-rules ()
    ((_ n (i ... v) o)
     (define (n r i ... v)
       (construct-ugen 'n r (list i ...) v o 0 (make-uid 0))))))

(define-oscillator* Duty (dur reset doneAction level) 1)
(define-oscillator* EnvGen (gate levelScale levelBias timeScale doneAction envelopeArray) 1)
(define-oscillator* Klang (freqscale freqoffset specArray) 1)
(define-oscillator* TDuty (dur reset doneAction level) 1)

(define-syntax define-oscillator/id
  (syntax-rules ()
    ((_ n (i ...) o)
     (define (n r i ...)
       (construct-ugen 'n r (list i ...) #f o 0 (unique-uid))))))

(define-oscillator/id BrownNoise () 1)
(define-oscillator/id ClipNoise () 1)
(define-oscillator/id Dust (density) 1)
(define-oscillator/id Dust2 (density) 1)
(define-oscillator/id GrayNoise () 1)
(define-oscillator/id LFClipNoise (freq) 1)
(define-oscillator/id LFDClipNoise (freq) 1)
(define-oscillator/id LFDNoise0 (freq) 1)
(define-oscillator/id LFDNoise1 (freq) 1)
(define-oscillator/id LFDNoise3 (freq) 1)
(define-oscillator/id LFNoise0 (freq) 1)
(define-oscillator/id LFNoise1 (freq) 1)
(define-oscillator/id LFNoise2 (freq) 1)
(define-oscillator/id NoahNoise () 1)
(define-oscillator/id PinkNoise () 1)
(define-oscillator/id RandID (id) 1)
(define-oscillator/id RandSeed (trig seed) 1)
(define-oscillator/id WhiteNoise () 1)


;; ugen/proxied

(define (proxied u)
  (cond
   ((ugen? u) (let* ((o (ugen-outputs u))
                     (n (length o)))
                (if (< n 2)
                    u
                    (make-mce (map1 (lambda (i) (make-proxy u i))
				    (iota n))))))
   ((mce? u)  (make-mce (map1 proxied (mce-channels u))))))


;; ugen/specialized

(define-syntax define-specialized
  (syntax-rules ()
    ((_ n (i ...) o r)
     (define (n i ...)
       (construct-ugen 'n r (list i ...) #f o 0 (make-uid 0))))))

(define-specialized K2A (in) 1 ar)
(define-specialized Pitch (in initFreq minFreq maxFreq execFreq maxBinsPerOctave median ampThreshold peakThreshold downSample) 2 kr)

(define-specialized FFT (buf in hop wintype active) 1 kr)
(define (FFT* buf in) (FFT buf in 0.5 0 1))
(define-specialized IFFT (buf wintype) 1 ar)
(define (IFFT* buf) (IFFT buf 0))

(define-specialized Unpack1FFT (chain bufsize binindex whichmeasure) 1 dr)

(define-specialized Convolution (in kernel frameSize) 1 ar)
(define-specialized Convolution2 (in bufnum trigger frameSize) 1 ar)

(define-specialized PV_Add (bufA bufB) 1 kr)
(define-specialized PV_BinScramble (buffer wipe width trig) 1 kr)
(define-specialized PV_BinShift (buffer stretch shift) 1 kr)
(define-specialized PV_BinWipe (bufferA bufferB wipe) 1 kr)
(define-specialized PV_BrickWall (buffer wipe) 1 kr)
(define-specialized PV_ConformalMap (buffer real imag) 1 kr)
(define-specialized PV_Copy (bufferA bufferB) 1 kr)
(define-specialized PV_CopyPhase (bufferA bufferB) 1 kr)
(define-specialized PV_Diffuser (buffer trig) 1 kr)
(define-specialized PV_HainsworthFoote (buffer proph propf threshold waittime) 1 ar)
(define-specialized PV_JensenAndersen (buffer propsc prophfe prophfc propsf threshold waittime) 1 ar)
(define-specialized PV_LocalMax (buffer threshold) 1 kr)
(define-specialized PV_MagAbove (buffer threshold) 1 kr)
(define-specialized PV_MagBelow (buffer threshold) 1 kr)
(define-specialized PV_MagClip (buffer threshold) 1 kr)
(define-specialized PV_MagFreeze (buffer freeze) 1 kr)
(define-specialized PV_MagMul () 1 kr)
(define-specialized PV_MagNoise (buffer) 1 kr)
(define-specialized PV_MagShift () 1 kr)
(define-specialized PV_MagSmear (buffer bins) 1 kr)
(define-specialized PV_MagSquared () 1 kr)
(define-specialized PV_Max () 1 kr)
(define-specialized PV_Min () 1 kr)
(define-specialized PV_Mul () 1 kr)
(define-specialized PV_PhaseShift270 (buffer) 1 kr)
(define-specialized PV_PhaseShift90 (buffer) 1 kr)
(define-specialized PV_PhaseShift (buffer shift) 1 kr)
(define-specialized PV_RandComb (buffer wipe trig) 1 kr)
(define-specialized PV_RandWipe (bufferA bufferB wipe trig) 1 kr)
(define-specialized PV_RectComb2 () 1 kr)
(define-specialized PV_RectComb (buffer numTeeth phase width) 1 kr)

(define-specialized SharedOut (bus channelsArray) 0 kr)

(define-syntax define-specialized/c
  (syntax-rules ()
    ((_ n o r)
     (define n
       (construct-ugen 'n r nil #f o 0 (make-uid 0))))))

(define-specialized/c ControlRate 1 ir)
(define-specialized/c NumAudioBuses 1 ir)
(define-specialized/c NumBuffers 1 ir)
(define-specialized/c NumControlBuses 1 ir)
(define-specialized/c NumInputBuses 1 ir)
(define-specialized/c NumOutputBuses 1 ir)
(define-specialized/c NumRunningSynths 1 ir)
(define-specialized/c RadiansPerSample 1 ir)
(define-specialized/c SampleDur 1 ir)
(define-specialized/c SampleRate 1 ir)
(define-specialized/c SubsampleOffset 1 ir)

(define-syntax define-specialized*
  (syntax-rules ()
    ((_ n (i ... v) o r)
     (define (n i ... v)
       (construct-ugen 'n r (list i ...) v o 0 (make-uid 0))))))

(define-specialized* PackFFT (chain bufsize from to z magsphases) 1 kr)

(define-syntax define-specialized/n
  (syntax-rules ()
    ((_ n (i ...) r)
     (define (n nc i ...)
       (if (not (integer? nc))
           (error "illegal channel count:" 'n nc)
           #f)
       (let ((l (list i ...)))
         (construct-ugen 'n r l #f nc 0 (make-uid 0)))))))

(define-specialized/n InFeedback (bus) ar)
(define-specialized/n InTrig (bus) kr)
(define-specialized/n GrainBuf (tr dur sndbuf rate pos interp pan envbuf) ar)
(define-specialized/n GrainFM (tr dur carfreq modfreq index pan envbuf) ar)
(define-specialized/n GrainIn (tr dur in pan envbuf) ar)
(define-specialized/n GrainSin (tr dur freq pan envbuf) ar)
(define-specialized/n LagIn (bus lag) kr)
(define-specialized/n PlayBuf (bufnum rate trigger startPos loop) ar)
(define-specialized/n Warp1 (bufnum pointer freqScale windowSize envbufnum overlaps windowRandRatio interp) ar)

(define-syntax define-specialized/id
  (syntax-rules ()
    ((_ n (i ...) o r)
     (define (n i ...)
       (construct-ugen 'n r (list i ...) #f o 0 (unique-uid))))))

(define-specialized/id Dbufrd (bufnum phase loop) 1 dr)
(define-specialized/id Dbrown (length lo hi step) 1 dr)
(define-specialized/id Dibrown (length lo hi step) 1 dr)
(define-specialized/id Diwhite (length lo hi) 1 dr)
(define-specialized/id Dgeom (length start grow) 1 dr)
(define-specialized/id Dseries (length start step) 1 dr)
(define-specialized/id Dwhite (length lo hi) 1 dr)
(define-specialized/id ExpRand (lo hi) 1 ir)
(define-specialized/id IRand (lo hi) 1 ir)
(define-specialized/id LinRand (lo hi minmax) 1 ir)
(define-specialized/id NRand (lo hi n) 1 ir)
(define-specialized/id Rand (lo hi) 1 ir)

(define-syntax define-specialized*/id
  (syntax-rules ()
    ((_ n (i ... v) o r)
     (define (n i ... v)
       (construct-ugen 'n r (list i ...) v o 0 (unique-uid))))))

(define-specialized*/id Drand (length array) 1 dr)
(define-specialized*/id Dseq (length array) 1 dr)
(define-specialized*/id Dser (length array) 1 dr)
(define-specialized*/id Dswitch1 (length array) 1 dr)
(define-specialized*/id Dxrand (length array) 1 dr)


;; u8/decode

(define (decode-u8  v) (bytevector-u8-ref v 0))
(define (decode-u16 v) (bytevector-u16-ref v 0))
(define (decode-u32 v) (bytevector-u32-ref v 0))
(define (decode-u64 v) (bytevector-u64-ref v 0))
(define (decode-i8  v) (bytevector-s8-ref v 0))
(define (decode-i16 v) (bytevector-s16-ref v 0))
(define (decode-i32 v) (bytevector-s32-ref v 0))
(define (decode-i64 v) (bytevector-s64-ref v 0))
(define (decode-f32 v) (bytevector-ieee-single-ref v 0))
(define (decode-f64 v) (bytevector-ieee-double-ref v 0))

;; inclusive, exclusive

(define (section v l r)
  (let* ((n (- r l))
         (w (make-bytevector n 0)))
    (bytevector-copy! v l w 0 n)
    w))

(define (decode-str v)
  (let ((l (bytevector->u8-list v)))
    (list->string (map1 integer->char l))))

(define (decode-pstr v)
  (let* ((n (decode-u8 v))
         (w (section v 1 (+ n 1))))
    (decode-str w)))

(define (index v x)
  (letrec ((f (lambda (i)
                (if (= (bytevector-u8-ref v i) x)
                    i
                    (f (+ i 1))))))
    (f 0)))

(define (decode-cstr v)
  (let* ((n (index v 0))
         (w (section v 0 n)))
    (decode-str w)))


;;
(define be (endianness big))

(define (make-and-set* f k n)
  (let ((v (make-bytevector k 0)))
    (f v 0 n)
    v))

(define (make-and-set f k n)
  (let ((v (make-bytevector k 0)))
    (f v 0 n be)
    v))

(define (encode-u8 n)  (make-and-set* bytevector-u8-set! 1 n))
(define (encode-u16 n) (make-and-set bytevector-u16-set! 2 n))
(define (encode-u32 n) (make-and-set bytevector-u32-set! 4 n))
(define (encode-u64 n) (make-and-set bytevector-u64-set! 8 n))
(define (encode-i8 n)  (make-and-set* bytevector-s8-set! 1 n))
(define (encode-i16 n) (make-and-set bytevector-s16-set! 2 n))
(define (encode-i32 n) (make-and-set bytevector-s32-set! 4 n))
(define (encode-i64 n) (make-and-set bytevector-s64-set! 8 n))
(define (encode-f32 n) (make-and-set bytevector-ieee-single-set! 4 n))
(define (encode-f64 n) (make-and-set bytevector-ieee-double-set! 8 n))

(define (encode-str s)
  (u8-list->bytevector
   (map1 char->integer (string->list s))))

(define (encode-pstr s)
  (u8-list->bytevector
   (cons (string-length s) (map1 char->integer (string->list s)))))

(define (encode-cstr s)
  (u8-list->bytevector
   (append2 (map1 char->integer (string->list s)) (list 0))))


;; u8/read

(define (read-bstr n)
  (get-bytevector-n (current-input-port) n) )

(define (read-i16) (decode-i16 (read-bstr 2)))
(define (read-u16) (decode-u16 (read-bstr 2)))
(define (read-i32) (decode-i32 (read-bstr 4)))
(define (read-u32) (decode-u32 (read-bstr 4)))
(define (read-i64) (decode-i64 (read-bstr 8)))
(define (read-u64) (decode-u64 (read-bstr 8)))
(define (read-f32) (decode-f32 (read-bstr 4)))
(define (read-f64) (decode-f64 (read-bstr 8)))

(define (read-pstr)
  (let* ((p (current-input-port))
         (n (lookahead-u8 p))
         (v (read-bstr (+ n 1))))
    (decode-pstr v)))

(define (read-cstr)
  (let loop ((l nil)
             (b (get-u8 (current-input-port))))
    (if (= b 0)
        (decode-cstr (u8-list->bytevector (reverse l)))
        (loop (cons b l) (get-u8 (current-input-port))))))


;; u8/u8t

(define (u8t? t)
  (or (null? t)
      (let ((e (car t)))
        (and (or (bytevector? e)
                 (u8t? e))
             (every u8t? (cdr t))))))

(define (u8t->bytevector t)
  (let* ((l (flatten t))
         (n (map1 bytevector-length l))
         (m (sum n))
         (v (make-bytevector m)))
    (let loop ((i 0)
               (l l)
               (n n))
      (if (null? l)
          v
          (let ((l0 (car l))
                (n0 (car n)))
            (bytevector-copy! l0 0 v i n0)
            (loop (+ i n0) (cdr l) (cdr n)))))))