zzkt/osc
1
0
Fork 0
Code Issues 7 Pull requests Projects Releases Activity Actions

microscale

Browse source 
reduce size. return to the core. #18
This commit is contained in:
nik gaffney 2023-12-29 12:12:38 +01:00
parent 75f4ea8a27
commit b92e1675ff
Signed by: nik
GPG key ID: 989F5E6EDB478160
4 changed files with 162 additions and 164 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.github/workflows/ci.yaml vendored
View file

@ -17,7 +17,7 @@ jobs:
matrix: matrix:
# current ccl-bin has a flaky zip file, so roswell can't install it. # current ccl-bin has a flaky zip file, so roswell can't install it.
# Specify a version that works for now. # Specify a version that works for now.
lisp: [sbcl-bin, ccl-bin/1.12] lisp: [sbcl-bin]
os: [ windows-latest, ubuntu-latest, macos-latest] os: [ windows-latest, ubuntu-latest, macos-latest]
# run the job on every combination of "lisp" and "os" above # run the job on every combination of "lisp" and "os" above

25
osc-tests.lisp
View file

@ -9,7 +9,7 @@
;; Authors ;; Authors
;; - nik gaffney <nik@fo.am> ;; - nik gaffney <nik@fo.am>
#+sbcl (require 'sb-bsd-sockets) (require "usocket")
(defun osc-write () (defun osc-write ()
"a basic test function which sends various osc stuff on port 5555" "a basic test function which sends various osc stuff on port 5555"
@ -55,10 +55,13 @@
;; - error catching, junk data ;; - error catching, junk data
(defun osc-test () (defun osc-test ()
(list (format t "osc tests: ~a"
(osc-t2) (osc-t3) (osc-t4) (osc-t5) (osc-t6) (osc-t7) (osc-t8) (osc-t9) (list
(osc-t10) (osc-t11) (osc-t12) (osc-t13) (osc-t2) (osc-t3) (osc-t4)
)) (osc-t5) (osc-t6) (osc-t7)
(osc-t8) (osc-t9) (osc-t10)
(osc-t11) (osc-t12) (osc-t13)))
T)
(defun osc-t2 () (defun osc-t2 ()
(equalp '("/dip/lop" 666) (equalp '("/dip/lop" 666)
@ -146,8 +149,8 @@
(defun osc-read (port) #+sbcl (defun osc-read (port)
"a basic test function which attempts to decode osc stuff on port xc" "A basic test function which attempts to decode osc stuff on PORT."
(let ((s (make-instance 'inet-socket (let ((s (make-instance 'inet-socket
:type :datagram :type :datagram
:protocol (get-protocol-by-name "udp"))) :protocol (get-protocol-by-name "udp")))
@ -159,7 +162,7 @@
(osc:decode-message buffer) (osc:decode-message buffer)
)) ))
;(osc-decode-message data) ;;(osc-decode-message data)
(defun osc-ft () (defun osc-ft ()
(and (eql (osc::DECODE-FLOAT32 #(63 84 32 93)) 0.8286188) (and (eql (osc::DECODE-FLOAT32 #(63 84 32 93)) 0.8286188)
@ -189,9 +192,6 @@
(setf cons-msg (osc:decode-message packed-msg)) (setf cons-msg (osc:decode-message packed-msg))
(osc:encode-message (values-list cons-msg))) (osc:encode-message (values-list cons-msg)))
;;
#| #|
sc3 server sc3 server
@ -209,4 +209,5 @@ sc3 server
|# |#
;; (osc-test) (defun run-tests ()
(osc-test))

6
osc.asd
View file

@ -1,11 +1,11 @@
;; -*- mode: lisp -*- ;; -*- mode: lisp -*-
(in-package #:asdf) (in-package #:cl-user)
(defsystem osc (defsystem osc
:name "osc" :name "osc"
:author "nik gaffney <nik@fo.am>" :author "nik gaffney <nik@fo.am>"
:licence "LLGPL" :licence "GPL v3"
:description "The Open Sound Control protocol, aka OSC" :description "The Open Sound Control protocol, aka OSC"
:version "0.5" :version "1.0.0"
:components ((:file "osc"))) :components ((:file "osc")))

293
osc.lisp
View file

@ -1,59 +1,53 @@
;;; -*- mode: lisp -*- ;;; -*- mode: lisp -*-
;;; ;;;
;;; an implementation of the OSC (Open Sound Control) protocol ;;; An implementation of the OSC (Open Sound Control) protocol
;;; ;;;
;;; copyright (C) 2004 FoAM vzw. ;;; Copyright (c) 2004 FoAM
;;; ;;;
;;; You are granted the rights to distribute and use this software ;;; cl-osc is free software: you can redistribute it and/or modify it
;;; under the terms of the Lisp Lesser GNU Public License, known ;;; under the terms of the GNU General Public License as published by
;;; as the LLGPL. The LLGPL consists of a preamble and the LGPL. ;;; the Free Software Foundation, either version 3 of the License, or
;;; Where these conflict, the preamble takes precedence. The LLGPL ;;; (at your option) any later version.
;;; is available online at http://opensource.franz.com/preamble.html
;;; and is distributed with this code (see: LICENCE and LGPL files)
;;; ;;;
;;; authors ;;; authors
;;; ;;;
;;; nik gaffney <nik@f0.am> ;;; nik gaffney <nik@fo.am> and the listed AUTHORS
;;; ;;;
;;; requirements ;;; requirements
;;; ;;;
;;; dependent on sbcl, cmucl or openmcl for float encoding, other suggestions ;;; dependent on sbcl, cmucl or openmcl for float encoding, other suggestions
;;; welcome. ;;; welcome.
;;; ;;;
;;; commentary ;;; commentary
;;; ;;;
;;; this is a partial implementation of the OSC protocol which is used ;;; this is a partial implementation of the OSC protocol which is used
;;; for communication mostly amongst music programs and their attatched ;;; for communication mostly amongst music programs and their attached
;;; musicians. eg. sc3, max/pd, reaktor/traktorska etc+. more details ;;; musicians. eg. sc3, max/pd, reaktor/traktorska etc+. more details
;;; of the protocol can be found at the open sound control pages -=> ;;; of the protocol can be found at the open sound control pages -=>
;;; http://www.cnmat.berkeley.edu/OpenSoundControl/ ;;; http://www.cnmat.berkeley.edu/OpenSoundControl/
;;; ;;;
;;; - doesnt send nested bundles or timetags later than 'now'
;;; - malformed input -> exception
;;; - int32 en/de-coding based on code (c) Walter C. Pelissero
;;; - unknown types are sent as 'blobs' which may or may not be an issue
;;; ;;;
;;; see the README file for more details... ;;; see the README file for more details...
;;; ;;;
;;; known BUGS ;;; known BUGS/Issues
;;; - encoding a :symbol which is unbound, or has no symbol-value will cause ;;; - encoding a :symbol that is unbound or without symbol-value causes an error
;;; an error ;;; - unknown types are sent as 'blobs' which may or may not be an issue
;;; ;;; - malformed input -> exception
(defpackage :osc (defpackage :osc
(:use :cl) (:use :cl)
(:documentation "OSC aka the 'open sound control' protocol") (:documentation "OSC aka the 'open sound control' protocol")
(:export :encode-message (:export
:encode-bundle #:encode-message
:decode-message #:encode-bundle
:decode-bundle)) #:decode-message
#:decode-bundle))
(in-package :osc) (in-package :osc)
;; (declaim (optimize (speed 3) (safety 1) (debug 3)))
;(declaim (optimize (speed 3) (safety 1) (debug 3)))
;;;;;; ; ;; ; ; ; ; ; ; ; ;;;;;; ; ;; ; ; ; ; ; ; ;
;; ;;
;; eNcoding OSC messages ;; eNcoding OSC messages
;; ;;
;;;; ;; ;; ; ; ;; ; ; ; ; ;;;; ;; ;; ; ; ;; ; ; ; ;
@ -67,111 +61,111 @@
(encode-timetag timetag) (encode-timetag timetag)
(encode-timetag :now)) (encode-timetag :now))
(if (listp (car data)) (if (listp (car data))
(apply #'cat (mapcar #'encode-bundle-elt data)) (apply #'cat (mapcar #'encode-bundle-elt data))
(encode-bundle-elt data)))) (encode-bundle-elt data))))
(defun encode-bundle-elt (data) (defun encode-bundle-elt (data)
(let ((message (apply #'encode-message data))) (let ((message (apply #'encode-message data)))
(cat (encode-int32 (length message)) message))) (cat (encode-int32 (length message)) message)))
(defun encode-message (address &rest data) (defun encode-message (address &rest data)
"encodes an osc message with the given address and data." "encodes an osc message with the given address and data."
(concatenate '(vector (unsigned-byte 8)) (concatenate '(vector (unsigned-byte 8))
(encode-address address) (encode-address address)
(encode-typetags data) (encode-typetags data)
(encode-data data))) (encode-data data)))
(defun encode-address (address) (defun encode-address (address)
(cat (map 'vector #'char-code address) (cat (map 'vector #'char-code address)
(string-padding address))) (string-padding address)))
(defun encode-typetags (data) (defun encode-typetags (data)
"creates a typetag string suitable for the given data. "Create a typetag string suitable for the given DATA.
valid typetags according to the osc spec are ,i ,f ,s and ,b valid typetags according to the OSC spec are ,i ,f ,s and ,b
non-std extensions include ,{h|t|d|S|c|r|m|T|F|N|I|[|]} non-std extensions include ,{h|t|d|S|c|r|m|T|F|N|I|[|]}
see the spec for more details. .. see the spec for more details. ..
NOTE: currently handles the following tags NOTE: currently handles the following tags
i => #(105) => int32 i => #(105) => int32
f => #(102) => float f => #(102) => float
s => #(115) => string s => #(115) => string
b => #(98) => blob b => #(98) => blob
h => #(104) => int64 h => #(104) => int64
and considers non int/float/string data to be a blob." and considers non int/float/string data to be a blob."
(let ((lump (make-array 0 :adjustable t (let ((lump (make-array 0 :adjustable t
:fill-pointer t))) :fill-pointer t)))
(macrolet ((write-to-vector (char) (macrolet ((write-to-vector (char)
`(vector-push-extend `(vector-push-extend
(char-code ,char) lump))) (char-code ,char) lump)))
(write-to-vector #\,) (write-to-vector #\,)
(dolist (x data) (dolist (x data)
(typecase x (typecase x
(integer (if (>= x 4294967296) (write-to-vector #\h) (write-to-vector #\i))) (integer (if (>= x 4294967296) (write-to-vector #\h) (write-to-vector #\i)))
(float (write-to-vector #\f)) (float (write-to-vector #\f))
(simple-string (write-to-vector #\s)) (simple-string (write-to-vector #\s))
(t (write-to-vector #\b))))) (t (write-to-vector #\b)))))
(cat lump (cat lump
(pad (padding-length (length lump)))))) (pad (padding-length (length lump))))))
(defun encode-data (data) (defun encode-data (data)
"encodes data in a format suitable for an OSC message" "Encode DATA in a format suitable for an OSC message."
(let ((lump (make-array 0 :adjustable t :fill-pointer t))) (let ((lump (make-array 0 :adjustable t :fill-pointer t)))
(macrolet ((enc (f) (macrolet ((enc (f)
`(setf lump (cat lump (,f x))))) `(setf lump (cat lump (,f x)))))
(dolist (x data) (dolist (x data)
(typecase x (typecase x
(integer (if (>= x 4294967296) (enc encode-int64) (enc encode-int32))) (integer (if (>= x 4294967296) (enc encode-int64) (enc encode-int32)))
(float (enc encode-float32)) (float (enc encode-float32))
(simple-string (enc encode-string)) (simple-string (enc encode-string))
(t (enc encode-blob)))) (t (enc encode-blob))))
lump))) lump)))
;;;;;; ; ;; ; ; ; ; ; ; ; ;;;;;; ; ;; ; ; ; ; ; ; ;
;; ;;
;; decoding OSC messages ;; decoding OSC messages
;; ;;
;;; ;; ;; ; ; ; ; ; ; ;;; ;; ;; ; ; ; ; ; ;
(defun decode-bundle (data) (defun decode-bundle (data)
"decodes an osc bundle into a list of decoded-messages, which has "Decode an OSC bundle into a list of decoded-messages.
an osc-timetagas its first element" The first element is an osc-timetag."
(let ((contents '())) (let ((contents '()))
(if (equalp 35 (elt data 0)) ; a bundle begins with '#' (if (equalp 35 (elt data 0)) ;; a bundle begins with '#'
(let ((timetag (subseq data 8 16)) (let ((timetag (subseq data 8 16))
(i 16) (i 16)
(bundle-length (length data))) (bundle-length (length data)))
(loop while (< i bundle-length) (loop while (< i bundle-length)
do (let ((mark (+ i 4)) do (let ((mark (+ i 4))
(size (decode-int32 (size (decode-int32
(subseq data i (+ i 4))))) (subseq data i (+ i 4)))))
(if (eq size 0) (if (eq size 0)
(setf bundle-length 0) (setf bundle-length 0)
(push (decode-bundle (push (decode-bundle
(subseq data mark (+ mark size))) (subseq data mark (+ mark size)))
contents)) contents))
(incf i (+ 4 size)))) (incf i (+ 4 size))))
(push timetag contents)) (push timetag contents))
(decode-message data)))) (decode-message data))))
(defun decode-message (message) (defun decode-message (message)
"reduces an osc message to an (address . data) pair. .." "Reduce an OSC MESSAGE to an (address . data) pair."
(declare (type (vector *) message)) (declare (type (vector *) message))
(let ((x (position (char-code #\,) message))) (let ((x (position (char-code #\,) message)))
(if (eq x NIL) (if (eq x NIL)
(format t "message contains no data.. ") (format t "Message contains no data.. ")
(cons (decode-address (subseq message 0 x)) (cons (decode-address (subseq message 0 x))
(decode-taged-data (subseq message x)))))) (decode-taged-data (subseq message x))))))
(defun decode-address (address) (defun decode-address (address)
(coerce (map 'vector #'code-char (coerce (map 'vector #'code-char
(delete 0 address)) (delete 0 address))
'string)) 'string))
(defun decode-taged-data (data) (defun decode-taged-data (data)
"decodes data encoded with typetags... "Decode DATA encoded with typetags.
NOTE: currently handles the following tags NOTE: currently handles the following tags
i => #(105) => int32 i => #(105) => int32
f => #(102) => float f => #(102) => float
s => #(115) => string s => #(115) => string
@ -179,86 +173,87 @@
h => #(104) => int64" h => #(104) => int64"
(let ((div (position 0 data))) (let ((div (position 0 data)))
(let ((tags (subseq data 1 div)) (let ((tags (subseq data 1 div))
(acc (subseq data (padded-length div))) (acc (subseq data (padded-length div)))
(result '())) (result '()))
(map 'vector (map 'vector
#'(lambda (x) #'(lambda (x)
(cond (cond
((eq x (char-code #\i)) ((eq x (char-code #\i))
(push (decode-int32 (subseq acc 0 4)) (push (decode-int32 (subseq acc 0 4))
result) result)
(setf acc (subseq acc 4))) (setf acc (subseq acc 4)))
((eq x (char-code #\h)) ((eq x (char-code #\h))
(push (decode-uint64 (subseq acc 0 8)) (push (decode-uint64 (subseq acc 0 8))
result) result)
(setf acc (subseq acc 8))) (setf acc (subseq acc 8)))
((eq x (char-code #\f)) ((eq x (char-code #\f))
(push (decode-float32 (subseq acc 0 4)) (push (decode-float32 (subseq acc 0 4))
result) result)
(setf acc (subseq acc 4))) (setf acc (subseq acc 4)))
((eq x (char-code #\s)) ((eq x (char-code #\s))
(let ((pointer (padded-length (position 0 acc)))) (let ((pointer (padded-length (position 0 acc))))
(push (decode-string (push (decode-string
(subseq acc 0 pointer)) (subseq acc 0 pointer))
result) result)
(setf acc (subseq acc pointer)))) (setf acc (subseq acc pointer))))
((eq x (char-code #\b)) ((eq x (char-code #\b))
(let* ((size (decode-int32 (subseq acc 0 4))) (let* ((size (decode-int32 (subseq acc 0 4)))
(bl (+ 4 size)) (bl (+ 4 size))
(end (+ bl (mod (- 4 bl) 4)))) ; NOTE: cannot use (padded-length bl), as it is not the same algorithm. Blobs of 4, 8, 12 etc bytes should not be padded! (end (+ bl (mod (- 4 bl) 4))))
(push (decode-blob (subseq acc 0 end)) ;; NOTE: cannot use (padded-length bl), as it is not the same algorithm. Blobs of 4, 8, 12 etc bytes should not be padded!
result) (push (decode-blob (subseq acc 0 end))
(setf acc (subseq acc end)))) result)
(t (error "unrecognised typetag ~a" x)))) (setf acc (subseq acc end))))
(t (error "unrecognised typetag ~a" x))))
tags) tags)
(nreverse result)))) (nreverse result))))
;;;;;; ;; ;; ; ; ; ; ; ;; ; ;;;;;; ;; ;; ; ; ; ; ; ;; ;
;; ;;
;; timetags ;; Timetags
;; ;;
;; - timetags can be encoded using a value, or the :now and :time keywords. the ;; - timetags can be encoded using a value, or the :now and :time keywords. the
;; keywords enable either a tag indicating 'immediate' execution, or ;; keywords enable either a tag indicating 'immediate' execution, or
;; a tag containing the current time (which will most likely be in the past ;; a tag containing the current time (which will most likely be in the past
;; of anyt receiver) to be created. ;; of any receiver) to be created.
;; ;;
;; - note: not well tested, and probably not accurate enough for syncronisation. ;; - note: not well tested, and probably not accurate enough for syncronisation.
;; see also: CLHS 25.1.4 Time, and the ntp timestamp format. also needs to ;; see also: CLHS 25.1.4 Time, and the NTP timestamp format. also needs to
;; convert from 2 32bit ints to 64bit fixed point value. ;; convert from 2 32bit ints to 64bit fixed point value.
;; ;;
;; - see this c.l.l thread to sync universal-time and internal-time ;; - see this c.l.l thread to sync universal-time and internal-time
;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/c207fef63a78d720/adc7442d2e4de5a0?lnk=gst&q=internal-real-time-sync&rnum=1#adc7442d2e4de5a0 ;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/c207fef63a78d720/adc7442d2e4de5a0?lnk=gst&q=internal-real-time-sync&rnum=1#adc7442d2e4de5a0
;; ;;
;;;; ;; ; ; ;;;; ;; ; ;
(defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) (defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0))
(defun encode-timetag (utime &optional subseconds) (defun encode-timetag (utime &optional subseconds)
"encodes an osc timetag from a universal-time and 32bit 'sub-second' part. "Encode an OSC timetag from a universal-time and 32bit 'sub-second' part.
for an 'instantaneous' timetag use (encode-timetag :now) for an 'instantaneous' timetag use (encode-timetag :now)
for a timetag with the current time use (encode-timetag :time)" for a timetag with the current time use (encode-timetag :time)"
(cond (cond
;; a 1bit timetag will be interpreted as 'imediately' ;; a timetag of 1 will be interpreted as 'immediately'
((equalp utime :now) ((equalp utime :now)
#(0 0 0 0 0 0 0 1)) #(0 0 0 0 0 0 0 1))
;; converts seconds since 19000101 to seconds since 19700101 ;; converts seconds since 19000101 to seconds since 19700101
;; note: fractions of a second is accurate, but not syncronised. ;; note: fractions of seconds are accurate, but not synchronised.
((equalp utime :time) ((equalp utime :time)
(cat (encode-int32 (- (get-universal-time) +unix-epoch+)) (cat (encode-int32 (- (get-universal-time) +unix-epoch+))
(encode-int32 (encode-int32
(round (* internal-time-units-per-second (round (* internal-time-units-per-second
(second (multiple-value-list (second (multiple-value-list
(floor (/ (get-internal-real-time) (floor (/ (get-internal-real-time)
internal-time-units-per-second))))))))) internal-time-units-per-second)))))))))
((integerp utime) ((integerp utime)
(cat (encode-int32 (+ utime +unix-epoch+)) (cat (encode-int32 (+ utime +unix-epoch+))
(encode-int32 subseconds))) (encode-int32 subseconds)))
(t (error "the time or subsecond given is not an integer")))) (t (error "The time or subsecond given is not an integer."))))
(defun decode-timetag (timetag) (defun decode-timetag (timetag)
"decomposes a timetag into unix-time and a subsecond,. . ." "Decompose a TIMETAG into unix-time and subsecond."
(list (list
(decode-int32 (subseq timetag 0 4)) (decode-int32 (subseq timetag 0 4))
(decode-int32 (subseq timetag 4 8)))) (decode-int32 (subseq timetag 4 8))))
@ -271,25 +266,25 @@
;;; ;; ; ; ; ;;; ;; ; ; ;
;; floats are encoded using implementation specific 'internals' which is not ;; floats are encoded using implementation specific 'internals' which is not
;; particulaly portable, but 'works for now'. ;; particularly portable, but 'works for now'.
(defun encode-float32 (f) (defun encode-float32 (f)
"encode an ieee754 float as a 4 byte vector. currently sbcl/cmucl specifc" "Encode an ieee754 float as a 4 byte vector. currently sbcl/cmucl specific."
#+sbcl (encode-int32 (sb-kernel:single-float-bits f)) #+sbcl (encode-int32 (sb-kernel:single-float-bits f))
#+cmucl (encode-int32 (kernel:single-float-bits f)) #+cmucl (encode-int32 (kernel:single-float-bits f))
#+openmcl (encode-int32 (CCL::SINGLE-FLOAT-BITS f)) #+openmcl (encode-int32 (CCL::SINGLE-FLOAT-BITS f))
#+allegro (encode-int32 (multiple-value-bind (x y) (excl:single-float-to-shorts f) #+allegro (encode-int32 (multiple-value-bind (x y) (excl:single-float-to-shorts f)
(+ (ash x 16) y))) (+ (ash x 16) y)))
#-(or sbcl cmucl openmcl allegro) (error "cant encode floats using this implementation")) #-(or sbcl cmucl openmcl allegro) (error "Can't encode floats using this implementation."))
(defun decode-float32 (s) (defun decode-float32 (s)
"ieee754 float from a vector of 4 bytes in network byte order" "Convert a vector of 4 bytes in network byte order into an ieee754 float."
#+sbcl (sb-kernel:make-single-float (decode-int32 s)) #+sbcl (sb-kernel:make-single-float (decode-int32 s))
#+cmucl (kernel:make-single-float (decode-int32 s)) #+cmucl (kernel:make-single-float (decode-int32 s))
#+openmcl (CCL::HOST-SINGLE-FLOAT-FROM-UNSIGNED-BYTE-32 (decode-uint32 s)) #+openmcl (CCL::HOST-SINGLE-FLOAT-FROM-UNSIGNED-BYTE-32 (decode-uint32 s))
#+allegro (excl:shorts-to-single-float (ldb (byte 16 16) (decode-int32 s)) #+allegro (excl:shorts-to-single-float (ldb (byte 16 16) (decode-int32 s))
(ldb (byte 16 0) (decode-int32 s))) (ldb (byte 16 0) (decode-int32 s)))
#-(or sbcl cmucl openmcl allegro) (error "cant decode floats using this implementation")) #-(or sbcl cmucl openmcl allegro) (error "Can't decode floats using this implementation."))
(defmacro defint-decoder (num-of-octets &optional docstring) (defmacro defint-decoder (num-of-octets &optional docstring)
(let ((decoder-name (intern (format nil "~:@(decode-uint~)~D" (* 8 num-of-octets)))) (let ((decoder-name (intern (format nil "~:@(decode-uint~)~D" (* 8 num-of-octets))))
@ -331,65 +326,67 @@
(let ((i (decode-uint32 s))) (let ((i (decode-uint32 s)))
(if (>= i #.(1- (expt 2 31))) (if (>= i #.(1- (expt 2 31)))
(- (- #.(expt 2 32) i)) (- (- #.(expt 2 32) i))
i))) i)))
(defun decode-int64 (s) (defun decode-int64 (s)
"8 byte -> 64 bit int -> two's complement (in network byte order)" "8 byte -> 64 bit int -> two's complement (in network byte order)"
(let ((i (decode-uint64 s))) (let ((i (decode-uint64 s)))
(if (>= i #.(1- (expt 2 63))) (if (>= i #.(1- (expt 2 63)))
(- (- #.(expt 2 64) i)) (- (- #.(expt 2 64) i))
i))) i)))
;; osc-strings are unsigned bytes, padded to a 4 byte boundary ;; osc-strings are unsigned bytes, padded to a 4 byte boundary
(defun decode-string (data) (defun decode-string (data)
"converts a binary vector to a string and removes trailing #\nul characters" "Convert a binary vector to a string and remove any trailing #\nul characters."
(string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string))) (string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string)))
(defun encode-string (string) (defun encode-string (string)
"encodes a string as a vector of character-codes, padded to 4 byte boundary" "Encode a STRING as a vector of character-codes padded to 4 byte boundary."
(cat (map 'vector #'char-code string) (cat (map 'vector #'char-code string)
(string-padding string))) (string-padding string)))
;; blobs are binary data, consisting of a length (int32) and bytes which are ;; blobs are binary data, consisting of a length (int32) and bytes which are
;; osc-padded to a 4 byte boundary. ;; osc-padded to a 4 byte boundary.
(defun decode-blob (blob) (defun decode-blob (blob)
"decode a blob as a vector of unsigned bytes." "Decode a BLOB as a vector of unsigned bytes."
(let ((size (decode-int32 (let ((size (decode-int32
(subseq blob 0 4)))) (subseq blob 0 4))))
(subseq blob 4 (+ 4 size)))) (subseq blob 4 (+ 4 size))))
(defun encode-blob (blob) (defun encode-blob (blob)
"encodes a blob from a given vector" "Encode BLOB as a vector."
(let ((bl (length blob))) (let ((bl (length blob)))
(cat (encode-int32 bl) blob (cat (encode-int32 bl) blob
(pad (mod (- 4 bl) 4))))) ; NOTE: cannot use (padding-length bl), as it is not the same algorithm. Blobs of 4, 8, 12 etc bytes should not be padded! (pad (mod (- 4 bl) 4)))))
;; NOTE: cannot use (padding-length bl), as it is not the same algorithm. Blobs of 4, 8, 12 etc bytes should not be padded!
;; utility functions for osc-string/padding slonking ;; utility functions for osc-string/padding/slonking
(defun cat (&rest catatac) (defun cat (&rest catatac)
(apply #'concatenate '(vector *) catatac)) (apply #'concatenate '(vector *) catatac))
(defun padding-length (s) (defun padding-length (s)
"returns the length of padding required for a given length of string" "Return the length of padding required for a given length of string."
(declare (type fixnum s)) (declare (type fixnum s))
(- 4 (mod s 4))) (- 4 (mod s 4)))
(defun padded-length (s) (defun padded-length (s)
"returns the length of an osc-string made from a given length of string" "Return the length of an osc-string made from a given length of string."
(declare (type fixnum s)) (declare (type fixnum s))
(+ s (- 4 (mod s 4)))) (+ s (- 4 (mod s 4))))
(defun string-padding (string) (defun string-padding (string)
"returns the padding required for a given osc string" "Return the padding required for a given osc string."
(declare (type simple-string string)) (declare (type simple-string string))
(pad (padding-length (length string)))) (pad (padding-length (length string))))
(defun pad (n) (defun pad (n)
"make a sequence of the required number of #\Nul characters" "Make a sequence of the required number of #\Nul characters."
(declare (type fixnum n)) (declare (type fixnum n))
(make-array n :initial-element 0 :fill-pointer n)) (make-array n :initial-element 0 :fill-pointer n))
(provide :osc) (provide :osc)
;; end ;; end