zzkt/osc
1
0
Fork 0
Code Issues 7 Pull requests Projects Releases Activity Actions

integrate new timetag implementation

Browse source 
Ignore-this: 52c88aaef2bbd2921a90d4f423c89c7e

Also update .asd and add a new package definition file.

darcs-hash:20100925133104-16a00-69352e864aefbb59e43ce4e62a32f8ebd5d1810e
This commit is contained in:
j.forth 2010-09-25 14:31:04 +01:00 committed by Jamie Forth
parent c739b3eca0
commit 3ef5a50d7a
4 changed files with 109 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
osc-time.lisp
View file

@ -51,10 +51,12 @@ with microsecond precision, relative to 19700101."
(subsecs->microseconds subsecs)))))
(defun timetag->unix-time (timetag)
(let* ((secs (ash timetag -32))
(subsec-int32 (- timetag (ash secs 32))))
(the double-float (+ (- secs +unix-epoch+)
(int32->subsecs subsec-int32)))))
(if (= timetag 1)
1 ; immediate timetag
(let* ((secs (ash timetag -32))
(subsec-int32 (- timetag (ash secs 32))))
(the double-float (+ (- secs +unix-epoch+)
(int32->subsecs subsec-int32))))))
(defun microseconds->subsecs (usecs)
(declare (type (integer 0 1000000) usecs))

9
osc.asd
View file

@ -1,11 +1,14 @@
;; -*- mode: lisp -*-
(in-package #:asdf)
(in-package #:common-lisp-user)
(defsystem osc
(asdf:defsystem osc
:name "osc"
:author "nik gaffney <nik@fo.am>"
:licence "LLGPL"
:description "The Open Sound Control protocol, aka OSC"
:version "0.5"
:components ((:file "osc")))
:components ((:file "osc" :depends-on ("osc-time"))
(:file "osc-dispatch" :depends-on ("osc"))
(:file "osc-time" :depends-on ("package"))
(:file "package")))

139
osc.lisp
View file

@ -40,14 +40,6 @@
;;; an error
;;;
(defpackage :osc
(:use :cl)
(:documentation "OSC aka the 'open sound control' protocol")
(:export :encode-message
:encode-bundle
:decode-message
:decode-bundle))
(in-package :osc)
;(declaim (optimize (speed 3) (safety 1) (debug 3)))
@ -112,7 +104,7 @@
(t (write-to-vector #\b)))))
(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)))
@ -126,7 +118,7 @@
(t (enc encode-blob))))
lump)))
;;;;;; ; ;; ; ; ; ; ; ; ;
;;
;; decoding OSC messages
@ -218,50 +210,45 @@ not contain stale data."
;;
;; timetags
;;
;; - timetags can be encoded using a value, or the :now and :time keywords. the
;; keywords enable either a tag indicating 'immediate' execution, or
;; a tag containing the current time (which will most likely be in the past
;; of anyt receiver) to be created.
;;
;; - note: not well tested, and probably not accurate enough for syncronisation.
;; see also: CLHS 25.1.4 Time, and the ntp timestamp format. also needs to
;; convert from 2 32bit ints to 64bit fixed point value.
;; - timetags can be encoded using a value, or the :now and :time
;; keywords. the keywords enable either a tag indicating 'immediate'
;; execution, or a tag containing the current time (which will most
;; likely be in the past of any receiver) to be created.
;;
;; - see this c.l.l thread to sync universal-time and internal-time
;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/c207fef63a78d720/adc7442d2e4de5a0?lnk=gst&q=internal-real-time-sync&rnum=1#adc7442d2e4de5a0
;; - In SBCL, using sb-ext:get-time-of-day to get accurate seconds and
;; microseconds from OS.
;;
;;;; ;; ; ;
(defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0))
(defun encode-timetag (utime &optional subseconds)
"encodes an osc timetag from a universal-time and 32bit 'sub-second' part.
for an 'instantaneous' timetag use (encode-timetag :now)
for a timetag with the current time use (encode-timetag :time)"
(defun encode-timetag (timetag)
"From the spec: `Time tags are represented by a 64 bit fixed point
number. The first 32 bits specify the number of seconds since midnight
on January 1, 1900, and the last 32 bits specify fractional parts of a
second to a precision of about 200 picoseconds. This is the
representation used by Internet NTP timestamps'. For an
'instantaneous' timetag use (encode-timetag :now), and for a timetag
with the current time use (encode-timetag :time)."
(cond
;; a 1bit timetag will be interpreted as 'imediately'
((equalp utime :now)
#(0 0 0 0 0 0 0 1))
;; converts seconds since 19000101 to seconds since 19700101
;; note: fractions of a second is accurate, but not syncronised.
((equalp utime :time)
(cat (encode-int32 (- (get-universal-time) +unix-epoch+))
(encode-int32
(round (* internal-time-units-per-second
(second (multiple-value-list
(floor (/ (get-internal-real-time)
internal-time-units-per-second)))))))))
((integerp utime)
(cat (encode-int32 (+ utime +unix-epoch+))
(encode-int32 subseconds)))
(t (error "the time or subsecond given is not an integer"))))
((equalp timetag :now)
;; a 1 bit timetag will be interpreted as 'immediately'
#(0 0 0 0 0 0 0 1))
((equalp timetag :time)
;; encode timetag with current real time
(encode-int64 (get-current-timetag)))
((timetagp timetag)
;; encode osc timetag
(encode-int64 timetag))
(t (error "Argument given is not one of :now, :time, or timetagp."))))
(defun decode-timetag (timetag)
"decomposes a timetag into unix-time and a subsecond,. . ."
(list
(decode-int32 (subseq timetag 0 4))
(decode-int32 (subseq timetag 4 8))))
"Return a 64 bit timetag from a vector of 8 bytes in network byte
order."
(if (equalp timetag #(0 0 0 0 0 0 0 1))
1 ; A timetag of 1 is defined as immediately.
(decode-uint64 timetag)))
;;;;; ; ; ;; ;; ; ;
;;
@ -290,6 +277,20 @@ not contain stale data."
(ldb (byte 16 0) (decode-int32 s)))
#-(or sbcl cmucl openmcl allegro) (error "cant decode floats using this implementation"))
(defun encode-int32 (i)
"convert an integer into a sequence of 4 bytes in network byte order."
(declare (type integer i))
(let ((buf (make-sequence
'(vector (unsigned-byte 8)) 4)))
(macrolet ((set-byte (n)
`(setf (elt buf ,n)
(logand #xff (ash i ,(* 8 (- n 3)))))))
(set-byte 0)
(set-byte 1)
(set-byte 2)
(set-byte 3))
buf))
(defun decode-int32 (s)
"4 byte -> 32 bit int -> two's compliment (in network byte order)"
(let ((i (+ (ash (elt s 0) 24)
@ -308,46 +309,62 @@ not contain stale data."
(elt s 3))))
i))
(defun encode-int32 (i)
"convert an integer into a sequence of 4 bytes in network byte order."
(defun encode-int64 (i)
"convert an integer into a sequence of 8 bytes in network byte order."
(declare (type integer i))
(let ((buf (make-sequence
'(vector (unsigned-byte 8)) 4)))
(let ((buf (make-sequence
'(vector (unsigned-byte 8)) 8)))
(macrolet ((set-byte (n)
`(setf (elt buf ,n)
(logand #xff (ash i ,(* 8 (- n 3)))))))
(logand #xff (ash i ,(* 8 (- n 7)))))))
(set-byte 0)
(set-byte 1)
(set-byte 2)
(set-byte 3))
(set-byte 3)
(set-byte 4)
(set-byte 5)
(set-byte 6)
(set-byte 7))
buf))
;; osc-strings are unsigned bytes, padded to a 4 byte boundary
(defun decode-uint64 (s)
"8 byte -> 64 bit unsigned int"
(let ((i (+ (ash (elt s 0) 56)
(ash (elt s 1) 48)
(ash (elt s 2) 40)
(ash (elt s 3) 32)
(ash (elt s 4) 24)
(ash (elt s 5) 16)
(ash (elt s 6) 8)
(elt s 7))))
i))
(defun decode-string (data)
"converts a binary vector to a string and removes trailing #\nul characters"
(string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string)))
;; osc-strings are unsigned bytes, padded to a 4 byte boundary
(defun encode-string (string)
"encodes a string as a vector of character-codes, padded to 4 byte boundary"
(cat (map 'vector #'char-code string)
(string-padding string)))
(defun decode-string (data)
"converts a binary vector to a string and removes trailing #\nul characters"
(string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string)))
;; blobs are binary data, consisting of a length (int32) and bytes which are
;; osc-padded to a 4 byte boundary.
(defun decode-blob (blob)
"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)))))
(defun decode-blob (blob)
"decode a blob as a vector of unsigned bytes."
(let ((size (decode-int32
(subseq blob 0 4))))
(subseq blob 4 (+ 4 size))))
;; utility functions for osc-string/padding slonking
(defun cat (&rest catatac)

19
package.lisp Normal file
View file

@ -0,0 +1,19 @@
(defpackage :osc
(:use :cl :sb-bsd-sockets)
(:documentation "OSC aka the 'open sound control' protocol")
(:export #:encode-message
#:encode-bundle
#:decode-message
#:decode-bundle
#:make-osc-tree
#:dp-register
#:dp-remove
#:dp-match
#:dispatch
#:get-current-timetag ; osc-time
#:timetag+
#:get-unix-time
#:unix-time->timetag
#:timetag->unix-time
#:print-as-double))