groschen

darcs-hash:20050302172356-2648a-b99e953e8920e6a6a0c5155c050ea04a46719c11.gz

README.txt

@@ -4,7 +4,8 @@ This is a common-lisp implementation of the Open Sound Control Protocol, aka OSC
 
 else ->
  - specific info about what is/isnt working can be found in the header of osc.lisp 
- - more details about OSC can be found at  http://www.cnmat.berkeley.edu/OpenSoundControl/
+ - more details about OSC can be found at 
+            http://www.cnmat.berkeley.edu/OpenSoundControl/
  - current versions of this code can be found at http://fo.am/darcs/osc
 
 

osc-dispatch.lisp

@@ -0,0 +1,65 @@
+;; -*- mode: lisp -*-
+;;
+;; patern matching and dispatching for OSC messages 
+;;
+;; copyright (C) 2004 FoAM vzw
+;;
+;; You are granted the rights to distribute and use this software
+;; under the terms of the Lisp Lesser GNU Public License, known 
+;; as the LLGPL. The LLGPL consists of a preamble and the LGPL. 
+;; 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>
+
+;; requirements
+;;  - not too useful without osc
+;;  - probably cl-pcre for matching (when it happens). 
+
+;; commentary
+;;  an osc de-/re -mungulator which should deal with piping data
+;;  from incoming messages to the function/handler/method
+;;  designated by the osc-address. 
+;;
+;;  NOTE: only does direct matches for now, no pattern globs,
+;;        with single function per uri     
+
+;; changes
+;;  2005-02-27 18:31:01
+;;  - initial version
+
+(in-package :osc)
+
+;; should probably be a clos object, and instantiated
+(defun osc-tree ()
+  (make-hash-table :test 'equalp))
+
+;; lookout for leaky abstract trees.. ,
+;;   how should this be better encapsulatd??
+
+(defun dp-register (tree address function)
+  "registers a function to respond to incoming osc message. since
+   only one function should be associated with an address, any
+   previous registration will be overwritten"
+  (setf (gethash address tree)
+	function))
+
+(defun dp-remove (tree address)
+  "removes the function associated with the given adress.."
+  (remhash address tree))
+
+(defun dp-match (tree pattern)
+"returns a list of functions which are registered for
+ dispatch for a given address pattern.."
+  (list (gethash pattern tree)))
+
+(defun dispatch (tree osc-message)
+  "calls the function(s) matching the address(pattern) in the osc 
+   message with the data contained in the message"
+  (dolist (x (dp-match tree 
+                       (car osc-message)))
+    (unless (eq x NIL)
+      (eval `(,x  ,@(cdr osc-message))))))

osc.lisp

@@ -54,7 +54,9 @@
 ;;  2005-01-26 
 ;;    - fixed string handling bug
 ;;  2005-02-08  
-;;    - in-package'd 
+;;    - in-package'd
+;;  2005-03-01
+;;    - fixed address string bug
 
 (defpackage :osc
   (:use :cl)
@@ -93,34 +95,31 @@
    s => #(115) => string"
 
   (let ((lump (make-array 0 :adjustable t :fill-pointer t)))
-    (vector-push-extend (char-code #\,) lump) ; typetag begins with ","
-    (dolist (x data) 
-      (typecase x
-	(integer
-	 (vector-push-extend (char-code #\i) lump))
-	(float 
-	 (vector-push-extend (char-code #\f) lump))
-	(simple-string 
-	 (vector-push-extend (char-code #\s) lump))
-	(t 
-	 (error "can only encode ints, floats or string"))))
-    (cat lump
-	 (pad (padding-length (length lump))))))      
+    (macrolet ((write-to-vector (char)
+                 `(vector-push-extend
+                   (char-code ,char) lump)))
+      (write-to-vector #\,)
+      (dolist (x data) 
+        (typecase x
+          (integer (write-to-vector #\i))
+          (float (write-to-vector #\f))
+          (simple-string (write-to-vector #\s))
+          (t (error "can only encode ints, floats or strings"))))
+      (cat lump
+           (pad (padding-length (length lump)))))))     
 		  
 (defun encode-data (data)
   "encodes data in a format suitable for an OSC message"
   (let ((lump (make-array 0 :adjustable t :fill-pointer t)))
-    (dolist (x data) 
-      (typecase x
-	(integer
-	 (setf lump (cat lump (encode-int32 x)))) 
-	(float 
-	 (setf lump (cat lump (encode-float32 x)))) 
-	(simple-string 
-	 (setf lump (cat lump (encode-string x)))) 
-	(t 
-	 (error "wrong type. turn back"))))
-    lump))
+    (macrolet ((enc (f)
+                 `(setf lump (cat lump (,f x)))))
+      (dolist (x data) 
+        (typecase x
+          (integer (enc encode-int32)) 
+          (float (enc encode-float32)) 
+          (simple-string (enc encode-string)) 
+          (t (error "wrong type. turn back"))))
+      lump)))
 
 (defun encode-string (string)
   (cat (map 'vector #'char-code string) 
@@ -135,13 +134,15 @@
 
 (defun decode-message (message)
   "reduces an osc message to an (address . data) pair. .."
-  (declare (omptimize debug 3)) 
   (let ((x (position (char-code #\,) message)))
-    (cons (decode-address (subseq message 0 x))
-	  (decode-taged-data (subseq message x)))))
+    (if (eq x NIL)
+        (format "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 address) 'string))
+  (coerce (map 'vector #'code-char (delete 0 address))
+   'string))
  
 (defun decode-taged-data (data)
   "decodes data encoded with typetags...
@@ -187,17 +188,24 @@
 	collect (subseq string i j)
 	while j))
 
+
+;;;;; ; ; ;;    ;; ; ;
+;;
 ;; dataformat en- de- cetera.
+;;
+;;; ;; ;   ;  ;
  
 (defun encode-float32 (f)
-  "encode an ieee754 float as a 4 byte vector. currently sbcl specifc"
+  "encode an ieee754 float as a 4 byte vector. currently sbcl/cmucl specifc"
   #+sbcl (encode-int32 (sb-kernel:single-float-bits f))
-  #-sbcl (error "cant encode floats using this implementation"))
+  #+cmucl (encode-int32 (kernel:single-float-bits f))
+  #-(or sbcl cmucl) (error "cant encode floats using this implementation"))
 
 (defun decode-float32 (s)
   "ieee754 float from a vector of 4 bytes in network byte order"
   #+sbcl (sb-kernel:make-single-float (decode-int32 s))
-  #-sbcl (error "cant decode floats using this implementation"))
+  #+cmucl (kernel:make-single-float (decode-int32 s))
+  #-(or sbcl cmucl) (error "cant decode floats using this implementation"))
 
 (defun decode-int32 (s)
   "4 byte > 32 bit int > two's compliment (in network byte order)"
@@ -260,4 +268,4 @@
   "make a sequence of the required number of #\Nul characters"
   (make-array n :initial-element 0 :fill-pointer n))
 
-;; end
+;; end