remove rnrs dependencies and improve racket comparability

This commit is contained in:
nik gaffney 2022-08-24 13:15:13 +02:00
parent a25985dab2
commit d37f0a2e03
7 changed files with 1019 additions and 1143 deletions

View file

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

File diff suppressed because it is too large Load diff

View file

@ -1,7 +1,6 @@
#lang racket #lang racket
(require rnrs (require rhs/rhs
rhs/rhs
rnrs/bytevectors-6 rnrs/bytevectors-6
rnrs/io/ports-6) rnrs/io/ports-6)
@ -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
@ -72,7 +71,7 @@
(module+ test (module+ test
(require rackunit) (require rackunit)
;; test bytevector-section, which is equivalent ot subbytes ;; test bytevector-section, which is equivalent ot subbytes
(test-begin (test-begin
(let [(long-vec (bytes 10 20 30 40 50))] (let [(long-vec (bytes 10 20 30 40 50))]
@ -82,10 +81,10 @@
long-vec) long-vec)
(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)))))
(check-equal? (flatten-bytevectors (list (bytes 10 20) (bytes 30 40) (list (bytes 50 60)))) (check-equal? (flatten-bytevectors (list (bytes 10 20) (bytes 30 40) (list (bytes 50 60))))
(bytes 10 20 30 40 50 60))) (bytes 10 20 30 40 50 60)))

564
sosc/encoding.rkt Normal file
View file

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

View file

@ -1,15 +1,9 @@
#lang racket #lang racket
;; from plt/ip.scm ;;;;;;;;;; (require "bytevector.rkt")
(require (prefix-in plt: racket)
(prefix-in plt: racket/udp)
"bytevector.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
;; data udp ;; data udp
(struct udp* (s h p)) (struct udp* (s h p))
@ -20,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))))

View file

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

View file

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