remove rnrs dependencies and improve racket comparability
This commit is contained in:
parent
a25985dab2
commit
d37f0a2e03
7 changed files with 1019 additions and 1143 deletions
169
rhs/rhs.rkt
169
rhs/rhs.rkt
|
|
@ -13,31 +13,9 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
|
||||
|#
|
||||
|
||||
(require rnrs)
|
||||
|
||||
(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]
|
||||
(define enum-from-then-to
|
||||
(letrec ((efdt
|
||||
|
|
@ -54,47 +32,13 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(lambda (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
|
||||
(define succ
|
||||
(lambda (x)
|
||||
(+ x 1)))
|
||||
|
||||
;; undefined :: a
|
||||
(define undefined
|
||||
(lambda ()
|
||||
(error "undefined" "undefined")))
|
||||
|
||||
|
||||
|
||||
;; tuple.scm ;;;;;;;;;;;;
|
||||
|
||||
|
||||
;; curry :: ((a, b) -> c) -> a -> b -> c
|
||||
(define curry
|
||||
(lambda (f)
|
||||
(lambda (x y)
|
||||
(f (tuple2 x y)))))
|
||||
|
||||
(struct duple (p q))
|
||||
|
||||
;; fst :: (a, b) -> a
|
||||
|
|
@ -109,16 +53,8 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(define tuple2
|
||||
duple)
|
||||
|
||||
;; uncurry :: (a -> b -> c) -> (a, b) -> c
|
||||
(define uncurry
|
||||
(lambda (f)
|
||||
(lambda (xy)
|
||||
(f (fst xy) (snd xy)))))
|
||||
|
||||
|
||||
;; data/ord.scm ;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;; data Ordering = LT | EQ | GT
|
||||
|
||||
;; compare :: (Ord a) => a -> a -> Ordering
|
||||
|
|
@ -139,22 +75,14 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(if (< x y) x y)))
|
||||
|
||||
|
||||
|
||||
;; data/function.scm ;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;; (.) :: (b -> c) -> (a -> b) -> a -> c
|
||||
(define compose
|
||||
(lambda (f g)
|
||||
(lambda (x)
|
||||
(f (g x)))))
|
||||
|
||||
;; const :: a -> b -> a
|
||||
(define const
|
||||
(lambda (x)
|
||||
(lambda (_)
|
||||
x)))
|
||||
|
||||
;; flip :: (a -> b -> c) -> b -> a -> c
|
||||
(define flip
|
||||
(lambda (f)
|
||||
|
|
@ -166,8 +94,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(lambda (x)
|
||||
x))
|
||||
|
||||
|
||||
|
||||
;; data/list.scm ;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; all :: (a -> Bool) -> [a] -> Bool
|
||||
|
|
@ -177,20 +103,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
#t
|
||||
(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]
|
||||
(define append2
|
||||
(lambda (a b)
|
||||
|
|
@ -198,11 +110,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
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]
|
||||
(define concat
|
||||
(lambda (l)
|
||||
|
|
@ -243,10 +150,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(drop-while p (tail 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
|
||||
(define elem-index
|
||||
|
|
@ -403,19 +306,10 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(head l)
|
||||
(last xs)))))
|
||||
|
||||
;; mlength :: [a] -> Int
|
||||
(define mlength
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
0
|
||||
(+ 1 (length (tail l))))))
|
||||
|
||||
|
||||
|
||||
;; list1 :: a -> [a]
|
||||
(define list1
|
||||
(lambda (x)
|
||||
(cons x nil)))
|
||||
list)
|
||||
|
||||
;; list2 :: a -> a -> [a]
|
||||
(define list2
|
||||
|
|
@ -517,24 +411,7 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
|
||||
;; nil :: [a]
|
||||
(define nil
|
||||
(list))
|
||||
|
||||
;; 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))))))
|
||||
null)
|
||||
|
||||
;; partition :: (a -> Bool) -> [a] -> ([a], [a])
|
||||
(define partition*
|
||||
|
|
@ -646,10 +523,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(tuple2 (cons (head l) (fst r)) (snd r)))
|
||||
(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
|
||||
(define sum
|
||||
|
|
@ -659,12 +532,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
;; tail :: [a] -> [a]
|
||||
(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]
|
||||
(define take-while
|
||||
|
|
@ -696,27 +563,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(transpose (cons xs
|
||||
(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)]
|
||||
(define zip
|
||||
|
|
@ -760,15 +606,6 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
|
||||
;; 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]]
|
||||
(define levels
|
||||
(lambda (t)
|
||||
|
|
@ -778,10 +615,8 @@ Licensed under GPL (2 or 3? FIXME)
|
|||
(cons (fst lr) (levels (concat (snd lr))))))))
|
||||
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(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)))
|
||||
)
|
||||
|
||||
|
|
|
|||
382
rsc3/main.rkt
382
rsc3/main.rkt
|
|
@ -1,17 +1,28 @@
|
|||
#lang racket
|
||||
|
||||
(require
|
||||
rnrs
|
||||
(require (only-in rnrs exact mod) ;; last remnants of rnrs
|
||||
rhs/rhs
|
||||
sosc/bytevector
|
||||
sosc/transport
|
||||
sosc/sosc
|
||||
(prefix-in srfi: srfi/27)
|
||||
(prefix-in srfi: srfi/19))
|
||||
(prefix-in sosc: "../sosc/sosc.rkt") ;; local testing
|
||||
;;(prefix-in sosc: sosc/sosc)
|
||||
;;(prefix-in sosc: sosc/bytevector)
|
||||
;;(prefix-in sosc: sosc/transport)
|
||||
;;(prefix-in sosc: sosc/ip)
|
||||
(prefix-in srfi: srfi/19)) ;; time functions (possibly use racket/date)
|
||||
|
||||
;; TODO - export only useful funcs
|
||||
(provide (all-defined-out)
|
||||
send)
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
||||
;; 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]
|
||||
(define extend
|
||||
|
|
@ -193,8 +204,9 @@
|
|||
(and (= (+ x 1) (head xs))
|
||||
(consecutive? xs))))))
|
||||
;; int -> uid
|
||||
(define-record-type uid
|
||||
(fields n))
|
||||
(struct uid(n)
|
||||
#:transparent
|
||||
#:constructor-name make-uid)
|
||||
|
||||
;; () -> uid
|
||||
(define unique-uid
|
||||
|
|
@ -204,16 +216,19 @@
|
|||
(make-uid n))))
|
||||
|
||||
;; string -> int -> control
|
||||
(define-record-type control
|
||||
(fields name index))
|
||||
(struct control (name index)
|
||||
#:transparent
|
||||
#:constructor-name make-control)
|
||||
|
||||
;; string -> float -> rate -> float -> control*
|
||||
(define-record-type control*
|
||||
(fields name default rate lag))
|
||||
(struct control* (name default rate lag)
|
||||
#:transparent
|
||||
#:constructor-name make-control*)
|
||||
|
||||
;; string -> [float] -> [float] -> [controls] -> [ugens] -> graphdef
|
||||
(define-record-type graphdef
|
||||
(fields name constants defaults controls ugens))
|
||||
(struct graphdef (name constants defaults controls ugens)
|
||||
#:transparent
|
||||
#:constructor-name make-graphdef)
|
||||
|
||||
;; graphdef -> int -> ugen
|
||||
(define graphdef-ugen
|
||||
|
|
@ -231,12 +246,14 @@
|
|||
(list-ref (graphdef-constants g) n)))
|
||||
|
||||
;; int -> int -> input
|
||||
(define-record-type input
|
||||
(fields ugen port))
|
||||
(struct input (ugen port)
|
||||
#:transparent
|
||||
#:constructor-name make-input)
|
||||
|
||||
;; [ugen] -> mce
|
||||
(define-record-type mce
|
||||
(fields proxies))
|
||||
(struct mce (proxies)
|
||||
#:transparent
|
||||
#:constructor-name make-mce)
|
||||
|
||||
;; ugen -> ugen -> mce
|
||||
(define mce2
|
||||
|
|
@ -265,7 +282,7 @@
|
|||
((mce? u) (mce-proxies u))
|
||||
((mrg? u) (let ((rs (mce-channels (mrg-left u))))
|
||||
(cons (make-mrg (head rs) (mrg-right u)) rs)))
|
||||
(else (list1 u)))))
|
||||
(else (list u)))))
|
||||
|
||||
;; mce -> int -> ugen
|
||||
(define mce-channel
|
||||
|
|
@ -273,8 +290,9 @@
|
|||
(list-ref (mce-proxies u) n)))
|
||||
|
||||
;; ugen -> ugen -> mrg
|
||||
(define-record-type mrg
|
||||
(fields left right))
|
||||
(struct mrg (left right)
|
||||
#:transparent
|
||||
#:constructor-name make-mrg)
|
||||
|
||||
;; [ugen] -> mrg
|
||||
(define mrg-n
|
||||
|
|
@ -300,16 +318,19 @@
|
|||
(make-mrg a (make-mrg b (make-mrg c d)))))
|
||||
|
||||
;; rate -> output
|
||||
(define-record-type output
|
||||
(fields rate))
|
||||
(struct output (rate)
|
||||
#:transparent
|
||||
#:constructor-name make-output)
|
||||
|
||||
;; ugen -> int -> proxy
|
||||
(define-record-type proxy
|
||||
(fields ugen port))
|
||||
(struct proxy (ugen port)
|
||||
#:transparent
|
||||
#:constructor-name make-proxy)
|
||||
|
||||
;; int -> rate
|
||||
(define-record-type rate
|
||||
(fields value))
|
||||
(struct rate (value)
|
||||
#:transparent
|
||||
#:constructor-name make-rate)
|
||||
|
||||
;; rate
|
||||
(define ir
|
||||
|
|
@ -334,7 +355,7 @@
|
|||
((control*? o) (control*-rate o))
|
||||
((ugen? o) (ugen-rate 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)))
|
||||
(else (error "rate-of" "illegal value" o)))))
|
||||
|
||||
|
|
@ -360,8 +381,9 @@
|
|||
(foldl1 rate-select* l)))
|
||||
|
||||
;; string -> rate -> [ugen] -> [output] -> int -> uid -> ugen
|
||||
(define-record-type ugen
|
||||
(fields name rate inputs outputs special id))
|
||||
(struct ugen (name rate inputs outputs special id)
|
||||
#:transparent
|
||||
#:constructor-name make-ugen)
|
||||
|
||||
;; ugen -> int -> output
|
||||
(define ugen-output
|
||||
|
|
@ -414,23 +436,23 @@
|
|||
;; control -> [bytevector]
|
||||
(define encode-control
|
||||
(lambda (c)
|
||||
(list2 (encode-pstr (control-name c))
|
||||
(encode-i16 (control-index c)))))
|
||||
(list2 (sosc:encode-pstr (control-name c))
|
||||
(sosc:encode-i16 (control-index c)))))
|
||||
|
||||
;; input -> [bytevector]
|
||||
(define encode-input
|
||||
(lambda (i)
|
||||
(list2 (encode-i16 (input-ugen i))
|
||||
(encode-i16 (input-port i)))))
|
||||
(list2 (sosc:encode-i16 (input-ugen i))
|
||||
(sosc:encode-i16 (input-port i)))))
|
||||
|
||||
;; output -> [bytevector]
|
||||
(define encode-output
|
||||
(lambda (o)
|
||||
(encode-u8 (rate-value (output-rate o)))))
|
||||
(sosc:encode-u8 (rate-value (output-rate o)))))
|
||||
|
||||
;; [bytevector]
|
||||
(define scgf
|
||||
(map encode-u8 (map char->integer (string->list "SCgf"))))
|
||||
(map sosc:encode-u8 (map char->integer (string->list "SCgf"))))
|
||||
|
||||
;; ugen -> [bytevector]
|
||||
(define encode-ugen
|
||||
|
|
@ -439,18 +461,18 @@
|
|||
u
|
||||
(lambda (n r i o s d)
|
||||
(list
|
||||
(encode-pstr n)
|
||||
(encode-u8 (rate-value r))
|
||||
(encode-i16 (length i))
|
||||
(encode-i16 (length o))
|
||||
(encode-i16 s)
|
||||
(map1 encode-input i)
|
||||
(map1 encode-output o))))))
|
||||
(sosc:encode-pstr n)
|
||||
(sosc:encode-u8 (rate-value r))
|
||||
(sosc:encode-i16 (length i))
|
||||
(sosc:encode-i16 (length o))
|
||||
(sosc:encode-i16 s)
|
||||
(map encode-input i)
|
||||
(map encode-output o))))))
|
||||
|
||||
;; graphdef -> bytevector
|
||||
(define encode-graphdef
|
||||
(lambda (g)
|
||||
(flatten-bytevectors
|
||||
(define (encode-graphdef g)
|
||||
(verbose "encode-graphdef: ~a~n" g)
|
||||
(sosc:flatten-bytevectors
|
||||
(let ((n (graphdef-name g))
|
||||
(c (graphdef-constants g))
|
||||
(d (graphdef-defaults g))
|
||||
|
|
@ -458,17 +480,17 @@
|
|||
(u (graphdef-ugens g)))
|
||||
(list
|
||||
scgf
|
||||
(encode-i32 0)
|
||||
(encode-i16 1)
|
||||
(encode-pstr n)
|
||||
(encode-i16 (length c))
|
||||
(map1 encode-f32 c)
|
||||
(encode-i16 (length d))
|
||||
(map1 encode-f32 d)
|
||||
(encode-i16 (length k))
|
||||
(map1 encode-control k)
|
||||
(encode-i16 (length u))
|
||||
(map1 encode-ugen u))))))
|
||||
(sosc:encode-i32 0)
|
||||
(sosc:encode-i16 1)
|
||||
(sosc:encode-pstr n)
|
||||
(sosc:encode-i16 (length c))
|
||||
(map sosc:encode-f32 c)
|
||||
(sosc:encode-i16 (length d))
|
||||
(map sosc:encode-f32 d)
|
||||
(sosc:encode-i16 (length k))
|
||||
(map encode-control k)
|
||||
(sosc:encode-i16 (length u))
|
||||
(map encode-ugen u)))))
|
||||
|
||||
;; syntax for binding control values
|
||||
(define-syntax letc
|
||||
|
|
@ -490,7 +512,7 @@
|
|||
inputs))
|
||||
(rate (if rate?
|
||||
rate?
|
||||
(rate-select (map1 rate-of inputs*))))
|
||||
(rate-select (map rate-of inputs*))))
|
||||
(u (make-ugen
|
||||
name
|
||||
rate
|
||||
|
|
@ -506,9 +528,9 @@
|
|||
(cond
|
||||
((ugen? u) (cons u (concat-map graph-nodes (ugen-inputs u))))
|
||||
((proxy? u) (cons u (graph-nodes (proxy-ugen u))))
|
||||
((control*? u) (list1 u))
|
||||
((number? u) (list1 u))
|
||||
((mce? u) (concat (map1 graph-nodes (mce-proxies u))))
|
||||
((control*? u) (list u))
|
||||
((number? u) (list u))
|
||||
((mce? u) (concat (map graph-nodes (mce-proxies u))))
|
||||
((mrg? u) (append2 (graph-nodes (mrg-left u)) (graph-nodes (mrg-right u))))
|
||||
(else (error "graph-nodes" "illegal value" u)))))
|
||||
|
||||
|
|
@ -534,7 +556,7 @@
|
|||
(error "ugen-close" "invalid ugen" u)
|
||||
(make-ugen (ugen-name u)
|
||||
(ugen-rate u)
|
||||
(map1 (lambda (i)
|
||||
(map (lambda (i)
|
||||
(input*-to-input i nn cc uu))
|
||||
(ugen-inputs u))
|
||||
(ugen-outputs u)
|
||||
|
|
@ -561,9 +583,9 @@
|
|||
(make-graphdef
|
||||
name
|
||||
nn
|
||||
(map1 control*-default cc)
|
||||
(map1 (lambda (c) (control*-to-control c cc)) cc)
|
||||
(map1 (lambda (u) (ugen-close u nn cc uu*)) uu*)))))
|
||||
(map control*-default cc)
|
||||
(map (lambda (c) (control*-to-control c cc)) cc)
|
||||
(map (lambda (u) (ugen-close u nn cc uu*)) uu*)))))
|
||||
|
||||
;; [control] -> ugen
|
||||
(define implicit-ugen
|
||||
|
|
@ -571,7 +593,7 @@
|
|||
(make-ugen "Control"
|
||||
kr
|
||||
nil
|
||||
(map1 make-output (replicate (length cc) kr))
|
||||
(map make-output (replicate (length cc) kr))
|
||||
0
|
||||
(make-uid 0))))
|
||||
|
||||
|
|
@ -643,7 +665,7 @@
|
|||
(define mce-transpose
|
||||
(lambda (u)
|
||||
(make-mce
|
||||
(map1 make-mce (transpose (map1 mce-channels (mce-channels u)))))))
|
||||
(map make-mce (transpose (map mce-channels (mce-channels u)))))))
|
||||
|
||||
;; ugen -> bool
|
||||
(define mce-required?
|
||||
|
|
@ -665,15 +687,15 @@
|
|||
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))))
|
||||
(m (maximum (map mce-degree (filter mce? i))))
|
||||
(e (lambda (i) (mce-extend m i)))
|
||||
(i* (transpose (map1 e i))))
|
||||
(make-mce (map1 f i*)))))))
|
||||
(i* (transpose (map e i))))
|
||||
(make-mce (map f i*)))))))
|
||||
|
||||
;; node -> node|mce
|
||||
(define mce-expand
|
||||
(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)))
|
||||
(else (if (mce-required? u)
|
||||
(mce-transform u)
|
||||
|
|
@ -683,13 +705,13 @@
|
|||
(define proxify
|
||||
(lambda (u)
|
||||
(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)))
|
||||
((ugen? u) (let* ((o (ugen-outputs u))
|
||||
(n (mlength o)))
|
||||
(n (length o)))
|
||||
(if (< n 2)
|
||||
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)))))))
|
||||
(else (error "proxify" "illegal ugen" u)))))
|
||||
|
||||
|
|
@ -700,7 +722,7 @@
|
|||
(if (and (number? a)
|
||||
f)
|
||||
(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)
|
||||
(define mk-binary-operator
|
||||
|
|
@ -1338,227 +1360,241 @@
|
|||
(define linear 0)
|
||||
(define exponential 1)
|
||||
|
||||
;; server messages
|
||||
(define quit
|
||||
(message "/quit" nil))
|
||||
(sosc:message "/quit" nil))
|
||||
|
||||
(define notify
|
||||
(lambda (i)
|
||||
(message "/notify" (list i))))
|
||||
(verbose "/notify: ~a~n" i)
|
||||
(sosc:message "/notify" (list i))))
|
||||
|
||||
(define status
|
||||
(message "/status" nil))
|
||||
(sosc:message "/status" nil))
|
||||
|
||||
(define dump-osc
|
||||
(lambda (i)
|
||||
(message "/dumpOSC" (list i))))
|
||||
(verbose "/dumpOSC: ~a~n" i)
|
||||
(sosc:message "/dumpOSC" (list i))))
|
||||
|
||||
(define sync
|
||||
(lambda (i)
|
||||
(message "/sync" (list i))))
|
||||
(verbose "/sync: ~a~n" i)
|
||||
(sosc:message "/sync" (list i))))
|
||||
|
||||
(define clear-sched
|
||||
(message "/clearSched" nil))
|
||||
(sosc:message "/clearSched" nil))
|
||||
|
||||
(define d-recv
|
||||
(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
|
||||
(lambda (s)
|
||||
(message "/d_load" (list s))))
|
||||
(verbose "/d_load ~a~n" s)
|
||||
(sosc:message "/d_load" (list s))))
|
||||
|
||||
(define d-load-dir
|
||||
(lambda (s)
|
||||
(message "/d_loadDir" (list s))))
|
||||
(verbose "/d_loadDir ~a~n" s)
|
||||
(sosc:message "/d_loadDir" (list s))))
|
||||
|
||||
(define d-free1
|
||||
(lambda (s)
|
||||
(message "/d_free" (list s))))
|
||||
(verbose "/d_free ~a~n" s)
|
||||
(sosc:message "/d_free" (list s))))
|
||||
|
||||
(define n-free1
|
||||
(lambda (i)
|
||||
(message "/n_free" (list i))))
|
||||
(verbose "/n_free ~a~n" i)
|
||||
(sosc:message "/n_free" (list i))))
|
||||
|
||||
(define n-run1
|
||||
(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
|
||||
(lambda (i xys)
|
||||
(verbose "/n_set ~a, ~a~n" i 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
|
||||
(lambda (i s f)
|
||||
(message "/n_set" (list i s f))))
|
||||
(sosc:message "/n_set" (list i s f))))
|
||||
|
||||
(define n-setn1
|
||||
(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
|
||||
(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)
|
||||
(message "/n_map" (list i s j))))
|
||||
(sosc:message "/n_map" (list i s j))))
|
||||
|
||||
(define n-mapn1
|
||||
(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
|
||||
(lambda (i j)
|
||||
(message "/n_before" (list i j))))
|
||||
(sosc:message "/n_before" (list i j))))
|
||||
|
||||
(define n-query
|
||||
(lambda (i)
|
||||
(message "/n_query" (list i))))
|
||||
(sosc:message "/n_query" (list i))))
|
||||
|
||||
(define n-trace
|
||||
(lambda (i)
|
||||
(message "/n_trace" (list i))))
|
||||
(sosc:message "/n_trace" (list i))))
|
||||
|
||||
(define s-new0
|
||||
(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
|
||||
(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
|
||||
(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
|
||||
(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
|
||||
(lambda (i j)
|
||||
(message "/s_get" (list i j))))
|
||||
(sosc:message "/s_get" (list i j))))
|
||||
|
||||
(define s-getn1
|
||||
(lambda (i s j)
|
||||
(message "/s_getn" (list i s j))))
|
||||
(sosc:message "/s_getn" (list i s j))))
|
||||
|
||||
(define s-noid
|
||||
(lambda (i)
|
||||
(message "/s_noid" (list i))))
|
||||
(sosc:message "/s_noid" (list i))))
|
||||
|
||||
(define g-new1
|
||||
(lambda (i j k)
|
||||
(message "/g_new" (list i j k))))
|
||||
(sosc:message "/g_new" (list i j k))))
|
||||
|
||||
(define g-head1
|
||||
(lambda (i j)
|
||||
(message "/g_head" (list i j))))
|
||||
(sosc:message "/g_head" (list i j))))
|
||||
|
||||
(define g-tail1
|
||||
(lambda (i j)
|
||||
(message "/g_tail" (list i j))))
|
||||
(sosc:message "/g_tail" (list i j))))
|
||||
|
||||
(define g-free-all1
|
||||
(lambda (i)
|
||||
(message "/g_freeAll" (list i))))
|
||||
(sosc:message "/g_freeAll" (list i))))
|
||||
|
||||
(define g-deep-free1
|
||||
(lambda (i)
|
||||
(message "/g_deepFree" (list i))))
|
||||
(sosc:message "/g_deepFree" (list i))))
|
||||
|
||||
(define b-alloc
|
||||
(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
|
||||
(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
|
||||
(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
|
||||
(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
|
||||
(lambda (i)
|
||||
(message "/b_free" (list i))))
|
||||
(sosc:message "/b_free" (list i))))
|
||||
|
||||
(define b-zero
|
||||
(lambda (i)
|
||||
(message "/b_zero" (list i))))
|
||||
(sosc:message "/b_zero" (list i))))
|
||||
|
||||
(define b-set1
|
||||
(lambda (i j f)
|
||||
(message "/b_set" (list i j f))))
|
||||
(sosc:message "/b_set" (list i j f))))
|
||||
|
||||
(define b-setn1
|
||||
(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
|
||||
(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
|
||||
(lambda (i)
|
||||
(message "/b_close" (list i))))
|
||||
(sosc:message "/b_close" (list i))))
|
||||
|
||||
(define b-query1
|
||||
(lambda (i)
|
||||
(message "/b_query" (list i))))
|
||||
(sosc:message "/b_query" (list i))))
|
||||
|
||||
(define b-get1
|
||||
(lambda (i j)
|
||||
(message "/b_get" (list i j))))
|
||||
(sosc:message "/b_get" (list i j))))
|
||||
|
||||
(define b-getn1
|
||||
(lambda (i j k)
|
||||
(message "/b_getn" (list i j k))))
|
||||
(sosc:message "/b_getn" (list i j k))))
|
||||
|
||||
(define b-gen1
|
||||
(lambda (i s fs)
|
||||
(message "/b_gen" (cons i (cons s fs)))))
|
||||
(sosc:message "/b_gen" (cons i (cons s fs)))))
|
||||
|
||||
(define c-set1
|
||||
(lambda (i f)
|
||||
(message "/c_set" (list i f))))
|
||||
(sosc:message "/c_set" (list i f))))
|
||||
|
||||
(define c-setn1
|
||||
(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
|
||||
(lambda (i j f)
|
||||
(message "/c_fill" (list i j f))))
|
||||
(sosc:message "/c_fill" (list i j f))))
|
||||
|
||||
(define c-get1
|
||||
(lambda (i)
|
||||
(message "/c_get" (list i))))
|
||||
(sosc:message "/c_get" (list i))))
|
||||
|
||||
(define c-getn1
|
||||
(lambda (i j)
|
||||
(message "/c_getn" (list i j))))
|
||||
(sosc:message "/c_getn" (list i j))))
|
||||
|
||||
;; port -> osc -> ()
|
||||
(define async
|
||||
(lambda (fd m)
|
||||
(send fd m)
|
||||
(wait fd "/done")))
|
||||
(define (async fd m)
|
||||
(sosc:send fd m)
|
||||
(sosc:wait fd "/done"))
|
||||
|
||||
;; port -> string -> ugen -> ()
|
||||
(define send-synth
|
||||
(lambda (fd n u)
|
||||
(async fd (d-recv (encode-graphdef (synthdef n u))))))
|
||||
(define (send-synth 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)))))
|
||||
|
||||
;; osc message -> ()
|
||||
(define (send-msg msg)
|
||||
(with-sc3 (lambda (fd)
|
||||
(send fd msg)))
|
||||
(sosc:send fd msg)))
|
||||
(void))
|
||||
|
||||
;; osc message -> ()
|
||||
|
|
@ -1573,22 +1609,22 @@
|
|||
(define play
|
||||
(lambda (fd 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
|
||||
(define with-udp-sc3
|
||||
(lambda (f)
|
||||
(let* ((fd (udp:open "127.0.0.1" 57110))
|
||||
(let* ((fd (sosc:udp:open "127.0.0.1" 57110))
|
||||
(r (f fd)))
|
||||
(udp:close fd)
|
||||
(sosc:udp:close fd)
|
||||
r)))
|
||||
|
||||
;; (socket -> a) -> a
|
||||
(define with-tcp-sc3
|
||||
(lambda (f)
|
||||
(let* ((fd (tcp:open "127.0.0.1" 57110))
|
||||
(let* ((fd (sosc:tcp:open "127.0.0.1" 57110))
|
||||
(r (f fd)))
|
||||
(tcp:close fd)
|
||||
(sosc:tcp:close fd)
|
||||
r)))
|
||||
|
||||
;; (socket -> a) -> a
|
||||
|
|
@ -1596,9 +1632,11 @@
|
|||
|
||||
|
||||
;; port -> ()
|
||||
(define (reset)
|
||||
(with-sc3 (lambda (fd)
|
||||
(send fd (bundle -1 (list (g-free-all1 0)
|
||||
(define (reset fd)
|
||||
(with-sc3
|
||||
(lambda (fd)
|
||||
(sosc:send fd
|
||||
(sosc:bundle -1 (list (g-free-all1 0)
|
||||
clear-sched
|
||||
(g-new1 1 0 0))))))
|
||||
(void))
|
||||
|
|
@ -1629,18 +1667,18 @@
|
|||
"Sample Rate (Actual) "))
|
||||
|
||||
;; osc -> [string]
|
||||
(define status-format
|
||||
(lambda (r)
|
||||
(define (status-format r)
|
||||
(printf "server status: ~a~n" r)
|
||||
(cons "***** SuperCollider Server Status *****"
|
||||
(zip-with string-append
|
||||
status-fields
|
||||
(map1 number->string (tail (tail r)))))))
|
||||
(map number->string (cddr r)))))
|
||||
|
||||
;; port -> [string]
|
||||
(define server-status
|
||||
(lambda (fd)
|
||||
(send fd status)
|
||||
(let ((r (wait fd "/status.reply")))
|
||||
(sosc:send fd status)
|
||||
(let ((r (sosc:wait fd "/status.reply")))
|
||||
(status-format r))))
|
||||
|
||||
;; port -> ()
|
||||
|
|
@ -1653,8 +1691,8 @@
|
|||
;; port -> int -> number
|
||||
(define server-status-field
|
||||
(lambda (fd n)
|
||||
(send fd status)
|
||||
(let ((r (wait fd "/status.reply")))
|
||||
(sosc:send fd status)
|
||||
(let ((r (sosc:wait fd "/status.reply")))
|
||||
(list-ref r n))))
|
||||
|
||||
;; port -> float
|
||||
|
|
@ -1723,8 +1761,8 @@
|
|||
;; [(ugen . ugen)] -> ugen -> ugen -> [ugen] -> ugen
|
||||
(define env-coord
|
||||
(lambda (d dur amp curves)
|
||||
(env (map1 (lambda (e) (mul (cdr e) amp)) d)
|
||||
(map1 (lambda (e) (mul e dur)) (d->dx (map car d)))
|
||||
(env (map (lambda (e) (mul (cdr e) amp)) d)
|
||||
(map (lambda (e) (mul e dur)) (d->dx (map car d)))
|
||||
curves
|
||||
-1
|
||||
-1)))
|
||||
|
|
@ -1799,7 +1837,7 @@
|
|||
peakLevel
|
||||
curves
|
||||
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 attackTime decayTime releaseTime)
|
||||
curves
|
||||
|
|
@ -1838,7 +1876,7 @@
|
|||
|
||||
(define unpack-fft
|
||||
(lambda (c nf from to mp?)
|
||||
(map1 (lambda (i)
|
||||
(map (lambda (i)
|
||||
(unpack1-fft c nf i mp?))
|
||||
(enum-from-to from to))))
|
||||
|
||||
|
|
@ -1914,7 +1952,7 @@
|
|||
;; int -> (int -> ugen) -> mce
|
||||
(define mce-fill
|
||||
(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
|
||||
(define mix-fill
|
||||
|
|
@ -1922,18 +1960,21 @@
|
|||
(mix (mce-fill n f))))
|
||||
|
||||
;; float
|
||||
(define dinf
|
||||
9.0e8)
|
||||
(define dinf 9.0e8)
|
||||
|
||||
(define maxf 3.402823e+38) ;; max float value
|
||||
(define maxs 4294967087) ;; max spread for 'random'
|
||||
|
||||
;; float -> float -> float
|
||||
(define random
|
||||
(lambda (a b)
|
||||
(+ (* (srfi:random-real) (- b a)) a)))
|
||||
(define (rand-float a b)
|
||||
(let ((n (inexact->exact maxs)))
|
||||
(+ (* (/ (random 0 n) (* 1.0 n))
|
||||
(- b a))
|
||||
a)))
|
||||
|
||||
;; int -> int -> int
|
||||
(define i-random
|
||||
(lambda (l r)
|
||||
(+ l (srfi:random-integer (- r l)))))
|
||||
(define (rand-int l r)
|
||||
(random l r))
|
||||
|
||||
;; float -> float -> float
|
||||
(define exp-random
|
||||
|
|
@ -1942,9 +1983,8 @@
|
|||
(* (expt r (random 0 1)) a))))
|
||||
|
||||
;; [a] -> a
|
||||
(define choose
|
||||
(lambda (xs)
|
||||
(list-ref xs (srfi:random-integer (length xs)))))
|
||||
(define (choose xs)
|
||||
(list-ref xs (random (length xs))))
|
||||
|
||||
;; () -> float
|
||||
(define utc
|
||||
|
|
@ -1981,7 +2021,7 @@
|
|||
;; double -> void
|
||||
(define pause-thread
|
||||
(lambda (n)
|
||||
(if (> n 1e-4)
|
||||
(when (> n 1e-4)
|
||||
(thread-sleep n))))
|
||||
|
||||
;; double -> void
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang racket
|
||||
|
||||
(require rnrs
|
||||
rhs/rhs
|
||||
(require rhs/rhs
|
||||
rnrs/bytevectors-6
|
||||
rnrs/io/ports-6)
|
||||
|
||||
|
|
@ -42,7 +41,7 @@
|
|||
(define flatten-bytevectors
|
||||
(lambda (t)
|
||||
(let* ((l (flatten t))
|
||||
(n (map1 bytevector-length l))
|
||||
(n (map bytevector-length l))
|
||||
(m (sum n))
|
||||
(v (make-bytevector m)))
|
||||
(let loop ((i 0)
|
||||
|
|
|
|||
564
sosc/encoding.rkt
Normal file
564
sosc/encoding.rkt
Normal 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
27
sosc/ip.rkt
|
|
@ -1,15 +1,9 @@
|
|||
#lang racket
|
||||
|
||||
;; from plt/ip.scm ;;;;;;;;;;
|
||||
|
||||
|
||||
(require (prefix-in plt: racket)
|
||||
(prefix-in plt: racket/udp)
|
||||
"bytevector.rkt")
|
||||
(require "bytevector.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
||||
;; data udp
|
||||
(struct udp* (s h p))
|
||||
|
||||
|
|
@ -20,7 +14,7 @@
|
|||
;; string -> int -> socket
|
||||
(define udp:open
|
||||
(lambda (h p)
|
||||
(udp* (plt:udp-open-socket h p) h p)))
|
||||
(udp* (udp-open-socket h p) h p)))
|
||||
|
||||
;; socket -> bytevector -> ()
|
||||
(define udp:send
|
||||
|
|
@ -28,7 +22,7 @@
|
|||
(let ((s (udp*-s u))
|
||||
(h (udp*-h u))
|
||||
(p (udp*-p u)))
|
||||
(plt:udp-send-to* s h p b))))
|
||||
(udp-send-to* s h p b))))
|
||||
|
||||
;; socket -> maybe bytevector
|
||||
(define udp:recv
|
||||
|
|
@ -37,18 +31,18 @@
|
|||
(h (udp*-h u))
|
||||
(p (udp*-p u))
|
||||
(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
|
||||
(plt:subbytes b 0 (plt:car r))
|
||||
(subbytes b 0 (car r))
|
||||
#f))))
|
||||
|
||||
;; socket -> ()
|
||||
(define udp:close
|
||||
(lambda (u)
|
||||
(plt:udp-close (udp*-s u))))
|
||||
(udp-close (udp*-s u))))
|
||||
|
||||
;; data tcp
|
||||
(plt:define-struct tcp* (i o h p))
|
||||
(define-struct tcp* (i o h p))
|
||||
|
||||
;; any -> bool
|
||||
(define tcp:socket?
|
||||
|
|
@ -58,9 +52,9 @@
|
|||
(define tcp:open
|
||||
(lambda (h p)
|
||||
(let-values
|
||||
(((i o) (plt:tcp-connect h p)))
|
||||
(plt:file-stream-buffer-mode i 'none)
|
||||
(plt:file-stream-buffer-mode o 'none)
|
||||
(((i o) (tcp-connect h p)))
|
||||
(file-stream-buffer-mode i 'none)
|
||||
(file-stream-buffer-mode o 'none)
|
||||
(make-tcp* i o h p))))
|
||||
|
||||
;; socket -> bytevector -> ()
|
||||
|
|
@ -79,4 +73,3 @@
|
|||
(lambda (fd)
|
||||
(close-input-port (tcp*-i fd))
|
||||
(close-output-port (tcp*-o fd))))
|
||||
|
||||
|
|
|
|||
570
sosc/sosc.rkt
570
sosc/sosc.rkt
|
|
@ -1,562 +1,12 @@
|
|||
#lang racket
|
||||
|
||||
(require
|
||||
rnrs
|
||||
rhs/rhs
|
||||
"bytevector.rkt"
|
||||
rnrs/bytevectors-6 ;; TODO - should be provided by bytevector.rkt
|
||||
rnrs/io/ports-6
|
||||
)
|
||||
|
||||
(provide message
|
||||
bundle
|
||||
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)
|
||||
|#
|
||||
(require "bytevector.rkt"
|
||||
"transport.rkt"
|
||||
"encoding.rkt"
|
||||
"ip.rkt")
|
||||
|
||||
(provide
|
||||
(all-from-out "bytevector.rkt"
|
||||
"transport.rkt"
|
||||
"encoding.rkt"
|
||||
"ip.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,16 +1,12 @@
|
|||
#lang racket
|
||||
|
||||
;; from transport.scm ;;;;;;;
|
||||
|
||||
(require rnrs
|
||||
"bytevector.rkt"
|
||||
"sosc.rkt"
|
||||
(require "bytevector.rkt"
|
||||
"encoding.rkt"
|
||||
"ip.rkt")
|
||||
|
||||
(provide (all-defined-out)
|
||||
(all-from-out "ip.rkt"))
|
||||
|
||||
|
||||
(provide send
|
||||
recv
|
||||
wait)
|
||||
|
||||
;; socket -> osc -> ()
|
||||
(define send
|
||||
|
|
@ -41,4 +37,3 @@
|
|||
((not p) (error "error" "Could not connect to the SuperCollider server"))
|
||||
((not (string=? (car p) s)) (error "wait" "bad return packet" p s))
|
||||
(else p)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue