zzkt/rsc3
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

remove rnrs dependencies and improve racket comparability

Browse source
This commit is contained in:
nik gaffney 2022-08-24 13:15:13 +02:00
parent a25985dab2
commit d37f0a2e03
7 changed files with 1019 additions and 1143 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

169
rhs/rhs.rkt
View file

@ -13,31 +13,9 @@ Licensed under GPL (2 or 3? FIXME)
|# |#
(require rnrs)
(provide (all-defined-out)) (provide (all-defined-out))
;; to fix rnrs compatibility
#|
(define exact inexact->exact)
(define inexact exact->inexact)
(define mod remainder)
|#
;; JBC, 2014-- looks like most of these library functions have
;; equivalents in Racket....
;; quakehead: I'm assuming these functions are to handle the port of rsc3 from haskell to scheme.
;; this table has basic list functions in haskell vs racket:
;; https://artyom.me/learning-racket-1#interlude-list-functions
;; copied here: https://gist.github.com/quakehead/42b25c8891565cf9f761
;; prelude.scm ;;;;;;;;;;;;;;;;;;;;;;
;; enumFromThenTo :: a -> a -> a -> [a] ;; enumFromThenTo :: a -> a -> a -> [a]
(define enum-from-then-to (define enum-from-then-to
(letrec ((efdt (letrec ((efdt
@ -54,47 +32,13 @@ Licensed under GPL (2 or 3? FIXME)
(lambda (i j) (lambda (i j)
(enum-from-then-to i (succ i) j))) (enum-from-then-to i (succ i) j)))
;; even :: (Integral a) => a -> Bool
(define even
even?)
;; odd :: (Integral a) => a -> Bool
(define odd
odd?)
;; pred :: a -> a
(define pred
(lambda (x)
(- x 1)))
;; signum :: Num a => a -> a
(define signum
(lambda (x)
(cond ((> x 0) 1)
((< x 0) -1)
(else 0))))
;; succ :: a -> a ;; succ :: a -> a
(define succ (define succ
(lambda (x) (lambda (x)
(+ x 1))) (+ x 1)))
;; undefined :: a
(define undefined
(lambda ()
(error "undefined" "undefined")))
;; tuple.scm ;;;;;;;;;;;; ;; tuple.scm ;;;;;;;;;;;;
;; curry :: ((a, b) -> c) -> a -> b -> c
(define curry
(lambda (f)
(lambda (x y)
(f (tuple2 x y)))))
(struct duple (p q)) (struct duple (p q))
;; fst :: (a, b) -> a ;; fst :: (a, b) -> a
@ -109,16 +53,8 @@ Licensed under GPL (2 or 3? FIXME)
(define tuple2 (define tuple2
duple) duple)
;; uncurry :: (a -> b -> c) -> (a, b) -> c
(define uncurry
(lambda (f)
(lambda (xy)
(f (fst xy) (snd xy)))))
;; data/ord.scm ;;;;;;;;;;;;;;;; ;; data/ord.scm ;;;;;;;;;;;;;;;;
;; data Ordering = LT | EQ | GT ;; data Ordering = LT | EQ | GT
;; compare :: (Ord a) => a -> a -> Ordering ;; compare :: (Ord a) => a -> a -> Ordering
@ -139,22 +75,14 @@ Licensed under GPL (2 or 3? FIXME)
(if (< x y) x y))) (if (< x y) x y)))
;; data/function.scm ;;;;;;;;;;;;;;;;;; ;; data/function.scm ;;;;;;;;;;;;;;;;;;
;; (.) :: (b -> c) -> (a -> b) -> a -> c ;; (.) :: (b -> c) -> (a -> b) -> a -> c
(define compose (define compose
(lambda (f g) (lambda (f g)
(lambda (x) (lambda (x)
(f (g x))))) (f (g x)))))
;; const :: a -> b -> a
(define const
(lambda (x)
(lambda (_)
x)))
;; flip :: (a -> b -> c) -> b -> a -> c ;; flip :: (a -> b -> c) -> b -> a -> c
(define flip (define flip
(lambda (f) (lambda (f)
@ -166,8 +94,6 @@ Licensed under GPL (2 or 3? FIXME)
(lambda (x) (lambda (x)
x)) x))
;; data/list.scm ;;;;;;;;;;;;;;;;;;;;;; ;; data/list.scm ;;;;;;;;;;;;;;;;;;;;;;
;; all :: (a -> Bool) -> [a] -> Bool ;; all :: (a -> Bool) -> [a] -> Bool
@ -177,20 +103,6 @@ Licensed under GPL (2 or 3? FIXME)
#t #t
(and (f (head l)) (all f (tail l)))))) (and (f (head l)) (all f (tail l))))))
;; and :: [Bool] -> Bool
(define all-true
(lambda (l)
(if (null? l)
#t
(and (head l) (all-true (tail l))))))
;; any :: (a -> Bool) -> [a] -> Bool
(define any
(lambda (f l)
(if (null? l)
#f
(or (f (head l)) (any f (tail l))))))
;; (++) :: [a] -> [a] -> [a] ;; (++) :: [a] -> [a] -> [a]
(define append2 (define append2
(lambda (a b) (lambda (a b)
@ -198,11 +110,6 @@ Licensed under GPL (2 or 3? FIXME)
b b
(cons (head a) (append2 (tail a) b))))) (cons (head a) (append2 (tail a) b)))))
;; break :: (a -> Bool) -> [a] -> ([a],[a])
(define break
(lambda (p l)
(span (compose not p) l)))
;; concat :: [[a]] -> [a] ;; concat :: [[a]] -> [a]
(define concat (define concat
(lambda (l) (lambda (l)
@ -243,10 +150,6 @@ Licensed under GPL (2 or 3? FIXME)
(drop-while p (tail l)) (drop-while p (tail l))
l)))) l))))
;; elem :: (Eq a) => a -> [a] -> Bool
(define elem
(lambda (x l)
(any (lambda (y) (equal? x y)) l)))
;; elemIndex :: Eq a => a -> [a] -> Maybe Int ;; elemIndex :: Eq a => a -> [a] -> Maybe Int
(define elem-index (define elem-index
@ -403,19 +306,10 @@ Licensed under GPL (2 or 3? FIXME)
(head l) (head l)
(last xs))))) (last xs)))))
;; mlength :: [a] -> Int
(define mlength
(lambda (l)
(if (null? l)
0
(+ 1 (length (tail l))))))
;; list1 :: a -> [a] ;; list1 :: a -> [a]
(define list1 (define list1
(lambda (x) list)
(cons x nil)))
;; list2 :: a -> a -> [a] ;; list2 :: a -> a -> [a]
(define list2 (define list2
@ -517,24 +411,7 @@ Licensed under GPL (2 or 3? FIXME)
;; nil :: [a] ;; nil :: [a]
(define nil (define nil
(list)) null)
;; notElem :: (Eq a) => a -> [a] -> Bool
(define not-elem
(lambda (x l)
(all (lambda (y) (not (equal? x y))) l)))
;; null :: [a] -> Bool
#;(define null?
(lambda (x)
(equal? x nil)))
;; or :: [Bool] -> Bool
(define any-true
(lambda (l)
(if (null? l)
#f
(or (head l) (any-true (tail l))))))
;; partition :: (a -> Bool) -> [a] -> ([a], [a]) ;; partition :: (a -> Bool) -> [a] -> ([a], [a])
(define partition* (define partition*
@ -646,10 +523,6 @@ Licensed under GPL (2 or 3? FIXME)
(tuple2 (cons (head l) (fst r)) (snd r))) (tuple2 (cons (head l) (fst r)) (snd r)))
(tuple2 nil l))))) (tuple2 nil l)))))
;; splitAt :: Int -> [a] -> ([a],[a])
(define split-at
(lambda (n l)
(tuple2 (take n l) (drop n l))))
;; sum :: (Num a) => [a] -> a ;; sum :: (Num a) => [a] -> a
(define sum (define sum
@ -659,12 +532,6 @@ Licensed under GPL (2 or 3? FIXME)
;; tail :: [a] -> [a] ;; tail :: [a] -> [a]
(define tail cdr) (define tail cdr)
;; take :: Int -> [a] -> [a]
(define take
(lambda (n l)
(cond ((<= n 0) nil)
((null? l) nil)
(else (cons (head l) (take (- n 1) (tail l)))))))
;; takeWhile :: (a -> Bool) -> [a] -> [a] ;; takeWhile :: (a -> Bool) -> [a] -> [a]
(define take-while (define take-while
@ -696,27 +563,6 @@ Licensed under GPL (2 or 3? FIXME)
(transpose (cons xs (transpose (cons xs
(map1 (protect tail) xss)))))))))) (map1 (protect tail) xss))))))))))
;; unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
(define unfoldr
(lambda (f x)
(let ((r (f x)))
(if r
(cons (fst r) (unfoldr f (snd r)))
nil))))
;; (unfoldr (lambda (b) (if (= b 0) #f (tuple2 b (- b 1)))) 10)
;; => (10 9 8 7 6 5 4 3 2 1)
;; union :: (Eq a) => [a] -> [a] -> [a]
(define union
(lambda (a b)
(union-by equal? a b)))
;; unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
(define union-by
(lambda (f xs ys)
(let ((g (lambda (x y) (delete-by f y x))))
(append2 xs (foldl g (nub-by f ys) xs)))))
;; zip :: [a] -> [b] -> [(a, b)] ;; zip :: [a] -> [b] -> [(a, b)]
(define zip (define zip
@ -760,15 +606,6 @@ Licensed under GPL (2 or 3? FIXME)
;; data/tree.scm ;;;;;;;;;;;;;; ;; data/tree.scm ;;;;;;;;;;;;;;
;; Tree a -> [a]
(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))))
;; Tree a -> [[a]] ;; Tree a -> [[a]]
(define levels (define levels
(lambda (t) (lambda (t)
@ -778,10 +615,8 @@ Licensed under GPL (2 or 3? FIXME)
(cons (fst lr) (levels (concat (snd lr)))))))) (cons (fst lr) (levels (concat (snd lr))))))))
(module+ test (module+ test
(require rackunit) (require rackunit)
(check-equal? (drop 2 '(1 2 3 4 5 6)) '(3 4 5 6)) (check-equal? (drop 2 '(1 2 3 4 5 6)) '(3 4 5 6))
(check-equal? (transpose '((1 2) (3 4))) '((1 3) (2 4))) (check-equal? (transpose '((1 2) (3 4))) '((1 3) (2 4)))
) )

382
rsc3/main.rkt
View file

@ -1,17 +1,28 @@
#lang racket #lang racket
(require (require (only-in rnrs exact mod) ;; last remnants of rnrs
rnrs
rhs/rhs rhs/rhs
sosc/bytevector (prefix-in sosc: "../sosc/sosc.rkt") ;; local testing
sosc/transport ;;(prefix-in sosc: sosc/sosc)
sosc/sosc ;;(prefix-in sosc: sosc/bytevector)
(prefix-in srfi: srfi/27) ;;(prefix-in sosc: sosc/transport)
(prefix-in srfi: srfi/19)) ;;(prefix-in sosc: sosc/ip)
(prefix-in srfi: srfi/19)) ;; time functions (possibly use racket/date)
;; TODO - export only useful funcs ;; TODO - export only useful funcs
(provide (all-defined-out) (provide (all-defined-out))
send)
;; verbose messages
(define verbose? (make-parameter #f))
(define loglevel (make-parameter 0))
(define (verbose str #:level (n 0) . fmt )
(when (and (verbose?) (<= n (loglevel)))
(if (empty? fmt)
(printf str)
(apply printf str fmt))))
;; [a] -> int -> [a] ;; [a] -> int -> [a]
(define extend (define extend
@ -193,8 +204,9 @@
(and (= (+ x 1) (head xs)) (and (= (+ x 1) (head xs))
(consecutive? xs)))))) (consecutive? xs))))))
;; int -> uid ;; int -> uid
(define-record-type uid (struct uid(n)
(fields n)) #:transparent
#:constructor-name make-uid)
;; () -> uid ;; () -> uid
(define unique-uid (define unique-uid
@ -204,16 +216,19 @@
(make-uid n)))) (make-uid n))))
;; string -> int -> control ;; string -> int -> control
(define-record-type control (struct control (name index)
(fields name index)) #:transparent
#:constructor-name make-control)
;; string -> float -> rate -> float -> control* ;; string -> float -> rate -> float -> control*
(define-record-type control* (struct control* (name default rate lag)
(fields name default rate lag)) #:transparent
#:constructor-name make-control*)
;; string -> [float] -> [float] -> [controls] -> [ugens] -> graphdef ;; string -> [float] -> [float] -> [controls] -> [ugens] -> graphdef
(define-record-type graphdef (struct graphdef (name constants defaults controls ugens)
(fields name constants defaults controls ugens)) #:transparent
#:constructor-name make-graphdef)
;; graphdef -> int -> ugen ;; graphdef -> int -> ugen
(define graphdef-ugen (define graphdef-ugen
@ -231,12 +246,14 @@
(list-ref (graphdef-constants g) n))) (list-ref (graphdef-constants g) n)))
;; int -> int -> input ;; int -> int -> input
(define-record-type input (struct input (ugen port)
(fields ugen port)) #:transparent
#:constructor-name make-input)
;; [ugen] -> mce ;; [ugen] -> mce
(define-record-type mce (struct mce (proxies)
(fields proxies)) #:transparent
#:constructor-name make-mce)
;; ugen -> ugen -> mce ;; ugen -> ugen -> mce
(define mce2 (define mce2
@ -265,7 +282,7 @@
((mce? u) (mce-proxies u)) ((mce? u) (mce-proxies u))
((mrg? u) (let ((rs (mce-channels (mrg-left u)))) ((mrg? u) (let ((rs (mce-channels (mrg-left u))))
(cons (make-mrg (head rs) (mrg-right u)) rs))) (cons (make-mrg (head rs) (mrg-right u)) rs)))
(else (list1 u))))) (else (list u)))))
;; mce -> int -> ugen ;; mce -> int -> ugen
(define mce-channel (define mce-channel
@ -273,8 +290,9 @@
(list-ref (mce-proxies u) n))) (list-ref (mce-proxies u) n)))
;; ugen -> ugen -> mrg ;; ugen -> ugen -> mrg
(define-record-type mrg (struct mrg (left right)
(fields left right)) #:transparent
#:constructor-name make-mrg)
;; [ugen] -> mrg ;; [ugen] -> mrg
(define mrg-n (define mrg-n
@ -300,16 +318,19 @@
(make-mrg a (make-mrg b (make-mrg c d))))) (make-mrg a (make-mrg b (make-mrg c d)))))
;; rate -> output ;; rate -> output
(define-record-type output (struct output (rate)
(fields rate)) #:transparent
#:constructor-name make-output)
;; ugen -> int -> proxy ;; ugen -> int -> proxy
(define-record-type proxy (struct proxy (ugen port)
(fields ugen port)) #:transparent
#:constructor-name make-proxy)
;; int -> rate ;; int -> rate
(define-record-type rate (struct rate (value)
(fields value)) #:transparent
#:constructor-name make-rate)
;; rate ;; rate
(define ir (define ir
@ -334,7 +355,7 @@
((control*? o) (control*-rate o)) ((control*? o) (control*-rate o))
((ugen? o) (ugen-rate o)) ((ugen? o) (ugen-rate o))
((proxy? o) (rate-of (proxy-ugen o))) ((proxy? o) (rate-of (proxy-ugen o)))
((mce? o) (rate-select (map1 rate-of (mce-proxies o)))) ((mce? o) (rate-select (map rate-of (mce-proxies o))))
((mrg? o) (rate-of (mrg-left o))) ((mrg? o) (rate-of (mrg-left o)))
(else (error "rate-of" "illegal value" o))))) (else (error "rate-of" "illegal value" o)))))
@ -360,8 +381,9 @@
(foldl1 rate-select* l))) (foldl1 rate-select* l)))
;; string -> rate -> [ugen] -> [output] -> int -> uid -> ugen ;; string -> rate -> [ugen] -> [output] -> int -> uid -> ugen
(define-record-type ugen (struct ugen (name rate inputs outputs special id)
(fields name rate inputs outputs special id)) #:transparent
#:constructor-name make-ugen)
;; ugen -> int -> output ;; ugen -> int -> output
(define ugen-output (define ugen-output
@ -414,23 +436,23 @@
;; control -> [bytevector] ;; control -> [bytevector]
(define encode-control (define encode-control
(lambda (c) (lambda (c)
(list2 (encode-pstr (control-name c)) (list2 (sosc:encode-pstr (control-name c))
(encode-i16 (control-index c))))) (sosc:encode-i16 (control-index c)))))
;; input -> [bytevector] ;; input -> [bytevector]
(define encode-input (define encode-input
(lambda (i) (lambda (i)
(list2 (encode-i16 (input-ugen i)) (list2 (sosc:encode-i16 (input-ugen i))
(encode-i16 (input-port i))))) (sosc:encode-i16 (input-port i)))))
;; output -> [bytevector] ;; output -> [bytevector]
(define encode-output (define encode-output
(lambda (o) (lambda (o)
(encode-u8 (rate-value (output-rate o))))) (sosc:encode-u8 (rate-value (output-rate o)))))
;; [bytevector] ;; [bytevector]
(define scgf (define scgf
(map encode-u8 (map char->integer (string->list "SCgf")))) (map sosc:encode-u8 (map char->integer (string->list "SCgf"))))
;; ugen -> [bytevector] ;; ugen -> [bytevector]
(define encode-ugen (define encode-ugen
@ -439,18 +461,18 @@
u u
(lambda (n r i o s d) (lambda (n r i o s d)
(list (list
(encode-pstr n) (sosc:encode-pstr n)
(encode-u8 (rate-value r)) (sosc:encode-u8 (rate-value r))
(encode-i16 (length i)) (sosc:encode-i16 (length i))
(encode-i16 (length o)) (sosc:encode-i16 (length o))
(encode-i16 s) (sosc:encode-i16 s)
(map1 encode-input i) (map encode-input i)
(map1 encode-output o)))))) (map encode-output o))))))
;; graphdef -> bytevector ;; graphdef -> bytevector
(define encode-graphdef (define (encode-graphdef g)
(lambda (g) (verbose "encode-graphdef: ~a~n" g)
(flatten-bytevectors (sosc:flatten-bytevectors
(let ((n (graphdef-name g)) (let ((n (graphdef-name g))
(c (graphdef-constants g)) (c (graphdef-constants g))
(d (graphdef-defaults g)) (d (graphdef-defaults g))
@ -458,17 +480,17 @@
(u (graphdef-ugens g))) (u (graphdef-ugens g)))
(list (list
scgf scgf
(encode-i32 0) (sosc:encode-i32 0)
(encode-i16 1) (sosc:encode-i16 1)
(encode-pstr n) (sosc:encode-pstr n)
(encode-i16 (length c)) (sosc:encode-i16 (length c))
(map1 encode-f32 c) (map sosc:encode-f32 c)
(encode-i16 (length d)) (sosc:encode-i16 (length d))
(map1 encode-f32 d) (map sosc:encode-f32 d)
(encode-i16 (length k)) (sosc:encode-i16 (length k))
(map1 encode-control k) (map encode-control k)
(encode-i16 (length u)) (sosc:encode-i16 (length u))
(map1 encode-ugen u)))))) (map encode-ugen u)))))
;; syntax for binding control values ;; syntax for binding control values
(define-syntax letc (define-syntax letc
@ -490,7 +512,7 @@
inputs)) inputs))
(rate (if rate? (rate (if rate?
rate? rate?
(rate-select (map1 rate-of inputs*)))) (rate-select (map rate-of inputs*))))
(u (make-ugen (u (make-ugen
name name
rate rate
@ -506,9 +528,9 @@
(cond (cond
((ugen? u) (cons u (concat-map graph-nodes (ugen-inputs u)))) ((ugen? u) (cons u (concat-map graph-nodes (ugen-inputs u))))
((proxy? u) (cons u (graph-nodes (proxy-ugen u)))) ((proxy? u) (cons u (graph-nodes (proxy-ugen u))))
((control*? u) (list1 u)) ((control*? u) (list u))
((number? u) (list1 u)) ((number? u) (list u))
((mce? u) (concat (map1 graph-nodes (mce-proxies u)))) ((mce? u) (concat (map graph-nodes (mce-proxies u))))
((mrg? u) (append2 (graph-nodes (mrg-left u)) (graph-nodes (mrg-right u)))) ((mrg? u) (append2 (graph-nodes (mrg-left u)) (graph-nodes (mrg-right u))))
(else (error "graph-nodes" "illegal value" u))))) (else (error "graph-nodes" "illegal value" u)))))
@ -534,7 +556,7 @@
(error "ugen-close" "invalid ugen" u) (error "ugen-close" "invalid ugen" u)
(make-ugen (ugen-name u) (make-ugen (ugen-name u)
(ugen-rate u) (ugen-rate u)
(map1 (lambda (i) (map (lambda (i)
(input*-to-input i nn cc uu)) (input*-to-input i nn cc uu))
(ugen-inputs u)) (ugen-inputs u))
(ugen-outputs u) (ugen-outputs u)
@ -561,9 +583,9 @@
(make-graphdef (make-graphdef
name name
nn nn
(map1 control*-default cc) (map control*-default cc)
(map1 (lambda (c) (control*-to-control c cc)) cc) (map (lambda (c) (control*-to-control c cc)) cc)
(map1 (lambda (u) (ugen-close u nn cc uu*)) uu*))))) (map (lambda (u) (ugen-close u nn cc uu*)) uu*)))))
;; [control] -> ugen ;; [control] -> ugen
(define implicit-ugen (define implicit-ugen
@ -571,7 +593,7 @@
(make-ugen "Control" (make-ugen "Control"
kr kr
nil nil
(map1 make-output (replicate (length cc) kr)) (map make-output (replicate (length cc) kr))
0 0
(make-uid 0)))) (make-uid 0))))
@ -643,7 +665,7 @@
(define mce-transpose (define mce-transpose
(lambda (u) (lambda (u)
(make-mce (make-mce
(map1 make-mce (transpose (map1 mce-channels (mce-channels u))))))) (map make-mce (transpose (map mce-channels (mce-channels u)))))))
;; ugen -> bool ;; ugen -> bool
(define mce-required? (define mce-required?
@ -665,15 +687,15 @@
u u
(lambda (n r i o s d) (lambda (n r i o s d)
(let* ((f (lambda (i*) (make-ugen 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)))) (m (maximum (map mce-degree (filter mce? i))))
(e (lambda (i) (mce-extend m i))) (e (lambda (i) (mce-extend m i)))
(i* (transpose (map1 e i)))) (i* (transpose (map e i))))
(make-mce (map1 f i*))))))) (make-mce (map f i*)))))))
;; node -> node|mce ;; node -> node|mce
(define mce-expand (define mce-expand
(lambda (u) (lambda (u)
(cond ((mce? u) (make-mce (map1 mce-expand (mce-proxies u)))) (cond ((mce? u) (make-mce (map mce-expand (mce-proxies u))))
((mrg? u) (make-mrg (mce-expand (mrg-left u)) (mrg-right u))) ((mrg? u) (make-mrg (mce-expand (mrg-left u)) (mrg-right u)))
(else (if (mce-required? u) (else (if (mce-required? u)
(mce-transform u) (mce-transform u)
@ -683,13 +705,13 @@
(define proxify (define proxify
(lambda (u) (lambda (u)
(cond (cond
((mce? u) (make-mce (map1 proxify (mce-proxies u)))) ((mce? u) (make-mce (map proxify (mce-proxies u))))
((mrg? u) (make-mrg (proxify (mrg-left u)) (mrg-right u))) ((mrg? u) (make-mrg (proxify (mrg-left u)) (mrg-right u)))
((ugen? u) (let* ((o (ugen-outputs u)) ((ugen? u) (let* ((o (ugen-outputs u))
(n (mlength o))) (n (length o)))
(if (< n 2) (if (< n 2)
u u
(make-mce (map1 (lambda (i) (make-proxy u i)) (make-mce (map (lambda (i) (make-proxy u i))
(enum-from-to 0 (- n 1))))))) (enum-from-to 0 (- n 1)))))))
(else (error "proxify" "illegal ugen" u))))) (else (error "proxify" "illegal ugen" u)))))
@ -700,7 +722,7 @@
(if (and (number? a) (if (and (number? a)
f) f)
(f a) (f a)
(construct-ugen "UnaryOpUGen" #f (list1 a) #f 1 s (make-uid 0)))))) (construct-ugen "UnaryOpUGen" #f (list a) #f 1 s (make-uid 0))))))
;; int -> maybe (float -> float -> float) -> (node -> node -> node) ;; int -> maybe (float -> float -> float) -> (node -> node -> node)
(define mk-binary-operator (define mk-binary-operator
@ -1338,227 +1360,241 @@
(define linear 0) (define linear 0)
(define exponential 1) (define exponential 1)
;; server messages
(define quit (define quit
(message "/quit" nil)) (sosc:message "/quit" nil))
(define notify (define notify
(lambda (i) (lambda (i)
(message "/notify" (list i)))) (verbose "/notify: ~a~n" i)
(sosc:message "/notify" (list i))))
(define status (define status
(message "/status" nil)) (sosc:message "/status" nil))
(define dump-osc (define dump-osc
(lambda (i) (lambda (i)
(message "/dumpOSC" (list i)))) (verbose "/dumpOSC: ~a~n" i)
(sosc:message "/dumpOSC" (list i))))
(define sync (define sync
(lambda (i) (lambda (i)
(message "/sync" (list i)))) (verbose "/sync: ~a~n" i)
(sosc:message "/sync" (list i))))
(define clear-sched (define clear-sched
(message "/clearSched" nil)) (sosc:message "/clearSched" nil))
(define d-recv (define d-recv
(lambda (b) (lambda (b)
(message "/d_recv" (list b)))) (verbose "/d_recv ~n length: ~a~n"
(length (bytes->list b)))
(verbose 2 "/d_recv ~n raw: ~a~n bytes: ~a~n"
b (bytes->list b))
(sosc:message "/d_recv" (list b))))
(define d-load (define d-load
(lambda (s) (lambda (s)
(message "/d_load" (list s)))) (verbose "/d_load ~a~n" s)
(sosc:message "/d_load" (list s))))
(define d-load-dir (define d-load-dir
(lambda (s) (lambda (s)
(message "/d_loadDir" (list s)))) (verbose "/d_loadDir ~a~n" s)
(sosc:message "/d_loadDir" (list s))))
(define d-free1 (define d-free1
(lambda (s) (lambda (s)
(message "/d_free" (list s)))) (verbose "/d_free ~a~n" s)
(sosc:message "/d_free" (list s))))
(define n-free1 (define n-free1
(lambda (i) (lambda (i)
(message "/n_free" (list i)))) (verbose "/n_free ~a~n" i)
(sosc:message "/n_free" (list i))))
(define n-run1 (define n-run1
(lambda (i j) (lambda (i j)
(message "/n_run" (list i j)))) (verbose "/d_run ~a, ~a~n" i j)
(sosc:message "/n_run" (list i j))))
(define n-set (define n-set
(lambda (i xys) (lambda (i xys)
(verbose "/n_set ~a, ~a~n" i xys)
(let ((z (concat-map (lambda (xy) (list (fst xy) (snd xy))) xys))) (let ((z (concat-map (lambda (xy) (list (fst xy) (snd xy))) xys)))
(message "/n_set" (cons i z))))) (sosc:message "/n_set" (cons i z)))))
(define n-set1 (define n-set1
(lambda (i s f) (lambda (i s f)
(message "/n_set" (list i s f)))) (sosc:message "/n_set" (list i s f))))
(define n-setn1 (define n-setn1
(lambda (i s fs) (lambda (i s fs)
(message "/n_setn" (cons i (cons s (cons (length fs) fs)))))) (sosc:message "/n_setn" (cons i (cons s (cons (length fs) fs))))))
(define n-fill1 (define n-fill1
(lambda (i s j f) (lambda (i s j f)
(message "/n_fill" (list i s j f)))) (sosc:message "/n_fill" (list i s j f))))
(define n-map1 (define n-map
(lambda (i s j) (lambda (i s j)
(message "/n_map" (list i s j)))) (sosc:message "/n_map" (list i s j))))
(define n-mapn1 (define n-mapn1
(lambda (i s j k) (lambda (i s j k)
(message "/n_mapn" (list i s j k)))) (sosc:message "/n_mapn" (list i s j k))))
(define n-before (define n-before
(lambda (i j) (lambda (i j)
(message "/n_before" (list i j)))) (sosc:message "/n_before" (list i j))))
(define n-query (define n-query
(lambda (i) (lambda (i)
(message "/n_query" (list i)))) (sosc:message "/n_query" (list i))))
(define n-trace (define n-trace
(lambda (i) (lambda (i)
(message "/n_trace" (list i)))) (sosc:message "/n_trace" (list i))))
(define s-new0 (define s-new0
(lambda (s i j k) (lambda (s i j k)
(message "/s_new" (list s i j k)))) (sosc:message "/s_new" (list s i j k))))
(define s-new1 (define s-new1
(lambda (s i j k t f) (lambda (s i j k t f)
(message "/s_new" (list s i j k t f)))) (sosc:message "/s_new" (list s i j k t f))))
(define s-new2 (define s-new2
(lambda (s i j k t1 f1 t2 f2) (lambda (s i j k t1 f1 t2 f2)
(message "/s_new" (list s i j k t1 f1 t2 f2)))) (sosc:message "/s_new" (list s i j k t1 f1 t2 f2))))
(define s-new (define s-new
(lambda (s i j k cs) (lambda (s i j k cs)
(message "/s_new" (append2 (list s i j k) cs)))) (sosc:message "/s_new" (append2 (list s i j k) cs))))
(define s-get1 (define s-get1
(lambda (i j) (lambda (i j)
(message "/s_get" (list i j)))) (sosc:message "/s_get" (list i j))))
(define s-getn1 (define s-getn1
(lambda (i s j) (lambda (i s j)
(message "/s_getn" (list i s j)))) (sosc:message "/s_getn" (list i s j))))
(define s-noid (define s-noid
(lambda (i) (lambda (i)
(message "/s_noid" (list i)))) (sosc:message "/s_noid" (list i))))
(define g-new1 (define g-new1
(lambda (i j k) (lambda (i j k)
(message "/g_new" (list i j k)))) (sosc:message "/g_new" (list i j k))))
(define g-head1 (define g-head1
(lambda (i j) (lambda (i j)
(message "/g_head" (list i j)))) (sosc:message "/g_head" (list i j))))
(define g-tail1 (define g-tail1
(lambda (i j) (lambda (i j)
(message "/g_tail" (list i j)))) (sosc:message "/g_tail" (list i j))))
(define g-free-all1 (define g-free-all1
(lambda (i) (lambda (i)
(message "/g_freeAll" (list i)))) (sosc:message "/g_freeAll" (list i))))
(define g-deep-free1 (define g-deep-free1
(lambda (i) (lambda (i)
(message "/g_deepFree" (list i)))) (sosc:message "/g_deepFree" (list i))))
(define b-alloc (define b-alloc
(lambda (id frames channels) (lambda (id frames channels)
(message "/b_alloc" (list id frames channels)))) (verbose "/b_alloc ~a, ~a, ~a~n" id frames channels)
(sosc:message "/b_alloc" (list id frames channels))))
(define b-alloc-read (define b-alloc-read
(lambda (id path frame n) (lambda (id path frame n)
(message "/b_allocRead" (list id path frame n)))) (sosc:message "/b_allocRead" (list id path frame n))))
(define b-read (define b-read
(lambda (id path frame n bframe flag) (lambda (id path frame n bframe flag)
(message "/b_read" (list id path frame n bframe flag)))) (sosc:message "/b_read" (list id path frame n bframe flag))))
(define b-write (define b-write
(lambda (id path header type frames start flag) (lambda (id path header type frames start flag)
(message "/b_write" (list id path header type frames start flag)))) (sosc:message "/b_write" (list id path header type frames start flag))))
(define b-free (define b-free
(lambda (i) (lambda (i)
(message "/b_free" (list i)))) (sosc:message "/b_free" (list i))))
(define b-zero (define b-zero
(lambda (i) (lambda (i)
(message "/b_zero" (list i)))) (sosc:message "/b_zero" (list i))))
(define b-set1 (define b-set1
(lambda (i j f) (lambda (i j f)
(message "/b_set" (list i j f)))) (sosc:message "/b_set" (list i j f))))
(define b-setn1 (define b-setn1
(lambda (i j fs) (lambda (i j fs)
(message "/b_setn" (cons i (cons j (cons (length fs) fs)))))) (sosc:message "/b_setn" (cons i (cons j (cons (length fs) fs))))))
(define b-fill1 (define b-fill1
(lambda (i j k f) (lambda (i j k f)
(message "/b_fill" (list i j k f)))) (sosc:message "/b_fill" (list i j k f))))
(define b-close (define b-close
(lambda (i) (lambda (i)
(message "/b_close" (list i)))) (sosc:message "/b_close" (list i))))
(define b-query1 (define b-query1
(lambda (i) (lambda (i)
(message "/b_query" (list i)))) (sosc:message "/b_query" (list i))))
(define b-get1 (define b-get1
(lambda (i j) (lambda (i j)
(message "/b_get" (list i j)))) (sosc:message "/b_get" (list i j))))
(define b-getn1 (define b-getn1
(lambda (i j k) (lambda (i j k)
(message "/b_getn" (list i j k)))) (sosc:message "/b_getn" (list i j k))))
(define b-gen1 (define b-gen1
(lambda (i s fs) (lambda (i s fs)
(message "/b_gen" (cons i (cons s fs))))) (sosc:message "/b_gen" (cons i (cons s fs)))))
(define c-set1 (define c-set1
(lambda (i f) (lambda (i f)
(message "/c_set" (list i f)))) (sosc:message "/c_set" (list i f))))
(define c-setn1 (define c-setn1
(lambda (i fs) (lambda (i fs)
(message "/c_setn" (cons i (cons (length fs) fs))))) (sosc:message "/c_setn" (cons i (cons (length fs) fs)))))
(define c-fill1 (define c-fill1
(lambda (i j f) (lambda (i j f)
(message "/c_fill" (list i j f)))) (sosc:message "/c_fill" (list i j f))))
(define c-get1 (define c-get1
(lambda (i) (lambda (i)
(message "/c_get" (list i)))) (sosc:message "/c_get" (list i))))
(define c-getn1 (define c-getn1
(lambda (i j) (lambda (i j)
(message "/c_getn" (list i j)))) (sosc:message "/c_getn" (list i j))))
;; port -> osc -> () ;; port -> osc -> ()
(define async (define (async fd m)
(lambda (fd m) (sosc:send fd m)
(send fd m) (sosc:wait fd "/done"))
(wait fd "/done")))
;; port -> string -> ugen -> () ;; port -> string -> ugen -> ()
(define send-synth (define (send-synth fd n u)
(lambda (fd n u) (verbose "send-synth~n fd:~a~n n:~a~n u:~a~n" fd n u)
(async fd (d-recv (encode-graphdef (synthdef n u)))))) (async fd (d-recv (encode-graphdef (synthdef n u)))))
;; osc message -> () ;; osc message -> ()
(define (send-msg msg) (define (send-msg msg)
(with-sc3 (lambda (fd) (with-sc3 (lambda (fd)
(send fd msg))) (sosc:send fd msg)))
(void)) (void))
;; osc message -> () ;; osc message -> ()
@ -1573,22 +1609,22 @@
(define play (define play
(lambda (fd u) (lambda (fd u)
(send-synth fd "anonymous" u) (send-synth fd "anonymous" u)
(send fd (s-new0 "anonymous" -1 1 1)))) (sosc:send fd (s-new0 "anonymous" -1 1 1))))
;; (socket -> a) -> a ;; (socket -> a) -> a
(define with-udp-sc3 (define with-udp-sc3
(lambda (f) (lambda (f)
(let* ((fd (udp:open "127.0.0.1" 57110)) (let* ((fd (sosc:udp:open "127.0.0.1" 57110))
(r (f fd))) (r (f fd)))
(udp:close fd) (sosc:udp:close fd)
r))) r)))
;; (socket -> a) -> a ;; (socket -> a) -> a
(define with-tcp-sc3 (define with-tcp-sc3
(lambda (f) (lambda (f)
(let* ((fd (tcp:open "127.0.0.1" 57110)) (let* ((fd (sosc:tcp:open "127.0.0.1" 57110))
(r (f fd))) (r (f fd)))
(tcp:close fd) (sosc:tcp:close fd)
r))) r)))
;; (socket -> a) -> a ;; (socket -> a) -> a
@ -1596,9 +1632,11 @@
;; port -> () ;; port -> ()
(define (reset) (define (reset fd)
(with-sc3 (lambda (fd) (with-sc3
(send fd (bundle -1 (list (g-free-all1 0) (lambda (fd)
(sosc:send fd
(sosc:bundle -1 (list (g-free-all1 0)
clear-sched clear-sched
(g-new1 1 0 0)))))) (g-new1 1 0 0))))))
(void)) (void))
@ -1629,18 +1667,18 @@
"Sample Rate (Actual) ")) "Sample Rate (Actual) "))
;; osc -> [string] ;; osc -> [string]
(define status-format (define (status-format r)
(lambda (r) (printf "server status: ~a~n" r)
(cons "***** SuperCollider Server Status *****" (cons "***** SuperCollider Server Status *****"
(zip-with string-append (zip-with string-append
status-fields status-fields
(map1 number->string (tail (tail r))))))) (map number->string (cddr r)))))
;; port -> [string] ;; port -> [string]
(define server-status (define server-status
(lambda (fd) (lambda (fd)
(send fd status) (sosc:send fd status)
(let ((r (wait fd "/status.reply"))) (let ((r (sosc:wait fd "/status.reply")))
(status-format r)))) (status-format r))))
;; port -> () ;; port -> ()
@ -1653,8 +1691,8 @@
;; port -> int -> number ;; port -> int -> number
(define server-status-field (define server-status-field
(lambda (fd n) (lambda (fd n)
(send fd status) (sosc:send fd status)
(let ((r (wait fd "/status.reply"))) (let ((r (sosc:wait fd "/status.reply")))
(list-ref r n)))) (list-ref r n))))
;; port -> float ;; port -> float
@ -1723,8 +1761,8 @@
;; [(ugen . ugen)] -> ugen -> ugen -> [ugen] -> ugen ;; [(ugen . ugen)] -> ugen -> ugen -> [ugen] -> ugen
(define env-coord (define env-coord
(lambda (d dur amp curves) (lambda (d dur amp curves)
(env (map1 (lambda (e) (mul (cdr e) amp)) d) (env (map (lambda (e) (mul (cdr e) amp)) d)
(map1 (lambda (e) (mul e dur)) (d->dx (map car d))) (map (lambda (e) (mul e dur)) (d->dx (map car d)))
curves curves
-1 -1
-1))) -1)))
@ -1799,7 +1837,7 @@
peakLevel peakLevel
curves curves
bias) bias)
(env (map1 (lambda (e) (mul e bias)) (env (map (lambda (e) (mul e bias))
(list 0.0 peakLevel (mul peakLevel sustainLevel) 0.0)) (list 0.0 peakLevel (mul peakLevel sustainLevel) 0.0))
(list attackTime decayTime releaseTime) (list attackTime decayTime releaseTime)
curves curves
@ -1838,7 +1876,7 @@
(define unpack-fft (define unpack-fft
(lambda (c nf from to mp?) (lambda (c nf from to mp?)
(map1 (lambda (i) (map (lambda (i)
(unpack1-fft c nf i mp?)) (unpack1-fft c nf i mp?))
(enum-from-to from to)))) (enum-from-to from to))))
@ -1914,7 +1952,7 @@
;; int -> (int -> ugen) -> mce ;; int -> (int -> ugen) -> mce
(define mce-fill (define mce-fill
(lambda (n f) (lambda (n f)
(make-mce (map1 f (enum-from-to 0 (- n 1)))))) (make-mce (map f (enum-from-to 0 (- n 1))))))
;; int -> (int -> ugen) -> ugen ;; int -> (int -> ugen) -> ugen
(define mix-fill (define mix-fill
@ -1922,18 +1960,21 @@
(mix (mce-fill n f)))) (mix (mce-fill n f))))
;; float ;; float
(define dinf (define dinf 9.0e8)
9.0e8)
(define maxf 3.402823e+38) ;; max float value
(define maxs 4294967087) ;; max spread for 'random'
;; float -> float -> float ;; float -> float -> float
(define random (define (rand-float a b)
(lambda (a b) (let ((n (inexact->exact maxs)))
(+ (* (srfi:random-real) (- b a)) a))) (+ (* (/ (random 0 n) (* 1.0 n))
(- b a))
a)))
;; int -> int -> int ;; int -> int -> int
(define i-random (define (rand-int l r)
(lambda (l r) (random l r))
(+ l (srfi:random-integer (- r l)))))
;; float -> float -> float ;; float -> float -> float
(define exp-random (define exp-random
@ -1942,9 +1983,8 @@
(* (expt r (random 0 1)) a)))) (* (expt r (random 0 1)) a))))
;; [a] -> a ;; [a] -> a
(define choose (define (choose xs)
(lambda (xs) (list-ref xs (random (length xs))))
(list-ref xs (srfi:random-integer (length xs)))))
;; () -> float ;; () -> float
(define utc (define utc
@ -1981,7 +2021,7 @@
;; double -> void ;; double -> void
(define pause-thread (define pause-thread
(lambda (n) (lambda (n)
(if (> n 1e-4) (when (> n 1e-4)
(thread-sleep n)))) (thread-sleep n))))
;; double -> void ;; double -> void

5
sosc/bytevector.rkt
View file

@ -1,7 +1,6 @@
#lang racket #lang racket
(require rnrs (require rhs/rhs
rhs/rhs
rnrs/bytevectors-6 rnrs/bytevectors-6
rnrs/io/ports-6) rnrs/io/ports-6)
@ -42,7 +41,7 @@
(define flatten-bytevectors (define flatten-bytevectors
(lambda (t) (lambda (t)
(let* ((l (flatten t)) (let* ((l (flatten t))
(n (map1 bytevector-length l)) (n (map bytevector-length l))
(m (sum n)) (m (sum n))
(v (make-bytevector m))) (v (make-bytevector m)))
(let loop ((i 0) (let loop ((i 0)

564
sosc/encoding.rkt Normal file
View file

@ -0,0 +1,564 @@
#lang racket
(require (only-in rnrs inexact exact mod) ;; various overlapping mutable troubles
(only-in racket/fixnum fxand fxnot) ;; really?
rhs/rhs
"bytevector.rkt"
rnrs/bytevectors-6 ;; TODO - should be provided by bytevector.rkt
rnrs/io/ports-6 ;; prefer to use racket posts
)
(provide message
bundle
encode-osc
decode-osc
encode-u8
encode-i16
encode-i32
encode-f32
encode-pstr
encode-u32
decode-u32
osc-display)
;; bytevector -> int
(define decode-u8
(lambda (v)
(bytevector-u8-ref v 0)))
;; bytevector -> int
(define decode-u16
(lambda (v)
(bytevector-u16-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-u32
(lambda (v)
(bytevector-u32-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-u64
(lambda (v)
(bytevector-u64-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-i8
(lambda (v)
(bytevector-s8-ref v 0)))
;; bytevector -> int
(define decode-i16
(lambda (v)
(bytevector-s16-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-i32
(lambda (v)
(bytevector-s32-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-i64
(lambda (v)
(bytevector-s64-ref v 0 (endianness big))))
;; bytevector -> double
(define decode-f32
(lambda (v)
(bytevector-ieee-single-ref v 0 (endianness big))))
;; bytevector -> double
(define decode-f64
(lambda (v)
(bytevector-ieee-double-ref v 0 (endianness big))))
;; bytevector -> string
(define decode-str
(lambda (b)
(utf8->string b)))
;; bytevector -> string
(define decode-pstr
(lambda (v)
(let* ((n (decode-u8 v))
(w (bytevector-section v 1 (+ n 1))))
(decode-str w))))
;; bytevector -> string
(define decode-cstr
(lambda (v)
(let* ((n (bytevector-find-index v 0))
(w (bytevector-section v 0 n)))
(decode-str w))))
;; int -> bytevector
(define encode-u8
(lambda (n)
(bytevector-make-and-set1
bytevector-u8-set!
1
(exact n))))
;; int -> bytevector
(define encode-u16
(lambda (n)
(bytevector-make-and-set
bytevector-u16-set!
2
(exact n))))
;; int -> bytevector
(define encode-u32
(lambda (n)
(bytevector-make-and-set
bytevector-u32-set!
4
(exact n))))
;; int -> bytevector
(define encode-u64
(lambda (n)
(bytevector-make-and-set
bytevector-u64-set!
8
(exact n))))
;; int -> bytevector
(define encode-i8
(lambda (n)
(bytevector-make-and-set1
bytevector-s8-set!
1
(exact n))))
;; int -> bytevector
(define encode-i16
(lambda (n)
(bytevector-make-and-set
bytevector-s16-set!
2
(exact n))))
;; int -> bytevector
(define encode-i32
(lambda (n)
(bytevector-make-and-set
bytevector-s32-set!
4
(exact n))))
;; int -> bytevector
(define encode-i64
(lambda (n)
(bytevector-make-and-set
bytevector-s64-set!
8
(exact n))))
;; double -> bytevector
(define encode-f32
(lambda (n)
(bytevector-make-and-set
bytevector-ieee-single-set!
4
(inexact n))))
;; double -> bytevector
(define encode-f64
(lambda (n)
(bytevector-make-and-set
bytevector-ieee-double-set!
8
(inexact n))))
;; string -> bytevector
(define encode-str
(lambda (s)
(string->utf8 s)))
;; string -> bytevector
(define encode-pstr
(lambda (s)
(let* ((b (encode-str s))
(n (encode-u8 (bytevector-length b))))
(list n b))))
;; string -> [bytevector]
(define encode-cstr
(lambda (s)
(let* ((b (encode-str s))
(z (encode-u8 0)))
(list b z))))
;; port -> string
(define read-pstr
(lambda (p)
(let* ((n (lookahead-u8 p))
(v (read-bstr p (+ n 1))))
(decode-pstr v))))
;; port -> string
(define read-cstr
(lambda (p)
(let loop ((l nil)
(b (get-u8 p)))
(if (= b 0)
(list->string (map integer->char (reverse l)))
(loop (cons b l) (get-u8 p))))))
;; port -> int -> bytevector
(define read-bstr
(lambda (p n)
(get-bytevector-n p n)))
;; port -> int
(define read-i16
(lambda (p)
(decode-i16 (read-bstr p 2))))
;; port -> int
(define read-u16
(lambda (p)
(decode-u16 (read-bstr p 2))))
;; port -> int
(define read-i32
(lambda (p)
(decode-i32 (read-bstr p 4))))
;; port -> int
(define read-u32
(lambda (p)
(decode-u32 (read-bstr p 4))))
;; port -> int
(define read-i64
(lambda (p)
(decode-i64 (read-bstr p 8))))
;; port -> int
(define read-u64
(lambda (p)
(decode-u64 (read-bstr p 8))))
;; port -> double
(define read-f32
(lambda (p)
(decode-f32 (read-bstr p 4))))
;; port -> double
(define read-f64
(lambda (p)
(decode-f64 (read-bstr p 8))))
;; int
(define seconds-from-1900-to-1970
(+ (* 70 365 24 60 60) (* 17 24 60 60)))
;; double -> int
(define ntpr->ntp
(lambda (n)
(exact (round (* n (expt 2 32))))))
;; double -> double
(define utc->ntpr
(lambda (n)
(+ n seconds-from-1900-to-1970)))
;; int -> double
(define ntp->utc
(lambda (n)
(- (/ n (expt 2 32)) seconds-from-1900-to-1970)))
;; port -> string
(define read-ostr
(lambda (p)
(let* ((s (read-cstr p))
(n (mod (cstring-length s) 4))
(i (- 4 (mod n 4))))
(if (not (= n 0))
(read-bstr p i)
#f)
s)))
;; port -> bytevector
(define read-obyt
(lambda (p)
(let* ((n (read-i32 p))
(b (read-bstr p n))
(i (- 4 (mod n 4))))
(if (not (= n 0))
(read-bstr p i)
#f)
b)))
;; datum = int | double | string | bytevector
;; port -> char -> datum
(define read-value
(lambda (p t)
(cond
((equal? t oI32) (read-i32 p))
((equal? t oI64) (read-i64 p))
((equal? t oU64) (read-u64 p))
((equal? t oF32) (read-f32 p))
((equal? t oF64) (read-f64 p))
((equal? t oSTR) (read-ostr p))
((equal? t oBYT) (read-obyt p))
((equal? t oMID) (read-u32 p))
(else (error "read-value" "bad type" t)))))
;; port -> [char] -> [datum]
(define read-arguments
(lambda (p types)
(if (null? types)
'()
(cons (read-value p (car types))
(read-arguments p (cdr types))))))
;; port -> (string:[datum])
(define read-message
(lambda (p)
(let* ((address (read-ostr p))
(types (read-ostr p)))
(cons address
(read-arguments p (cdr (string->list types)))))))
;; port -> (utc:[message])
(define read-bundle
(lambda (p)
(let ((bundletag (read-ostr p))
(timetag (ntp->utc (read-u64 p)))
(parts (list)))
(if (not (equal? bundletag "#bundle"))
(error "read-bundle"
"illegal bundle tag"
bundletag)
(cons timetag
(let loop ((parts (list)))
(if (eof-object? (lookahead-u8 p))
(reverse parts)
(begin
;; We have no use for the message size...
(read-i32 p)
(loop (cons (read-packet p) parts))))))))))
;; byte
(define hash-u8
(char->integer #\#))
;; port -> osc
(define read-packet
(lambda (p)
(if (equal? (lookahead-u8 p) hash-u8)
(read-bundle p)
(read-message p))))
;; bytevector -> osc
(define decode-osc
(lambda (b)
(with-input-from-bytevector b read-packet)))
;; [byte] -> ()
(define osc-display
(lambda (l)
(zip-with
(lambda (b n)
(display (list (number->string b 16) (integer->char b)))
(if (= 3 (mod n 4))
(newline)
(display #\space)))
l
(enum-from-to 0 (- (length l) 1)))))
;; string -> int
(define cstring-length
(lambda (s)
(+ 1 (string-length s))))
;; int -> int
;; (equal? (map osc-align (enum-from-to 0 7)) (list 0 3 2 1 0 3 2 1))
(define osc-align
(lambda (n)
(- (fxand (+ n 3) (fxnot 3)) n)))
;; int -> [bytevector]
(define padding-of
(lambda (n) (replicate (osc-align n) (encode-u8 0))))
;; string -> [bytevector]
(define encode-string
(lambda (s)
(list (encode-cstr s) (padding-of (cstring-length s)))))
;; bytevector -> [bytevector]
(define encode-bytes
(lambda (b)
(let ((n (bytevector-length b)))
(list (encode-i32 n)
b
(padding-of n)))))
;; datum -> bytevector
(define encode-value
(lambda (e)
(cond ((number? e) (if (integer? e)
(encode-i32 e)
(encode-f32 e)))
((string? e) (encode-string e))
((bytevector? e) (encode-bytes e))
(else (error "encode-value" "illegal value" e)))))
;; [datum] -> bytevector
(define encode-types
(lambda (l)
(encode-string
(list->string
(cons #\,
(map (lambda (e)
(cond ((number? e) (if (integer? e)
#\i
#\f))
((string? e) #\s)
((bytevector? e) #\b)
(else (error "encode-types" "type?" e))))
l))))))
;; osc -> [bytevector]
(define encode-message
(lambda (m)
(list (encode-string (car m))
(encode-types (cdr m))
(map encode-value (cdr m)))))
;; osc -> [bytevector]
(define encode-bundle-ntp
(lambda (b)
(list (encode-string "#bundle")
(encode-u64 (ntpr->ntp (car b)))
(map (lambda (e)
(if (message? e)
(encode-bytes (encode-osc e))
(error "encode-bundle" "illegal value" e)))
(cdr b)))))
;; osc -> [bytevector]
(define encode-bundle
(lambda (b)
(encode-bundle-ntp (cons (utc->ntpr (car b)) (cdr b)))))
;; osc -> bytevector
(define encode-osc
(lambda (p)
(flatten-bytevectors
(if (bundle? p)
(encode-bundle p)
(encode-message p)))))
;; any | [any] -> datum | [datum]
(define purify
(lambda (e)
(cond ((or (number? e) (string? e) (bytevector? e)) e)
((list? e) (map purify e))
((symbol? e) (symbol->string e))
((boolean? e) (if e 1 0))
(else (error "purify" "illegal input" e)))))
;; char
(define oI32 #\i)
(define oI64 #\h)
(define oU64 #\t)
(define oF32 #\f)
(define oF64 #\d)
(define oSTR #\s)
(define oBYT #\b)
(define oMID #\m)
;; string -> [any] -> osc
(define message
(lambda (c l)
(if (string? c)
(cons c l)
(error "message" "illegal address"))))
;; float -> [any] -> osc
(define bundle
(lambda (t l)
(if (number? t)
(cons t l)
(error "bundle" "illegal timestamp" t))))
;; osc -> bool
(define message?
(lambda (p)
(string? (car p))))
;; osc -> bool
(define bundle?
(lambda (p)
(number? (car p))))
;; osc -> bool
(define verify-message
(lambda (m)
(and (string? (car m))
(all (lambda (e) (or (number? e)
(string? e)))
(cdr m)))))
;; osc -> bool
(define verify-bundle
(lambda (b)
(and (integer? (car b))
(all (lambda (e) (or (verify-message e)
(and (verify-bundle e)
(>= (car e) (car b)))))
(cdr b)))))
;; osc -> bool
(define verify-packet
(lambda (p)
(or (verify-message p)
(verify-bundle p))))
(module+ test
(require rackunit)
;; test from Clement's osc package (osc-to-bytes.rkt)
;; in sosc, strings are just "abc", blobs are #"abc".
;; in osc, strings are #"abc", blobs are ('blob #"abc")
(check-equal? (encode-osc (message "/abc/def"
(list
3 6 2.278
"froggy"
#"derple")))
(bytes-append
#"/abc/def\000\000\000\000,iifsb\0\0"
(bytes 0 0 0 3)
(bytes 0 0 0 6)
#"@\21\312\301"
#"froggy\0\0"
(bytes 0 0 0 6)
#"derple"
(bytes 0 0)))
)
#|
(define m1 (encode-osc (message "/a/b" (list 257))))
;; try to create a call graph
(require profile)
(require profile/render-graphviz)
(profile-thunk trace-encode
#:render render
#:use-errortrace? #t)
|#

27
sosc/ip.rkt
View file

@ -1,15 +1,9 @@
#lang racket #lang racket
;; from plt/ip.scm ;;;;;;;;;; (require "bytevector.rkt")
(require (prefix-in plt: racket)
(prefix-in plt: racket/udp)
"bytevector.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
;; data udp ;; data udp
(struct udp* (s h p)) (struct udp* (s h p))
@ -20,7 +14,7 @@
;; string -> int -> socket ;; string -> int -> socket
(define udp:open (define udp:open
(lambda (h p) (lambda (h p)
(udp* (plt:udp-open-socket h p) h p))) (udp* (udp-open-socket h p) h p)))
;; socket -> bytevector -> () ;; socket -> bytevector -> ()
(define udp:send (define udp:send
@ -28,7 +22,7 @@
(let ((s (udp*-s u)) (let ((s (udp*-s u))
(h (udp*-h u)) (h (udp*-h u))
(p (udp*-p u))) (p (udp*-p u)))
(plt:udp-send-to* s h p b)))) (udp-send-to* s h p b))))
;; socket -> maybe bytevector ;; socket -> maybe bytevector
(define udp:recv (define udp:recv
@ -37,18 +31,18 @@
(h (udp*-h u)) (h (udp*-h u))
(p (udp*-p u)) (p (udp*-p u))
(b (make-bytes 8192)) (b (make-bytes 8192))
(r (plt:sync/timeout 1.0 (plt:udp-receive!-evt s b)))) (r (sync/timeout 1.0 (udp-receive!-evt s b))))
(if r (if r
(plt:subbytes b 0 (plt:car r)) (subbytes b 0 (car r))
#f)))) #f))))
;; socket -> () ;; socket -> ()
(define udp:close (define udp:close
(lambda (u) (lambda (u)
(plt:udp-close (udp*-s u)))) (udp-close (udp*-s u))))
;; data tcp ;; data tcp
(plt:define-struct tcp* (i o h p)) (define-struct tcp* (i o h p))
;; any -> bool ;; any -> bool
(define tcp:socket? (define tcp:socket?
@ -58,9 +52,9 @@
(define tcp:open (define tcp:open
(lambda (h p) (lambda (h p)
(let-values (let-values
(((i o) (plt:tcp-connect h p))) (((i o) (tcp-connect h p)))
(plt:file-stream-buffer-mode i 'none) (file-stream-buffer-mode i 'none)
(plt:file-stream-buffer-mode o 'none) (file-stream-buffer-mode o 'none)
(make-tcp* i o h p)))) (make-tcp* i o h p))))
;; socket -> bytevector -> () ;; socket -> bytevector -> ()
@ -79,4 +73,3 @@
(lambda (fd) (lambda (fd)
(close-input-port (tcp*-i fd)) (close-input-port (tcp*-i fd))
(close-output-port (tcp*-o fd)))) (close-output-port (tcp*-o fd))))

570
sosc/sosc.rkt
View file

@ -1,562 +1,12 @@
#lang racket #lang racket
(require (require "bytevector.rkt"
rnrs "transport.rkt"
rhs/rhs "encoding.rkt"
"bytevector.rkt" "ip.rkt")
rnrs/bytevectors-6 ;; TODO - should be provided by bytevector.rkt
rnrs/io/ports-6 (provide
) (all-from-out "bytevector.rkt"
"transport.rkt"
(provide message "encoding.rkt"
bundle "ip.rkt"))
encode-osc
decode-osc
encode-u8
encode-i16
encode-i32
encode-f32
encode-pstr
encode-u32
decode-u32 )
;; bytevector -> int
(define decode-u8
(lambda (v)
(bytevector-u8-ref v 0)))
;; bytevector -> int
(define decode-u16
(lambda (v)
(bytevector-u16-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-u32
(lambda (v)
(bytevector-u32-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-u64
(lambda (v)
(bytevector-u64-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-i8
(lambda (v)
(bytevector-s8-ref v 0)))
;; bytevector -> int
(define decode-i16
(lambda (v)
(bytevector-s16-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-i32
(lambda (v)
(bytevector-s32-ref v 0 (endianness big))))
;; bytevector -> int
(define decode-i64
(lambda (v)
(bytevector-s64-ref v 0 (endianness big))))
;; bytevector -> double
(define decode-f32
(lambda (v)
(bytevector-ieee-single-ref v 0 (endianness big))))
;; bytevector -> double
(define decode-f64
(lambda (v)
(bytevector-ieee-double-ref v 0 (endianness big))))
;; bytevector -> string
(define decode-str
(lambda (b)
(utf8->string b)))
;; bytevector -> string
(define decode-pstr
(lambda (v)
(let* ((n (decode-u8 v))
(w (bytevector-section v 1 (+ n 1))))
(decode-str w))))
;; bytevector -> string
(define decode-cstr
(lambda (v)
(let* ((n (bytevector-find-index v 0))
(w (bytevector-section v 0 n)))
(decode-str w))))
;; int -> bytevector
(define encode-u8
(lambda (n)
(bytevector-make-and-set1
bytevector-u8-set!
1
(exact n))))
;; int -> bytevector
(define encode-u16
(lambda (n)
(bytevector-make-and-set
bytevector-u16-set!
2
(exact n))))
;; int -> bytevector
(define encode-u32
(lambda (n)
(bytevector-make-and-set
bytevector-u32-set!
4
(exact n))))
;; int -> bytevector
(define encode-u64
(lambda (n)
(bytevector-make-and-set
bytevector-u64-set!
8
(exact n))))
;; int -> bytevector
(define encode-i8
(lambda (n)
(bytevector-make-and-set1
bytevector-s8-set!
1
(exact n))))
;; int -> bytevector
(define encode-i16
(lambda (n)
(bytevector-make-and-set
bytevector-s16-set!
2
(exact n))))
;; int -> bytevector
(define encode-i32
(lambda (n)
(bytevector-make-and-set
bytevector-s32-set!
4
(exact n))))
;; int -> bytevector
(define encode-i64
(lambda (n)
(bytevector-make-and-set
bytevector-s64-set!
8
(exact n))))
;; double -> bytevector
(define encode-f32
(lambda (n)
(bytevector-make-and-set
bytevector-ieee-single-set!
4
(inexact n))))
;; double -> bytevector
(define encode-f64
(lambda (n)
(bytevector-make-and-set
bytevector-ieee-double-set!
8
(inexact n))))
;; string -> bytevector
(define encode-str
(lambda (s)
(string->utf8 s)))
;; string -> bytevector
(define encode-pstr
(lambda (s)
(let* ((b (encode-str s))
(n (encode-u8 (bytevector-length b))))
(list n b))))
;; string -> [bytevector]
(define encode-cstr
(lambda (s)
(let* ((b (encode-str s))
(z (encode-u8 0)))
(list b z))))
;; port -> string
(define read-pstr
(lambda (p)
(let* ((n (lookahead-u8 p))
(v (read-bstr p (+ n 1))))
(decode-pstr v))))
;; port -> string
(define read-cstr
(lambda (p)
(let loop ((l nil)
(b (get-u8 p)))
(if (= b 0)
(list->string (map1 integer->char (reverse l)))
(loop (cons b l) (get-u8 p))))))
;; port -> int -> bytevector
(define read-bstr
(lambda (p n)
(get-bytevector-n p n)))
;; port -> int
(define read-i16
(lambda (p)
(decode-i16 (read-bstr p 2))))
;; port -> int
(define read-u16
(lambda (p)
(decode-u16 (read-bstr p 2))))
;; port -> int
(define read-i32
(lambda (p)
(decode-i32 (read-bstr p 4))))
;; port -> int
(define read-u32
(lambda (p)
(decode-u32 (read-bstr p 4))))
;; port -> int
(define read-i64
(lambda (p)
(decode-i64 (read-bstr p 8))))
;; port -> int
(define read-u64
(lambda (p)
(decode-u64 (read-bstr p 8))))
;; port -> double
(define read-f32
(lambda (p)
(decode-f32 (read-bstr p 4))))
;; port -> double
(define read-f64
(lambda (p)
(decode-f64 (read-bstr p 8))))
;; int
(define seconds-from-1900-to-1970
(+ (* 70 365 24 60 60) (* 17 24 60 60)))
;; double -> int
(define ntpr->ntp
(lambda (n)
(exact (round (* n (expt 2 32))))))
;; double -> double
(define utc->ntpr
(lambda (n)
(+ n seconds-from-1900-to-1970)))
;; int -> double
(define ntp->utc
(lambda (n)
(- (/ n (expt 2 32)) seconds-from-1900-to-1970)))
;; port -> string
(define read-ostr
(lambda (p)
(let* ((s (read-cstr p))
(n (mod (cstring-length s) 4))
(i (- 4 (mod n 4))))
(if (not (= n 0))
(read-bstr p i)
#f)
s)))
;; port -> bytevector
(define read-obyt
(lambda (p)
(let* ((n (read-i32 p))
(b (read-bstr p n))
(i (- 4 (mod n 4))))
(if (not (= n 0))
(read-bstr p i)
#f)
b)))
;; datum = int | double | string | bytevector
;; port -> char -> datum
(define read-value
(lambda (p t)
(cond
((equal? t oI32) (read-i32 p))
((equal? t oI64) (read-i64 p))
((equal? t oU64) (read-u64 p))
((equal? t oF32) (read-f32 p))
((equal? t oF64) (read-f64 p))
((equal? t oSTR) (read-ostr p))
((equal? t oBYT) (read-obyt p))
((equal? t oMID) (read-u32 p))
(else (error "read-value" "bad type" t)))))
;; port -> [char] -> [datum]
(define read-arguments
(lambda (p types)
(if (null? types)
'()
(cons (read-value p (car types))
(read-arguments p (cdr types))))))
;; port -> (string:[datum])
(define read-message
(lambda (p)
(let* ((address (read-ostr p))
(types (read-ostr p)))
(cons address
(read-arguments p (cdr (string->list types)))))))
;; port -> (utc:[message])
(define read-bundle
(lambda (p)
(let ((bundletag (read-ostr p))
(timetag (ntp->utc (read-u64 p)))
(parts (list)))
(if (not (equal? bundletag "#bundle"))
(error "read-bundle"
"illegal bundle tag"
bundletag)
(cons timetag
(let loop ((parts (list)))
(if (eof-object? (lookahead-u8 p))
(reverse parts)
(begin
;; We have no use for the message size...
(read-i32 p)
(loop (cons (read-packet p) parts))))))))))
;; byte
(define hash-u8
(char->integer #\#))
;; port -> osc
(define read-packet
(lambda (p)
(if (equal? (lookahead-u8 p) hash-u8)
(read-bundle p)
(read-message p))))
;; bytevector -> osc
(define decode-osc
(lambda (b)
(with-input-from-bytevector b read-packet)))
;; [byte] -> ()
(define osc-display
(lambda (l)
(zip-with
(lambda (b n)
(display (list (number->string b 16) (integer->char b)))
(if (= 3 (mod n 4))
(newline)
(display #\space)))
l
(enum-from-to 0 (- (length l) 1)))))
;; string -> int
(define cstring-length
(lambda (s)
(+ 1 (string-length s))))
;; int -> int
;; (equal? (map osc-align (enum-from-to 0 7)) (list 0 3 2 1 0 3 2 1))
(define osc-align
(lambda (n)
(- (fxand (+ n 3) (fxnot 3)) n)))
;; int -> [bytevector]
(define padding-of
(lambda (n) (replicate (osc-align n) (encode-u8 0))))
;; string -> [bytevector]
(define encode-string
(lambda (s)
(list (encode-cstr s) (padding-of (cstring-length s)))))
;; bytevector -> [bytevector]
(define encode-bytes
(lambda (b)
(let ((n (bytevector-length b)))
(list (encode-i32 n)
b
(padding-of n)))))
;; datum -> bytevector
(define encode-value
(lambda (e)
(cond ((number? e) (if (integer? e)
(encode-i32 e)
(encode-f32 e)))
((string? e) (encode-string e))
((bytevector? e) (encode-bytes e))
(else (error "encode-value" "illegal value" e)))))
;; [datum] -> bytevector
(define encode-types
(lambda (l)
(encode-string
(list->string
(cons #\,
(map1 (lambda (e)
(cond ((number? e) (if (integer? e)
#\i
#\f))
((string? e) #\s)
((bytevector? e) #\b)
(else (error "encode-types" "type?" e))))
l))))))
;; osc -> [bytevector]
(define encode-message
(lambda (m)
(list (encode-string (car m))
(encode-types (cdr m))
(map1 encode-value (cdr m)))))
;; osc -> [bytevector]
(define encode-bundle-ntp
(lambda (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)))))
;; osc -> [bytevector]
(define encode-bundle
(lambda (b)
(encode-bundle-ntp (cons (utc->ntpr (car b)) (cdr b)))))
;; osc -> bytevector
(define encode-osc
(lambda (p)
(flatten-bytevectors
(if (bundle? p)
(encode-bundle p)
(encode-message p)))))
;; any | [any] -> datum | [datum]
(define purify
(lambda (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)))))
;; char
(define oI32 #\i)
(define oI64 #\h)
(define oU64 #\t)
(define oF32 #\f)
(define oF64 #\d)
(define oSTR #\s)
(define oBYT #\b)
(define oMID #\m)
;; string -> [any] -> osc
(define message
(lambda (c l)
(if (string? c)
(cons c l)
(error "message" "illegal address"))))
;; float -> [any] -> osc
(define bundle
(lambda (t l)
(if (number? t)
(cons t l)
(error "bundle" "illegal timestamp" t))))
;; osc -> bool
(define message?
(lambda (p)
(string? (car p))))
;; osc -> bool
(define bundle?
(lambda (p)
(number? (car p))))
;; osc -> bool
(define verify-message
(lambda (m)
(and (string? (car m))
(all (lambda (e) (or (number? e)
(string? e)))
(cdr m)))))
;; osc -> bool
(define verify-bundle
(lambda (b)
(and (integer? (car b))
(all (lambda (e) (or (verify-message e)
(and (verify-bundle e)
(>= (car e) (car b)))))
(cdr b)))))
;; osc -> bool
(define verify-packet
(lambda (p)
(or (verify-message p)
(verify-bundle p))))
(module+ test
(require rackunit)
;; test from Clement's osc package (osc-to-bytes.rkt)
;; in sosc, strings are just "abc", blobs are #"abc".
;; in osc, strings are #"abc", blobs are ('blob #"abc")
(check-equal? (encode-osc (message "/abc/def"
(list
3 6 2.278
"froggy"
#"derple")))
(bytes-append
#"/abc/def\000\000\000\000,iifsb\0\0"
(bytes 0 0 0 3)
(bytes 0 0 0 6)
#"@\21\312\301"
#"froggy\0\0"
(bytes 0 0 0 6)
#"derple"
(bytes 0 0)))
)
#|
(define m1 (encode-osc (message "/a/b" (list 257))))
;; try to create a call graph
(require profile)
(require profile/render-graphviz)
(profile-thunk trace-encode
#:render render
#:use-errortrace? #t)
|#

15
sosc/transport.rkt
View file

@ -1,16 +1,12 @@
#lang racket #lang racket
;; from transport.scm ;;;;;;; (require "bytevector.rkt"
"encoding.rkt"
(require rnrs
"bytevector.rkt"
"sosc.rkt"
"ip.rkt") "ip.rkt")
(provide (all-defined-out) (provide send
(all-from-out "ip.rkt")) recv
wait)
;; socket -> osc -> () ;; socket -> osc -> ()
(define send (define send
@ -41,4 +37,3 @@
((not p) (error "error" "Could not connect to the SuperCollider server")) ((not p) (error "error" "Could not connect to the SuperCollider server"))
((not (string=? (car p) s)) (error "wait" "bad return packet" p s)) ((not (string=? (car p) s)) (error "wait" "bad return packet" p s))
(else p))))) (else p)))))