diff --git a/README.txt b/README.txt index e48413e..28df0a8 100644 --- a/README.txt +++ b/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 diff --git a/osc-dispatch.lisp b/osc-dispatch.lisp new file mode 100644 index 0000000..6754a3c --- /dev/null +++ b/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 + +;; 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)))))) diff --git a/osc.lisp b/osc.lisp index 8e63f33..8939558 100644 --- a/osc.lisp +++ b/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 \ No newline at end of file +;; end