;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; osc.ss - PLT scheme implementation of OSC protocol
; version: 0.2
;
; 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]
; 
; [1] http://www.cnmat.berkeley.edu/OpenSoundControl/OSC-spec.html
;
; TODO:
; - OSC/NTP time to miliseconds or something like that
; - fix comments
; - more argument types (at least those listed as additional nonstandard 
;   types in an OSC standard) 
; - test suite against:
;   - liblo
;   - libOMC
;   - pd's implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module osc mzscheme
  
  (require (lib "pregexp.ss"))
  (require (lib "13.ss" "srfi"))
  
  (provide
   osc:make-method
   osc:bundle
   osc:parse-packet
   osc:apply-to-matching)
  
  ;; 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 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 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)))))
  
  ;; obj->wire converts scheme object to OSC wire representation 
  ;; according to the type tag
  (define obj->wire
    (lambda (type-tag obj)
      (case type-tag
        ; int32 
        ((#\i int32) (integer->integer-byte-string obj 4 #t #t))
        ; IEEE float
        ((#\f float) (real->floating-point-byte-string obj 4 #t))
        ; zero terminated string (padded with 0es to a multiple of 4 bytes)
        ((#\s string) (string-append 
                       obj
                       (make-string (string-0s-count obj) #\nul)))
        ; OSC blob
        ((#\b blob) (string-append 
                     (integer->integer-byte-string (string-length obj) 4 #f #t)
                     obj
                     (make-string (blob-0s-count obj) #\nul)))
        ; OSC/NTP time stamp - a pair of two unsigned integers
        ((#\t timetag) (string-append (integer->integer-byte-string (car obj) 4 #f #t)
                                      (integer->integer-byte-string (cdr obj) 4 #f #t)))
        ; int64
        ((#\h int64) (integer->integer-byte-string obj 8 #t #t))
        ; IEEE double
        ((#\d double) (real->floating-point-byte-string obj 8 #t)))))
  
  ;; 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 
                     (obj->wire 'string address)
                     (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 (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 
                                (obj->wire 'int32 (string-length this))
                                this)
                 (cdr rest))))))
      ; actual append
      (append-rest
       (string-append
        (obj->wire 'string "#bundle")
        (obj->wire 'timetag time-tag))
       rest)))
  
  ;; server (receiving) 
  
  ;; wire->obj reads the object of OSC type type-tag from the 
  ;; wire position pos. returns two values - the object and new pos.
  (define wire->obj
    (lambda (wire pos type-tag)
      (case type-tag
        ; OSC string
        ((#\s string) 
         (let* ((rest (substring/shared wire pos (string-length wire)))
                (length (string-index rest #\nul)))
           (values (substring/shared rest 0 length)
                   (+ pos
                      length
                      (string-0s-count length)))))
        ((#\i int32) (values (integer-byte-string->integer 
                              (substring/shared wire pos (+ pos 4)) #t #t)
                             (+ pos 4)))
        ((uint32) (values (integer-byte-string->integer 
                           (substring/shared wire pos (+ pos 4)) #f #t)
                          (+ pos 4)))
        ((#\f float) (values (floating-point-byte-string->real 
                              (substring/shared wire pos (+ pos 4)) #t)
                             (+ pos 4)))
        ; OSC blob
        ((#\b blob) 
         (let ((length (integer-byte-string->integer 
                        (substring/shared wire pos (+ pos 4)) #f #t)))
           (values (substring/shared wire (+ pos 4) (+ pos 4 length))
                   (+ pos 4 length (blob-0s-count length)))))
        ; OSC/NTP timestamp
        ((#\t timetag) (values (cons 
                                (integer-byte-string->integer (substring/shared wire pos (+ pos 4)) #f #t)
                                (integer-byte-string->integer (substring/shared wire (+ pos 4) (+ pos 8)) #f #t))
                               (+ pos 8)))
        ((#\h int64) (values  (integer-byte-string->integer (substring/shared wire pos (+ pos 8)) #t #t)
                              (+ pos 8)))
        ((#\d double) (values (floating-point-byte-string->real (substring/shared wire pos (+ pos 8)) #t)
                              (+ pos 8))))))
  
  ;; immediatelly returns OSC's special "immediatelly" timetag.
  (define immediatelly
    (lambda () '(0 . 1)))
  
  ;; immediatelly? returns non #f if the timetag is OSC's special
  ;; "immediatelly" timetag.
  (define immediatelly?
    (lambda (timetag) (equal? timetag (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)
          (let*-values
           (((address pos) (wire->obj wire pos 'string))
            ((type-tags pos) (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) 
                (let*-values
                 (((val newpos) (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)
                (let*-values
                 (((length pos) (wire->obj wire pos 'uint32))
                  ((end) (+ pos length)))
                 (parse-packet wire pos end time-tag)
                 (parse-bundle-load wire end time-tag)))))
          
          (let*-values
           (((token pos) (wire->obj wire pos 'string))
            ; assume token is always #bundle
            ((time-tag pos) (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 (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)))))))))
  
  ;; address->list converts OSC address pattern to a list of
  ;; compiled regular expressions corresponding to OSC globs
  (define 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 (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)))))
  
  
  )