;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; osc.scm - scheme implementation of OSC protocol
; version: 0.1
;
; Copyright (C) 2004 Artem Baguinski <artm@v2.nl>
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Scheme implementation of the OSC protocol [1], using SLIB - portable 
; Scheme library [2], pregexp - portable regular expressions library for
; Scheme and Common Lisp [3]
; 
; [1] http://www.cnmat.berkeley.edu/OpenSoundControl/OSC-spec.html
; [2] http://swissnet.ai.mit.edu/~jaffer/SLIB
; [3] http://www.ccs.neu.edu/home/dorai/pregexp/pregexp.html
;
; TODO:
; - optimize read/writing with substring/shared instead of consing
; - use receive instead of homebrewed macro for multiple values binding
; - separate PLT dependant bits and make the library work in guile
; - modularize
; - example using unix domain sockets (at least in guile)
; - OSC/NTP time - e.g. POSIX-time->NTP-time and back
; - more argument types (at least those listed as additional nonstandard 
;   types in an OSC standard) 
; - test suite against:
;   - liblo
;   - libOMC
;   - pd's implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require (lib "load.ss" "slibinit"))

; SLIB modules
(require 'byte)
(require 'byte-number)
(require 'string-search)

; mz require's (for extra libraries)
(require (lib "pregexp.ss"))

;; client (sending) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; there's no standard way to use networking / ipc in scheme, 
;; but once you've got the packet sending it shouldn't be 
;; that hard.
;;
;; e.g. in PLT scheme:
;;
;; (define /my/method (osc:make-method "/my/method" "ifs"))
;; (define osc-socket (udp-open-socket))
;; (udp-connect! osc-socket "localhost" 7770) ; liblo's example_server
;; (udp-send osc-socket (/my/method 1 2.5 "lala"))
;;
;; To make it easy for myself, I'll wrap guile's POSIX sockets into 
;; PLT-compatible API, and may be later invent similar API for 
;; unix domain sockets.

;; how many zeroes to pad the string with so the length becomes
;; multiple of 4. There must be at least 1 zero.
(define osc:string-0s-count
  (lambda (str-or-len)
    (- 4 (modulo (if (number? str-or-len)
                     str-or-len
                     (string-length str-or-len)) 
                 4))))

;; idem for blob (do not pad if length is multiple of 4)
(define osc:blob-0s-count
  (lambda (str-or-len)
    (let ((mod (modulo 
                (if (number? str-or-len)
                    str-or-len
                    (string-length str-or-len))
                4)))
      (if (= mod 0) 0 (- 4 mod)))))

;; osc:obj->wire converts scheme object to OSC wire representation 
;; according to the type tag
(define osc:obj->wire
  (lambda (type-tag obj)
    (case type-tag
      ; int32 (-4 stands for 32bit, two's complement)
      ((#\i int32) (integer->bytes obj -4))
      ; IEEE float
      ((#\f float) (ieee-float->bytes obj))
      ; zero terminated string (padded with 0es to a multiple of 4 bytes)
      ((#\s string) (string-append 
              obj
              (make-bytes (osc:string-0s-count obj) 0)))
      ; OSC blob
      ((#\b blob) (string-append (integer->bytes (bytes-length obj) 4)
                            obj
                            (make-bytes (osc:blob-0s-count obj))))
      ; OSC/NTP time stamp - a pair of two unsigned integers
      ((#\t timetag) (string-append (integer->bytes (car obj) 4)
                            (integer->bytes (cdr obj) 4)))
      ; int64
      ((#\h int64) (integer->bytes obj -8))
      ; IEEE double
      ((#\d double) (ieee-double->bytes obj)))))

;; osc:make-method returns a function that serializes its arguments to a 
;; byte array representing an OSC package to be sent over a wire.
;; 
;; e.g:
;; (define /osc/test (osc:make-method "/osc/test" "iffs"))
;; (/osc/test 10 2.5 3.14159 "Hell World!!!")
(define osc:make-method
  (lambda (address type-tags)
    (let ((header (string-append 
                   (osc:obj->wire 'string address)
                   (osc:obj->wire 'string 
                                  (string-append 
                                   "," 
                                   type-tags)))))
      ;; "optimization": if no type tags given -> just header's returned and 
      ;; the closure is smaller
      (if (= (string-length type-tags) 0)
          (lambda () header)
          (let ((type-tags-list (string->list type-tags)))
            (lambda args
              (let ((result header))
                (for-each 
                 (lambda (type-tag arg)
                   (set! result (string-append result (osc:obj->wire type-tag arg))))
                 type-tags-list args)
                result)))))))

;; osc:bundle returns a byte array representing an OSC package to carry a bundle.
;; the rest should be a list of osc messages (created with invocations of osc 
;; methods in they turn created with osc:make-method) or other bundles.
;;
;; e.g.:
;; (osc:bundle (cons 10 10) ; <- some fake OSC time stamp - functions pending
;;             (/osc/test 10 2.5 3.5 "test message") ; <- see previous example
;;             (osc:bundle (cons 0 1) ; <- means "immediately" in OSC
;;                         (/player/play) ; <- example of parameterless method
;;                         (/digger/dig "up up right down")))
(define osc:bundle
  (lambda (time-tag . rest)
    ; helper function
    (define append-rest
      (lambda (start rest)
        (if (null? rest)
            start
            (let ((this (car rest)))
              (append-rest 
               (string-append start 
                              (osc:obj->wire 'int32 (bytes-length this))
                              this)
               (cdr rest))))))
    ; actual append
    (append-rest
     (string-append
      (osc:obj->wire 'string "#bundle")
      (osc:obj->wire 'timetag time-tag))
     rest)))

;; server (receiving) 

;; osc:wire->obj reads the object of OSC type type-tag from the 
;; wire position pos. returns two values - the object and new pos.
(define osc:wire->obj
  (lambda (wire pos type-tag)
    (case type-tag
      ; OSC string
      ((#\s string) 
       (let* ((rest (substring wire pos (string-length wire)))
              (length (string-index rest #\000)))
         (values (substring rest 0 length)
                 (+ pos
                    length
                    (osc:string-0s-count length)))))
      ((#\i int32) (values (bytes->integer (substring wire pos (+ pos 4)) -4)
                           (+ pos 4)))
      ((uint32) (values (bytes->integer (substring wire pos (+ pos 4)) 4)
                        (+ pos 4)))
      ((#\f float) (values (bytes->ieee-float (substring wire pos (+ pos 4)))
                           (+ pos 4)))
      ; OSC blob
      ((#\b blob) 
       (let ((length (bytes->integer (substring wire pos (+ pos 4)) 4)))
         (values (substring wire (+ pos 4) (+ pos 4 length))
                 (+ pos 4 length (osc:blob-0s-count length)))))
      ; OSC/NTP timestamp
      ((#\t timetag) (values (cons 
                              (bytes->integer (substring wire pos (+ pos 4)) 4)
                              (bytes->integer (substring wire (+ pos 4) (+ pos 8)) 4))
                             (+ pos 8)))
      ((#\h int64) (values  (bytes->integer (substring wire pos (+ pos 8)) -8)
                           (+ pos 8)))
      ((#\d double) (values (bytes->ieee-double (substring wire pos (+ pos 8)))
                            (+ pos 8))))))

;; help macro - allows binding multiple vars to an expression returning 
;; multiple values. 
(define-syntax multi-let*
  (syntax-rules ()
    ((_ (((x1 x2 ...) v)) e1 e2 ...)
     (call-with-values
      (lambda () v)
      (lambda (x1 x2 ...) e1 e2 ...)))
    ((_ (((x11 x12 ...) v1) ((x21 x22 ...) v2) ...) e1 e2 ...)
     (call-with-values
      (lambda () v1)
      (lambda (x11 x12 ...)
        (multi-let* (((x21 x22 ...) v2) ...)
                    e1 e2 ...))))))

;; osc:immediatelly returns OSC's special "immediatelly" timetag.
(define osc:immediatelly
  (lambda () '(0 . 1)))

;; osc:immediatelly? returns non #f if the timetag is OSC's special
;; "immediatelly" timetag.
(define osc:immediatelly?
  (lambda (timetag) (equal? timetag (osc:immediatelly))))

;; osc:parse-packet parses OSC packet and passes discovered messages 
;; to a schedule procedure which should accept two parameters - message 
;; list and OSC time tag. Messages which arent contained in bundles are
;; scheduled for immediate processing.
(define osc:parse-packet
  (lambda (wire length schedule)
    
    (define parse-message
      (lambda (wire pos end time-tag)
        (multi-let*
         (((address pos) (osc:wire->obj wire pos 'string))
          ((type-tags pos) (osc:wire->obj wire pos 'string))
          ((type-tags-list) (cdr (string->list type-tags))))
         (schedule
          ;; build message list:
          ;; (<ADDRESS> [<TYPE-TAGS> <VAL> ...])
          (append
           (list address (list->string type-tags-list))
           (map 
            (lambda (tag) 
              (multi-let*
               (((val newpos) (osc:wire->obj wire pos tag)))
               (set! pos newpos)
               val))
            type-tags-list))
          ;; pass the time value
          time-tag))))
    
    (define parse-bundle
      (lambda (wire pos end)
        
        (define parse-bundle-load
          (lambda (wire pos time-tag)
            (when (< pos end)
              (multi-let*
               (((length pos) (osc:wire->obj wire pos 'uint32))
                ((end) (+ pos length)))
               (parse-packet wire pos end time-tag)
               (parse-bundle-load wire end time-tag)))))
        
        (multi-let*
         (((token pos) (osc:wire->obj wire pos 'string))
          ; assume token is always #bundle
          ((time-tag pos) (osc:wire->obj wire pos 'timetag)))
         (parse-bundle-load wire pos time-tag))))
    
    (define parse-packet
      (lambda (wire pos end time-tag)
        (if (eq? (string-ref wire pos) #\/)
            (parse-message wire pos end time-tag)
            (parse-bundle wire pos end))))

    (parse-packet wire 0 length (osc:immediatelly))))

;; OSC namespace - higher level server interface
;; OSC namespace is hierarchy of containers and methods. Both are 
;; namespace tree nodes, methods being leafs. In osc.scm containers 
;; are (sub-)namespaces.
;; - Top level namespace is anonymous and is just a list of its children.
;; - Sub-namespace is a list whose car is a name and cdr is a list of 
;;   children. 
;; - Method(leaf) is a cons pair whose car is a name and cdr a 
;;   method handler.

;; So, the follwing methods:
;;
;; /test/me
;; /test/simple
;; /test/string
;; /video/channel/1/brightness
;; /video/channel/1/contrast
;; /video/channel/2/brightness
;; /video/channel/2/contrast
;;
;; form the following namespace:
;;
;; (("test" 
;;   ("me" . handler)
;;   ("simple" . handler)
;;   ("string" . handler))
;;  ("video"
;;   ("channel"
;;    ("1"
;;     ("brightness" . handler)
;;     ("contrast" . handler))
;;    ("2"
;;     ("brightness" . handler)
;;     ("contrast" . handler)))))
;;

;; make-regexp-filter - helper function (will be made private in a
;; modularized version of a library). program is a list of 2 element
;; lists where first element is a regular expression and the second is
;; a substitution string. returns a function applying those
;; substitutions in a list order.
(define make-regexp-filter
  (lambda program
    (let ((compiled (map (lambda (rule)
			   (cons (pregexp (car rule))
				 (cadr rule)))
			 program)))
      (lambda (str)
	(let filter ((compiled compiled)
		     (str str))
	  (if (null? compiled)
	      str
	      (filter (cdr compiled)
		      (pregexp-replace*
		       (caar compiled)
		       str
		       (cdar compiled)))))))))

;; osc:address->list converts OSC address pattern to a list of
;; compiled regular expressions corresponding to OSC globs
(define osc:address->list
  (let ((delim-re (pregexp "/"))
	(glob->regexp
	 (make-regexp-filter
	  ;; scheme reader is a bitch when it comes to perl regular
	  ;; expressions with escaped special characters
	  '("\\\\(\\[|\\])" "\\1")
	  '("\\\\\\{" "(")
	  '("\\\\}" ")")
	  '("," "|")
	  '("\\\\\\?" ".")
	  '("\\\\\\*" ".*")
	  '("^(.*)$" "^\\1$"))))
    (lambda (address)
      (map (lambda (str)
	     (pregexp
	      (glob->regexp
	       (pregexp-quote str))))
	   (cdr
	    (pregexp-split
	     delim-re
	     address))))))

;; procedure: osc:apply-to-matching namespace msg time-tag action-match [action-no-matches]
;;
;; namespace - namespace tree as described above
;; msg - message list (<ADDRESS-PATERN> [<TYPE-TAGS> <VAL> ...])
;; time-tag - OSC time tag (cons NNN nnn)
;; action-match - function accepting 3 parameters - msg time-tag obj, to be called on
;;                all matching methods with obj - method handler
;; action-no-matches - function accepting 2 parameters - msg time-tag, to be called if
;;                     no matching methods found
(define osc:apply-to-matching
  (lambda (namespace msg time-tag action-match . rest)
    (let ((action-no-matches (if (null? rest)
				 #f
				 (car rest))))
      (let walk-forest ((namespace namespace)
			(address-list (osc:address->list (car msg))))
	(let ((current-part (car address-list))
	      (rest-parts (cdr address-list)))
	  (for-each
	   (lambda (branch)
	     (when (pregexp-match current-part (car branch))
		   (let ((branch-cdr (cdr branch)))
		     (cond 
		      ((and
			(null? rest-parts) ; expect leaf
			(procedure? branch-cdr)) ; it is a leaf
		       ;; it's a match
		       (set! action-no-matches #f) ; at least one match found
		       (action-match msg time-tag branch-cdr))
		      ((and
			(not (null? rest-parts)) ; expect branch
			(list? branch-cdr)) ; it is a branch
		       ;; descend
		       (walk-forest branch-cdr rest-parts))))))
	   namespace)))
      (when action-no-matches (action-no-matches msg time-tag)))))

;; test objects
(define /test/me (osc:make-method "/test/me" "ifsbthd"))
(define /test/simple (osc:make-method "/test/simple" "if"))
(define /test/string (osc:make-method "/test/string" "s"))
(define bundle (osc:bundle '(12 . 20) 
                           (/test/simple 10 1.0)
                           (/test/string "Hello")))
(define bundle2 (osc:bundle '(100 . 101)
                            (/test/simple 25 2.67)
                            bundle
                            (/test/me 19 2.3 "hoi" "aha!" '(0 . 100) 100 2.6)))

(define test-handler (lambda rest #f))
(define test-namespace
  `(("test"
     ("me" . ,test-handler)
     ("simple" . ,test-handler)
     ("string" . ,test-handler)
     ("sub"
      ("player"
       ("1"
	("speed" . ,test-handler)
	("pan" . ,test-handler)
	("play" . ,test-handler)
	("stop" . ,test-handler))
       ("2"
	("speed" . ,test-handler)
	("pan" . ,test-handler)
	("play" . ,test-handler)
	("stop" . ,test-handler))
       ("3"
	("speed" . ,test-handler)
	("pan" . ,test-handler)
	("play" . ,test-handler)
	("stop" . ,test-handler)))))
    ;; to respond to example_client from liblo
    ("foo"
     ("bar" . ,test-handler))
    ("a"
     ("b"
      ("c"
       ("d" . ,test-handler))))
    ("jamin"
     ("scene" . ,test-handler)) ))

(define test-schedule
  (lambda (msg timetag) 
    (osc:apply-to-matching
     test-namespace msg timetag
     (lambda (msg timetag handler)
       (printf "found matching method for ~s~%" msg))
     (lambda (msg timetag)
       (printf "no matching methods for ~s~%" msg)))))
			   

; (let* ((msg (/test/me 10 1.0 "string" "blob" '(10 . 10) 100 10.0))
;        (len (string-length msg)))
;   (osc:parse-packet msg len test-schedule))

; (printf "~%bundle~%")
; (osc:parse-packet bundle (string-length bundle) test-schedule)
; (printf "~%bundle2~%")
; (osc:parse-packet bundle2 (string-length bundle2) test-schedule)


;; test-server is PLT-Scheme specific 
;; TODO: test if in PLT
(define test-server
  (lambda (port)
    (define socket (udp-open-socket))
    (udp-bind! socket #f 7770)
    (dynamic-wind ; to ensure the socket is closed if anything goes wrong
	void
	(lambda ()
	  (let receive ((osc-packet (make-string 4096)))
	    (call-with-values
		(lambda () (udp-receive!/enable-break socket osc-packet))
	      (lambda (length hostname remote-port)
		(osc:parse-packet osc-packet length test-schedule)
		(receive osc-packet)))))
        (lambda () (udp-close socket)))))