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))
|
(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)))
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
|
||||||
742
rsc3/main.rkt
742
rsc3/main.rkt
File diff suppressed because it is too large
Load diff
|
|
@ -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)
|
||||||
|
|
||||||
|
|
@ -17,7 +16,7 @@
|
||||||
(define with-input-from-bytevector
|
(define with-input-from-bytevector
|
||||||
(lambda (b f)
|
(lambda (b f)
|
||||||
(let* ((p (open-bytevector-input-port b))
|
(let* ((p (open-bytevector-input-port b))
|
||||||
(r (f p)))
|
(r (f p)))
|
||||||
(close-port p)
|
(close-port p)
|
||||||
r)))
|
r)))
|
||||||
|
|
||||||
|
|
@ -25,7 +24,7 @@
|
||||||
(define bytevector-section
|
(define bytevector-section
|
||||||
(lambda (v l r)
|
(lambda (v l r)
|
||||||
(let* ((n (- r l))
|
(let* ((n (- r l))
|
||||||
(w (make-bytevector n 0)))
|
(w (make-bytevector n 0)))
|
||||||
(bytevector-copy! v l w 0 n)
|
(bytevector-copy! v l w 0 n)
|
||||||
w)))
|
w)))
|
||||||
|
|
||||||
|
|
@ -33,27 +32,27 @@
|
||||||
(define bytevector-find-index
|
(define bytevector-find-index
|
||||||
(lambda (v x)
|
(lambda (v x)
|
||||||
(letrec ((f (lambda (i)
|
(letrec ((f (lambda (i)
|
||||||
(if (= (bytevector-u8-ref v i) x)
|
(if (= (bytevector-u8-ref v i) x)
|
||||||
i
|
i
|
||||||
(f (+ i 1))))))
|
(f (+ i 1))))))
|
||||||
(f 0))))
|
(f 0))))
|
||||||
|
|
||||||
;; Tree bytevector -> bytevector
|
;; Tree bytevector -> bytevector
|
||||||
(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)
|
||||||
(l l)
|
(l l)
|
||||||
(n n))
|
(n n))
|
||||||
(if (null? l)
|
(if (null? l)
|
||||||
v
|
v
|
||||||
(let ((l0 (car l))
|
(let ((l0 (car l))
|
||||||
(n0 (car n)))
|
(n0 (car n)))
|
||||||
(bytevector-copy! l0 0 v i n0)
|
(bytevector-copy! l0 0 v i n0)
|
||||||
(loop (+ i n0) (cdr l) (cdr n))))))))
|
(loop (+ i n0) (cdr l) (cdr n))))))))
|
||||||
|
|
||||||
;; number a => (bytevector -> int -> a -> ()) -> int -> a
|
;; number a => (bytevector -> int -> a -> ()) -> int -> a
|
||||||
(define bytevector-make-and-set1
|
(define bytevector-make-and-set1
|
||||||
|
|
@ -83,7 +82,7 @@
|
||||||
(check-equal? (bytevector-section long-vec 1 3)
|
(check-equal? (bytevector-section long-vec 1 3)
|
||||||
(subbytes long-vec 1 3))
|
(subbytes long-vec 1 3))
|
||||||
|
|
||||||
; check if exceding limits raises exception
|
; check if exceding limits raises exception
|
||||||
(check-exn exn:fail? (λ () (bytevector-section long-vec 0 30)))
|
(check-exn exn:fail? (λ () (bytevector-section long-vec 0 30)))
|
||||||
(check-exn exn:fail? (λ () (bytevector-section long-vec -1 3)))))
|
(check-exn exn:fail? (λ () (bytevector-section long-vec -1 3)))))
|
||||||
|
|
||||||
|
|
|
||||||
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)
|
||||||
|
|#
|
||||||
41
sosc/ip.rkt
41
sosc/ip.rkt
|
|
@ -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,35 +14,35 @@
|
||||||
;; 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
|
||||||
(lambda (u b)
|
(lambda (u b)
|
||||||
(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
|
||||||
(lambda (u)
|
(lambda (u)
|
||||||
(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))
|
||||||
(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,10 +52,10 @@
|
||||||
(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 -> ()
|
||||||
(define tcp:send
|
(define tcp:send
|
||||||
|
|
@ -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
570
sosc/sosc.rkt
|
|
@ -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)
|
|
||||||
|#
|
|
||||||
|
|
|
||||||
|
|
@ -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)))))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue