darcs-hash:20050302172356-2648a-b99e953e8920e6a6a0c5155c050ea04a46719c11.gz
This commit is contained in:
nik gaffney 2005-03-03 01:23:56 +08:00
parent 424b187234
commit 02bf197a6a
3 changed files with 108 additions and 34 deletions

View file

@ -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

65
osc-dispatch.lisp Normal file
View file

@ -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))))))

View file

@ -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