Mercurial > core / lisp/lib/net/codec/osc.lisp
changeset 212: |
742e6d74752d |
parent: |
524dfb768c7a
|
child: |
750629f830b2 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 23 Feb 2024 18:09:23 -0500 |
permissions: |
-rw-r--r-- |
description: |
added sans-io module, more bits |
1 (in-package :net/codec/osc) 4 (defparameter *default-osc-buffer-size* 1024) 6 ;; utility functions for osc-string/padding slonking 8 (defun cat (&rest args) 9 (apply #'concatenate '(vector (unsigned-byte 8)) args)) 11 (defun padding-length (s) 12 "returns the length of padding required for a given length of string" 13 (declare (type fixnum s)) 16 (defun padded-length (s) 17 "returns the length of an osc-string made from a given length of string" 18 (declare (type fixnum s)) 19 (+ s (- 4 (mod s 4)))) 21 (defun string-padding (string) 22 "returns the padding required for a given osc string" 23 (declare (type simple-string string)) 24 (pad (padding-length (length string)))) 27 "make a sequence of the required number of #\Nul characters" 28 (declare (type fixnum n)) 29 (make-array n :initial-element 0 :fill-pointer n)) 31 (defclass osc-data () ()) 33 (defclass message (osc-data) 42 (defclass bundle (osc-data) 54 (defun make-message (command args) 56 (setf args (list args))) 57 (make-instance 'message 61 (defun message (command &rest args) 62 (make-message command args)) 64 (defun make-bundle (timetag elements) 65 (unless (listp elements) 66 (setf elements (list elements))) 67 (make-instance 'bundle 71 (defun bundle (timetag &rest elements) 72 (make-bundle timetag elements)) 74 (defgeneric format-osc-data (data &key stream width)) 76 (defmethod format-osc-data ((message message) &key (stream t) 78 (let ((args-string (format nil "~{~a~^ ~}" (args message)))) 79 (when (> (length args-string) width) 82 (subseq args-string 0 width) 84 (format stream "~a ~a~%" 88 (defmethod format-osc-data ((bundle bundle) &key (stream t) (width 80)) 89 (format stream "~&[ ~a~%" (timetag bundle)) 90 (dolist (element (elements bundle)) 91 (format-osc-data element :stream stream :width width)) 92 (format stream "~&]~%")) 96 (defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) 97 (defconstant +2^32+ (expt 2 32)) 98 (defconstant +2^32/million+ (/ +2^32+ (expt 10 6))) 99 (defconstant +usecs+ (expt 10 6)) 101 (deftype timetag () '(unsigned-byte 64)) 103 (defun timetagp (object) 104 (typep object 'timetag)) 106 (defun unix-secs+usecs->timetag (secs usecs) 107 (let ((sec-offset (+ secs +unix-epoch+))) ; Seconds from 1900. 108 (setf sec-offset (ash sec-offset 32)) ; Make seconds the top 32 111 (round (* usecs +2^32/MILLION+)))) ; Fractional part. 112 (the timetag (+ sec-offset usec-offset))))) 114 (defun get-current-timetag () 115 "Returns a fixed-point 64 bit NTP-style timetag, where the top 32 116 bits represent seconds since midnight 19000101, and the bottom 32 bits 117 represent the fractional parts of a second." 118 #+sbcl (multiple-value-bind (secs usecs) 119 (sb-ext:get-time-of-day) 120 (the timetag (unix-secs+usecs->timetag secs usecs))) 121 #-sbcl (error "Can't encode timetags using this implementation.")) 123 (defun timetag+ (original seconds-offset) 124 (declare (type timetag original)) 125 (let ((offset (round (* seconds-offset +2^32+)))) 126 (the timetag (+ original offset)))) 129 ;;;===================================================================== 130 ;;; Functions for using double-float unix timestamps. 131 ;;;===================================================================== 133 (defun get-unix-time () 134 "Returns a a double-float representing real-time now in seconds, 135 with microsecond precision, relative to 19700101." 136 #+sbcl (multiple-value-bind (secs usecs) 137 (sb-ext:get-time-of-day) 138 (the double-float (+ secs (microseconds->subsecs usecs)))) 139 #-sbcl (error "Can't encode timetags using this implementation.")) 141 (defun unix-time->timetag (unix-time) 142 (multiple-value-bind (secs subsecs) 145 (unix-secs+usecs->timetag secs 146 (subsecs->microseconds subsecs))))) 148 (defun timetag->unix-time (timetag) 150 1 ; immediate timetag 151 (let* ((secs (ash timetag -32)) 152 (subsec-int32 (- timetag (ash secs 32)))) 153 (the double-float (+ (- secs +unix-epoch+) 154 (int32->subsecs subsec-int32)))))) 156 (defun microseconds->subsecs (usecs) 157 (declare (type (integer 0 1000000) usecs)) 158 (coerce (/ usecs +usecs+) 'double-float)) 160 (defun subsecs->microseconds (subsecs) 161 (declare (type (float 0.0 1.0) subsecs)) 162 (round (* subsecs +usecs+))) 164 (defun int32->subsecs (int32) 165 "This maps a 32 bit integer, representing subsecond time, to a 166 double float in the range 0-1." 167 (declare (type (unsigned-byte 32) int32)) 168 (coerce (/ int32 +2^32+) 'double-float)) 170 (defun print-as-double (time) 171 (format t "~%~F" (coerce time 'double-float)) 174 (defgeneric encode-osc-data (data)) 176 (defmethod encode-osc-data ((data message)) 177 "Encode an osc message with the given address and args." 178 (with-slots (command args) data 179 (concatenate '(vector (unsigned-byte 8)) 180 (encode-address command) 181 (encode-typetags args) 182 (encode-args args)))) 184 (defmethod encode-osc-data ((data bundle)) 185 "Encode an osc bundle. A bundle contains a timetag (symbol or 64bit 186 int) and a list of message or nested bundle elements." 187 (with-slots (timetag elements) data 188 (cat '(35 98 117 110 100 108 101 0) ; #bundle 190 (encode-timetag timetag) 191 (encode-timetag :now)) 192 (apply #'cat (mapcar #'encode-bundle-elt elements))))) 194 (defgeneric encode-bundle-elt (data)) 196 (defmethod encode-bundle-elt ((data message)) 197 (let ((bytes (encode-osc-data data))) 198 (cat (encode-int32 (length bytes)) bytes))) 200 (defmethod encode-bundle-elt ((data bundle)) 201 (let ((bytes (encode-osc-data data))) 202 (cat (encode-int32 (length bytes)) bytes))) 204 ;; Auxilary functions 206 (defun encode-address (address) 207 (cat (map 'vector #'char-code address) 208 (string-padding address))) 210 (defun encode-typetags (data) 211 "creates a typetag string suitable for the given data. 212 valid typetags according to the osc spec are ,i ,f ,s and ,b 213 non-std extensions include ,{h|t|d|S|c|r|m|T|F|N|I|[|]} 214 see the spec for more details. .. 216 NOTE: currently handles the following tags 219 s => #(115) => string 222 and considers non int/float/string data to be a blob." 224 (let ((lump (make-array 0 :adjustable t 226 (macrolet ((write-to-vector (char) 228 (char-code ,char) lump))) 229 (write-to-vector #\,) 232 (integer (if (>= x 4294967296) (write-to-vector #\h) (write-to-vector #\i))) 233 (float (write-to-vector #\f)) 234 (simple-string (write-to-vector #\s)) 235 (keyword (write-to-vector #\s)) 236 (t (write-to-vector #\b))))) 238 (pad (padding-length (length lump)))))) 240 (defun encode-args (args) 241 "encodes args in a format suitable for an OSC message" 242 (let ((lump (make-array 0 :adjustable t :fill-pointer t))) 244 `(setf lump (cat lump (,f x))))) 247 (integer (if (>= x 4294967296) (enc encode-int64) (enc encode-int32))) 248 (float (enc encode-float32)) 249 (simple-string (enc encode-string)) 250 (t (enc encode-blob)))) 254 ;;;;;; ; ;; ; ; ; ; ; ; ; 256 ;; decoding OSC messages 258 ;;; ;; ;; ; ; ; ; ; ; 260 (defun bundle-p (buffer &optional (start 0)) 261 "A bundle begins with '#bundle' (8 bytes). The start argument should 262 index the beginning of a bundle in the buffer." 263 (= 35 (elt buffer start))) 265 (defun get-timetag (buffer &optional (start 0)) 266 "Bytes 8-15 are the bundle timestamp. The start argument should 267 index the beginning of a bundle in the buffer." 268 (decode-timetag (subseq buffer 272 (defun get-bundle-element-length (buffer &optional (start 16)) 273 "Bytes 16-19 are the size of the bundle element. The start argument 274 should index the beginning of the bundle element (length, content) 276 (decode-int32 (subseq buffer start (+ 4 start)))) 278 (defun get-bundle-element (buffer &optional (start 16)) 279 "Bytes 20 upto to the length of the content (defined by the 280 preceding 4 bytes) are the content of the bundle. The start argument 281 should index the beginning of the bundle element (length, content) 283 (let ((length (get-bundle-element-length buffer start))) 289 (defun split-sequence-by-n (sequence n) 290 (loop :with length := (length sequence) 291 :for start :from 0 :by n :below length 293 (subseq sequence start (min length (+ start n))) 296 (defun print-buffer (buffer &optional (n 8)) 297 (format t "~%~{~{ ~5d~}~%~}Total: ~a bytes~2%" 298 (split-sequence-by-n buffer n) 301 (defun decode-bundle (buffer &key (start 0) end) 302 "Decodes an osc bundle/message into a bundle/message object. Bundles 303 comprise an osc-timetag and a list of elements, which may be 304 messages or bundles recursively. An optional end argument can be 305 supplied (i.e. the length value returned by socket-receive, or the 306 element length in the case of nested bundles), otherwise the entire 307 buffer is decoded - in which case, if you are reusing buffers, you 308 are responsible for ensuring that the buffer does not contain stale 311 (setf end (- (length buffer) start))) 313 (format t "~%Buffer start: ~a end: ~a~%" start end) 314 (print-buffer (subseq buffer start end))) 315 (if (bundle-p buffer start) 317 (let ((timetag (get-timetag buffer start))) 318 (incf start (+ 8 8)) ; #bundle, timetag bytes 319 (loop while (< start end) 320 for element-length = (get-bundle-element-length 322 do (incf start 4) ; length bytes 324 do (format t "~&Bundle element length: ~a~%" element-length) 325 collect (decode-bundle buffer 327 :end (+ start element-length)) 329 do (incf start (+ element-length)) 331 (values (make-bundle timetag elements) 336 (subseq buffer start (+ start end))))) 337 (make-message (car message) (cdr message))))) 339 (defun decode-message (message) 340 "reduces an osc message to an (address . data) pair. .." 341 (declare (type (vector *) message)) 342 (let ((x (position (char-code #\,) message))) 344 (format t "message contains no data.. ") 345 (cons (decode-address (subseq message 0 x)) 346 (decode-taged-data (subseq message x)))))) 348 (defun decode-address (address) 349 (coerce (map 'vector #'code-char 353 (defun decode-taged-data (data) 354 "decodes data encoded with typetags... 355 NOTE: currently handles the following tags 358 s => #(115) => string 360 h => #(104) => int64" 362 (let ((div (position 0 data))) 363 (let ((tags (subseq data 1 div)) 364 (acc (subseq data (padded-length div))) 369 ((eq x (char-code #\i)) 370 (push (decode-int32 (subseq acc 0 4)) 372 (setf acc (subseq acc 4))) 373 ((eq x (char-code #\h)) 374 (push (decode-uint64 (subseq acc 0 8)) 376 (setf acc (subseq acc 8))) 377 ((eq x (char-code #\f)) 378 (push (decode-float32 (subseq acc 0 4)) 380 (setf acc (subseq acc 4))) 381 ((eq x (char-code #\s)) 382 (let ((pointer (padded-length (position 0 acc)))) 384 (subseq acc 0 pointer)) 386 (setf acc (subseq acc pointer)))) 387 ((eq x (char-code #\b)) 388 (let* ((size (decode-int32 (subseq acc 0 4))) 390 (end (+ bl (mod (- 4 bl) 4)))) 391 ;; NOTE: cannot use (padded-length bl), as it is not the same algorithm. 392 ;; Blobs of 4, 8, 12 etc bytes should not be padded! 393 (push (decode-blob (subseq acc 0 end)) 395 (setf acc (subseq acc end)))) 396 (t (error "unrecognised typetag ~a" x)))) 401 ;;;;;; ;; ;; ; ; ; ; ; ;; ; 405 ;; - timetags can be encoded using a value, or the :now and :time 406 ;; keywords. the keywords enable either a tag indicating 'immediate' 407 ;; execution, or a tag containing the current time (which will most 408 ;; likely be in the past of any receiver) to be created. 410 ;; - see this c.l.l thread to sync universal-time and internal-time 411 ;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/c207fef63a78d720/adc7442d2e4de5a0?lnk=gst&q=internal-real-time-sync&rnum=1#adc7442d2e4de5a0 413 ;; - In SBCL, using sb-ext:get-time-of-day to get accurate seconds and 414 ;; microseconds from OS. 418 (defun encode-timetag (timetag) 419 "From the spec: `Time tags are represented by a 64 bit fixed point 420 number. The first 32 bits specify the number of seconds since midnight 421 on January 1, 1900, and the last 32 bits specify fractional parts of a 422 second to a precision of about 200 picoseconds. This is the 423 representation used by Internet NTP timestamps'. For an 424 'instantaneous' timetag use (encode-timetag :now), and for a timetag 425 with the current time use (encode-timetag :time)." 427 ((equalp timetag :now) 428 ;; a 1 bit timetag will be interpreted as 'immediately' 430 ((equalp timetag :time) 431 ;; encode timetag with current real time 432 (encode-int64 (get-current-timetag))) 434 ;; encode osc timetag 435 (encode-int64 timetag)) 436 (t (error "Argument given is not one of :now, :time, or timetagp.")))) 438 (defun decode-timetag (timetag) 439 "Return a 64 bit timetag from a vector of 8 bytes in network byte 441 (if (equalp timetag #(0 0 0 0 0 0 0 1)) 442 1 ; A timetag of 1 is defined as immediately. 443 (decode-uint64 timetag))) 447 ;; dataformat en- de- cetera. 451 ;; floats are encoded using implementation specific 'internals' which is not 452 ;; particulaly portable, but 'works for now'. 454 (defun encode-float32 (f) 455 "encode an ieee754 float as a 4 byte vector. currently sbcl/cmucl specific" 456 (encode-int32 (sb-kernel:single-float-bits f))) 458 (defun decode-float32 (s) 459 "ieee754 float from a vector of 4 bytes in network byte order" 460 (sb-kernel:make-single-float (decode-int32 s))) 462 (defmacro defint-decoder (num-of-octets &optional docstring) 463 (let ((decoder-name (intern (format nil "~:@(decode-uint~)~D" (* 8 num-of-octets)))) 466 `(defun ,decoder-name (,seq) 471 for n below num-of-octets 472 collect `(,int (dpb (aref ,seq ,n) (byte 8 (* 8 (- (1- ,num-of-octets) ,n))) 478 (defun decode-uint32 (s) 479 "4 byte -> 32 bit unsigned int" 480 (let ((i (+ (ash (elt s 0) 24) 486 (defmacro defint-encoder (num-of-octets &optional docstring) 487 (let ((enc-name (intern (format nil "~:@(encode-int~)~D" (* 8 num-of-octets)))) 490 `(defun ,enc-name (,int) 493 (let ((,buf (make-array ,num-of-octets :element-type '(unsigned-byte 8)))) 495 for n below num-of-octets 496 collect `(setf (aref ,buf ,n) 497 (ldb (byte 8 (* 8 (- (1- ,num-of-octets) ,n))) 501 (defint-encoder 4 "Convert an integer into a sequence of 4 bytes in network byte order (32 bit).") 502 (defint-encoder 8 "Convert an integer into a sequence of 8 bytes in network byte order (64 bit).") 504 (defun decode-int32 (s) 505 "4 byte -> 32 bit int -> two's complement (in network byte order)" 506 (let ((i (decode-uint32 s))) 507 (if (>= i #.(1- (expt 2 31))) 508 (- (- #.(expt 2 32) i)) 511 (defun decode-int64 (s) 512 "8 byte -> 64 bit int -> two's complement (in network byte order)" 513 (let ((i (decode-uint64 s))) 514 (if (>= i #.(1- (expt 2 63))) 515 (- (- #.(expt 2 64) i)) 518 ;; osc-strings are unsigned bytes, padded to a 4 byte boundary 520 (defun encode-string (string) 521 "encodes a string as a vector of character-codes, padded to 4 byte boundary" 522 (cat (map 'vector #'char-code string) 523 (string-padding string))) 525 (defun decode-string (data) 526 "converts a binary vector to a string and removes trailing #\nul characters" 527 (string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string))) 530 ;; blobs are binary data, consisting of a length (int32) and bytes which are 531 ;; osc-padded to a 4 byte boundary. 533 (defun encode-blob (blob) 534 "encodes a blob from a given vector" 535 (let ((bl (length blob))) 536 (cat (encode-int32 bl) blob 537 (pad (padding-length bl))))) 539 (defun decode-blob (blob) 540 "decode a blob as a vector of unsigned bytes." 541 (let ((size (decode-int32 543 (subseq blob 4 (+ 4 size)))) 545 (defun make-osc-tree () 546 (make-hash-table :test 'equalp)) 549 ;;; ;; ;;;;;; ; ; ; ; 551 ;; register/delete and dispatch. .. 555 (defun dp-register (tree address function) 556 "Registers a function to respond to incoming osc messages. Since 557 only one function should be associated with an address, any 558 previous registration will be overwritten." 559 (setf (gethash address tree) 562 (defun dp-remove (tree address) 563 "Removes the function associated with the given address." 564 (remhash address tree)) 566 (defun dp-match (tree pattern) 567 "Returns a list of functions which are registered for dispatch for a 568 given address pattern." 569 (list (gethash pattern tree))) 571 (defgeneric dispatch (tree data device address port &optional timetag 574 (defmethod dispatch (tree (data message) device address port &optional 577 "Calls the function(s) matching the address(pattern) in the osc 578 message passing the message object, the recieving device, and 579 optionally in the case where a message is part of a bundle, the 580 timetag of the bundle and the enclosing bundle." 581 (let ((pattern (command data))) 582 (dolist (x (dp-match tree pattern)) 584 (funcall x (command data) (args data) device address port 585 timetag parent-bundle))))) 587 (defmethod dispatch (tree (data bundle) device address port &optional 590 "Dispatches each bundle element in sequence." 591 (declare (ignore timetag parent-bundle)) 592 (dolist (element (elements data)) 593 (dispatch tree element device address port (timetag data) data)))