podoscaph

#bundle support added to the feet. small step towards watertightness

darcs-hash:20050314140505-2648a-268ae71e964c269e196c590d867970411d786804.gz

README.txt

@@ -1,12 +1,60 @@
 
-what ->
-This is a common-lisp implementation of the Open Sound Control Protocol, aka OSC. It should be close to ansi standard, and does not rely on any external code/ffi/etc+ to do the basic encoding and decoding of packets. since OSC does not specify a transport layer, messages can be send using TCP or UDP, however it seems UDP is more common amongst the programms that communicate using the protocol.
 
-else ->
+This is a common-lisp implementation of the Open Sound Control
- - specific info about what is/isnt working can be found in the header of osc.lisp 
+Protocol, aka OSC. The code should be close to ansi standard, and does
- - more details about OSC can be found at 
+not rely on any external code/ffi/etc+ to do the basic encoding and
-            http://www.cnmat.berkeley.edu/OpenSoundControl/
+decoding of packets. since OSC does not specify a transport layer,
- - current versions of this code can be found at http://fo.am/darcs/osc
+messages can be send using TCP or UDP (or carrier pigeons), however it
+seems UDP is more common amongst the programmes that communicate using
+the OSC protocol. the osc-examples.lisp file contains a few simple
+examples of how to send and recieve OSC via UDP, and so far seems
+reasonably compatible with the packets send from/to max-msp, pd,
+supercollider and liblo. . .
+
+more details about OSC can be found at . .,
+    http://www.cnmat.berkeley.edu/OpenSoundControl/
+
+the current version of this code is avilable using darcs
+    darcs get http://fo.am/darcs/osc 
+
+
+limitations
+  - doesnt send nested bundles or timetags later than 'now' 
+  - will most likely crash if the input is malformed
+  - doesnt do any pattern matching on addresses
+  - sbcl/cmucl specific float en/decoding 
+  - only supports the type(tag)s specified in the OSC spec
+
+things to do
+  - address patterns
+  - liblo like network wrapping 
+  - data checking and error handling
+  - portable en/decoding of floats -=> ieee754 tests
+  - doubles and other defacto typetags
+  - correct en/decoding of timetags
+  - asdf-installable
+
+
+changes
+
+  2005-03-11
+     - bundle and blob en/de- coding
+  2005-03-05
+     - 'declare' scattering and other optimisations
+  2005-02-08  
+     - in-package'd
+     - basic dispatcher
+  2005-03-01
+     - fixed address string bug
+  2005-01-26 
+     - fixed string handling bug
+  2005-01-24 
+     - sends and receives multiple arguments
+     - tests in osc-tests.lisp
+  2004-12-18 
+     - initial version, single args only
+
+
 
 
 

osc-dispatch.lisp

@@ -33,7 +33,7 @@
 
 (in-package :osc)
 
-;; should probably be a clos object, and instantiated
+;; should probably be a clos object or an alist.
 ;; for now, a hash table is enuf.
 
 (defun make-osc-tree ()

osc-examples.lisp

@@ -29,19 +29,19 @@
 
 (require :sb-bsd-sockets)
 (use-package :osc)
+(use-package :sb-bsd-sockets)
+
 
 (defun osc-listen (port) 
-  "a basic test function which attempts to decode osc stuff a 
+  "a basic test function which attempts to decode an osc message a given port."
-   given port. default ogreOSC port is 4178"
-
   (let ((s (make-udp-socket))
         (buffer (make-sequence '(vector (unsigned-byte 8)) 1024)))
     (socket-bind s #(0 0 0 0) port)
     (format t "listening on localhost port ~A~%~%" port)
     (unwind-protect 
 	(loop do
-	      (socket-receive s buffer nil :waitall t)
+	      (socket-receive s buffer nil)
-	      (format t "receiveded -=> ~S~%" (osc:decode-message buffer)))
+	      (format t "receiveded -=> ~S~%" (osc:decode-bundle buffer)))
       (when s (socket-close s))))) 
 
 
@@ -59,10 +59,10 @@
 	    :element-type '(unsigned-byte 8) :buffering :full)))
       (unwind-protect 
 	  (loop do 
-		(socket-receive in buffer nil :waitall t)
+		(socket-receive in buffer nil)
-		(let ((oscuff (osc:decode-message buffer)))
+		(let ((oscuff (osc:decode-bundle buffer)))
 		  (format t "glonked -=> message with ~S~% arg(s)" (length oscuff))
-		  (stream-t1 oscuff stream)))
+		  (write-stream-t1 oscuff stream)))
 	(when in (socket-close in)) 
  	(when out (socket-close out)))))) 
 
@@ -70,7 +70,7 @@
 (defun make-udp-socket()
   (make-instance 'inet-socket :type :datagram :protocol :udp))
 
-(defun stream-t1 (osc-message stream) 
+(defun write-stream-t1 (osc-message stream) 
   "writes a given message to a stream. keep in mind that when using a buffered 
    stream any funtion writing to the stream should  call (finish-output stream)
    after it sends the mesages,. ."

osc.lisp

@@ -10,7 +10,7 @@
 ;; Where these conflict, the preamble takes precedence. The LLGPL
 ;; is available online at http://opensource.franz.com/preamble.html 
 ;; and is distributed with this code (see: LICENCE and LGPL files)
-;; 
+;;
 ;; authors 
 ;;
 ;;  nik gaffney <nik@f0.am>
@@ -27,48 +27,27 @@
 ;;  of the protocol can be found at the open sound control pages -=> 
 ;;                     http://www.cnmat.berkeley.edu/OpenSoundControl/
 ;; 
-;;  - currently doesnt send timetags, but does send typetags
+;;   - doesnt send nested bundles or timetags later than 'now' 
-;;  - will most likely crash if the input is malformed
+;;   - will most likely crash if the input is malformed
-;;  - int32 en/de-coding based on code (c) Walter C. Pelissero
+;;   - int32 en/de-coding based on code (c) Walter C. Pelissero
-  
+;;
-;; to do
+;;  see the README file for more details...
 ;;
-;;  - liblo like network wrapping
-;;  - error handling
-;;  - receiver -> osc-responder.lisp
-;;  - osc-tree as name.value alist for responder/serve-event
-;;  - portable en/decoding of floats -=> ieee754 tests
-;;  - bundles, blobs, doubles and other typetags
-;;  - asdf-installable
-
 ;; known BUGS
 ;;  - only unknown for now.. .
 
-;; changes
-;;
-;;  2004-12-18 
-;;    - initial version, single args only
-;;  2005-01-24 
-;;    - sends and receives multiple arguments
-;;    - tests in osc-test.lisp
-;;  2005-01-26 
-;;    - fixed string handling bug
-;;  2005-02-08  
-;;    - in-package'd
-;;  2005-03-01
-;;    - fixed address string bug
-;;  2005-0305
-;;    - 'declare' scattering and other optimisations
 
 (defpackage :osc
   (:use :cl)
   (:documentation "OSC aka the 'open sound control' protocol")
   (:export :encode-message
-	   :decode-message))
+	   :encode-bundle
+	   :decode-message
+	   :decode-bundle))
 
 (in-package :osc)
  
-(declaim (optimize (speed 3) (safety 1)))
+;(declaim (optimize (speed 3) (safety 1)))
 
 ;;;;;; ;    ;;    ;     ; ;     ; ; ;         ;
 ;; 
@@ -76,6 +55,20 @@
 ;;
 ;;; ;;  ;;   ; ; ;;           ;      ;  ;                  ;
 
+
+(defun encode-bundle (data)
+  "will encode an osc message, or list of messages as a bundle
+   with an optional timetag. doesnt handle nested bundles"
+  (cat '(35 98 117 110 100 108 101 0)	; #bundle
+       (encode-timetag :now)
+       (if (listp (car data))
+	   (apply #'cat (mapcar #'encode-bundle-elt data))
+	 (encode-bundle-elt data))))
+
+(defun encode-bundle-elt (data)
+  (let ((message (apply #'encode-message data)))
+    (cat (encode-int32 (length message)) message)))      
+
 (defun encode-message (address &rest data)
   "encodes an osc message with the given address and data."
   (concatenate '(vector (unsigned-byte 8))
@@ -85,7 +78,7 @@
 
 (defun encode-address (address)
   (cat (map 'vector #'char-code address) 
-       (pad-string address)))
+       (string-padding address)))
 
 (defun encode-typetags (data)
   "creates a typetag string suitable for the given data.
@@ -93,10 +86,11 @@
   non-std extensions include ,{h|t|d|S|c|r|m|T|F|N|I|[|]}
                              see the spec for more details. ..
 
-  NOTE: currently handles the following tags only 
+  NOTE: currently handles the following tags 
    i => #(105) => int32
    f => #(102) => float
-   s => #(115) => string"
+   s => #(115) => string 
+   b => #(98)  => blob" 
 
   (let ((lump (make-array 0 :adjustable t 
 			  :fill-pointer t 
@@ -110,6 +104,7 @@
           (integer (write-to-vector #\i))
           (float (write-to-vector #\f))
           (simple-string (write-to-vector #\s))
+	  (simple-vector (write-to-vector #\b))
           (t (error "can only encode ints, floats or strings"))))
       (cat lump
            (pad (padding-length (length lump)))))))     
@@ -123,67 +118,125 @@
         (typecase x
           (integer (enc encode-int32)) 
           (float (enc encode-float32)) 
-          (simple-string (enc encode-string)) 
+          (simple-string (enc encode-string))
+	  (simple-vector (enc encode-blob))
           (t (error "wrong type. turn back"))))
       lump)))
 
 
+                
 ;;;;;; ;    ;;    ;     ; ;     ; ; ;         ;
 ;; 
 ;;    decoding OSC messages
 ;;
 ;;; ;;    ;;     ; ;     ;      ;      ; ;
 
+
+(defun decode-bundle (data)
+  "decodes an osc bundle into a list of decoded-messages, which has
+   an osc-timetagas its first element"
+  (let ((contents '()))
+    (if (equalp 35 (elt data 0))	; a bundle begins with '#'
+	(let ((timetag (subseq data 8 16)) 
+	      (i 16)
+	      (bundle-length (length data)))
+	  (loop while (< i bundle-length)
+	     do (let ((mark (+ i 4))
+		      (size (decode-int32
+			     (subseq data i (+ i 4)))))
+		  (if (eq size 0)
+		      (setf bundle-length 0)
+		      (push (decode-bundle
+			     (subseq data mark (+ mark size)))
+			    contents))
+		  (incf i (+ 4 size))))
+	  (push timetag contents))
+	(decode-message data))))
+     
 (defun decode-message (message)
-  "reduces an osc message to an (address . data) pair. .."
+  "reduces an osc message to an (address . data) pair. .." 
   (declare (type (vector *) message))
   (let ((x (position (char-code #\,) message)))
     (if (eq x NIL)
         (format t "message contains no data.. ")
 	(cons (decode-address (subseq message 0 x))
 	      (decode-taged-data (subseq message x))))))
-
+ 
 (defun decode-address (address)
   (coerce (map 'vector #'code-char 
 	       (delete 0 address))
 	  'string))
- 
+
 (defun decode-taged-data (data)
   "decodes data encoded with typetags...
-  NOTE: currently handles the following tags only 
+  NOTE: currently handles the following tags 
    i => #(105) => int32
    f => #(102) => float
-   s => #(115) => string"
+   s => #(115) => string
+   b => #(98)  => blob"
+
+  (let ((div (position 0 data)))
+    (let ((tags (subseq data 1 div)) 
+	  (acc (subseq data (padded-length div)))
+	  (result '()))
+      (map 'vector
+	   #'(lambda (x)
+	       (cond
+		((eq x (char-code #\i)) 
+		 (push (decode-int32 (subseq acc 0 4)) 
+		       result)
+		 (setf acc (subseq acc 4)))
+		((eq x (char-code #\f))
+		 (push (decode-float32 (subseq acc 0 4)) 
+		       result)
+		 (setf acc (subseq acc 4)))
+		((eq x (char-code #\s))
+		 (let ((pointer (padded-length (position 0 acc))))
+		   (push (decode-string 
+			  (subseq acc 0 pointer))
+			 result)
+		   (setf acc (subseq acc pointer))))
+		((eq x (char-code #\b)) 
+		 (let ((size (decode-int32 (subseq acc 0 4))))
+		   (let ((end (padded-length (+ 4 size))))
+		     (push (decode-blob (subseq acc 0 end)) 
+			   result)
+		     (setf acc (subseq acc end)))))
+		(t  (error "unrecognised typetag"))))
+	   tags)
+      (nreverse result))))
+
+
+;;; ; ;; ;
+;;	
+;; timetags
+;;
+;; - not yet, but probably something using
+;; (get-universal-time)  >  see also: CLHS 25.1.4 Time
+;;   or connecting to an ntp server.,.  - ntpdate, ntpq
+;;
+;; - begin with bundles using 'now' as the timetag
+;; - this should really handle 64bit fixed ints,
+;;   not signed 32bit ints
+;;
+;;;; ;; ; ; 
+
+(defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0))
+
+(defun encode-timetag (ut &optional subseconds)
+  "encodes an osc timetag from a universal-time and 32bit 'sub-second' part
+   for an 'instantaneous' timetag use (encode-timetag :now) "
+  (if (equalp ut :now)
+      #(0 0 0 0 0 0 0 1)
+      (cat (encode-int32 (+ ut +unix-epoch+))
+	   (encode-int32 (subseconds)))))
+
+(defun decode-timetag (timetag)
+  "decomposes a timetag into ut and a subsecond,. . ."
+  (list
+   (decode-int32 (subseq timetag 0 4))
+   (decode-int32 (subseq timetag 4 8))))
 
-  (setf div (position 0 data))
-  (let ((tags (subseq data 1 div)) 
-	(chunks (subseq data (osc-string-length (subseq data 0 div))))
-        (acc '())
-	(result '()))
-    (setf acc chunks)
-    (map 'vector
-	 #'(lambda (x)
-	     (cond
-	       ((eq x (char-code #\i)) 
-		(push (decode-int32 (subseq acc 0 4)) 
-		      result)
-		(setf acc (subseq acc 4)))
-	       ((eq x (char-code #\f))
-		(push (decode-float32  (subseq acc 0 4)) 
-		      result)
-		(setf acc (subseq acc 4)))
-	       ((eq x (char-code #\s))
-		(let ((pointer (+ (padding-length (position 0 acc))
-				  (position 0 acc))))
-		  (push (decode-string 
-			 (subseq acc 0 pointer))
-			result)
-		  (setf acc (subseq acc pointer))))
-	       ((eq x (char-code #\b)) (decode-blob x))
-	       (t  (error "unrecognised typetag"))))
-	 tags)
-    (nreverse result)))
-	
 
 ;;;;; ; ; ;;    ;; ; ;
 ;;
@@ -204,7 +257,6 @@
   #-(or sbcl cmucl) (error "cant decode floats using this implementation"))
 
 (defun decode-int32 (s)
-  (declare (type (vector (unsigned-byte 8) s)))
   "4 byte > 32 bit int > two's compliment (in network byte order)"
   (let ((i (+ (ash (elt s 0) 24)
 	      (ash (elt s 1) 16)
@@ -228,7 +280,7 @@
       (set-byte 3))
     buf))
 
-
+;; osc-strings are unsigned bytes, padded to a 4 byte boundary 
 
 (defun decode-string (data)
   "converts a binary vector to a string and removes trailing #\nul characters"
@@ -237,33 +289,40 @@
 (defun encode-string (string)
   "encodes a string as a vector of character-codes, padded to 4 byte boundary"
   (cat (map 'vector #'char-code string) 
-       (pad-string string)))
+       (string-padding string)))
 
-(defun decode-blob (b)
+;; blobs are binary data, consisting of a length (int32) and bytes which are
-  (error "cant decode blobs for now. .."))
+;; osc-padded to a 4 byte boundary.
 
-(defun encode-blob (b)
+(defun decode-blob (blob)
-  (error "cant encode blobs for now. .."))
+  "decode a blob as a vector of unsigned bytes."
+  (let ((size (decode-int32
+	       (subseq blob 0 4))))
+    (subseq blob 4 (+ 4 size)))) 
+
+(defun encode-blob (blob)
+  "encodes a blob from a given vector"
+  (let ((bl (length blob)))
+    (cat (encode-int32 bl) blob
+	 (pad (padding-length bl)))))      
 
 
-;; utility functions for OSC slonking
+;; utility functions for osc-string/padding slonking
 
 (defun cat (&rest catatac)
   (apply #'concatenate '(vector *) catatac))
 
-(defun osc-string-length (string)
-  "determines the length required for a padded osc string"
-  (declare (type simple-string string))
-  (let ((n (length string)))
-    (declare (type fixnum n))
-    (+ n (padding-length n))))
-
 (defun padding-length (s)
   "returns the length of padding required for a given length of string"
   (declare (type fixnum s))
   (- 4 (mod s 4)))
 
-(defun pad-string (string)
+(defun padded-length (s)
+  "returns the length of an osc-string made from a given length of string"
+  (declare (type fixnum s))
+  (+ s (- 4 (mod s 4))))
+
+(defun string-padding (string)
   "returns the padding required for a given osc string"
   (declare (type simple-string string)) 
   (pad (- 4 (mod (length string) 4))))