structure osc :> OSC = struct

structure B = Word8Vector
structure L = List

structure H = hml

datatype datum =
         Int of int
       | Float of real
       | Double of real
       | String of string
       | Blob of Word8.word list

datatype osc =
         Message of (string * datum list)
       | Bundle of (real * osc list)

exception OSC_Encode_Error
exception OSC_Decode_Error
exception OSC_Type_Error

fun encode_i8 n = 
    B.fromList [Word8.fromInt n]

fun encode_i16 n =
    let val w = Word16.fromInt n
        val w16_w8 = Word8.fromLargeWord o
                     Word16.toLargeWord
    in B.fromList [ w16_w8 (Word16.>> (w, 0w08))
                  , w16_w8 (Word16.>> (w, 0w00)) ]
    end

fun encode_i32 n =
    let val w = Word32.fromInt n
        val w32_w8 = Word8.fromLargeWord o
                     Word32.toLargeWord
    in B.fromList [ w32_w8 (Word32.>> (w, 0w24))
                  , w32_w8 (Word32.>> (w, 0w16))
                  , w32_w8 (Word32.>> (w, 0w08))
                  , w32_w8 (Word32.>> (w, 0w00)) ]
    end

fun decode_i32 v =
    let val w8_w32 = Word32.fromLargeWord o
                     Word8.toLargeWord
    in Word32.toInt ((Word32.<< (w8_w32 (B.sub (v, 0)), 0w24)) +
                     (Word32.<< (w8_w32 (B.sub (v, 1)), 0w16)) +
                     (Word32.<< (w8_w32 (B.sub (v, 2)), 0w08)) +
                     (Word32.<< (w8_w32 (B.sub (v, 3)), 0w00)))
    end

fun encode_u64 n =
    let val w = Word64.fromLargeInt n
        val w64_w8 = Word8.fromLargeWord o
                     Word64.toLargeWord
    in B.fromList [ w64_w8 (Word64.>> (w, 0w56))
                  , w64_w8 (Word64.>> (w, 0w48))
                  , w64_w8 (Word64.>> (w, 0w40))
                  , w64_w8 (Word64.>> (w, 0w32))
                  , w64_w8 (Word64.>> (w, 0w24))
                  , w64_w8 (Word64.>> (w, 0w16))
                  , w64_w8 (Word64.>> (w, 0w08))
                  , w64_w8 (Word64.>> (w, 0w00)) ]
    end

val encode_f32 =
    PackReal32Big.toBytes o
    Real32.fromLarge IEEEReal.TO_NEAREST o
    Real.toLarge

val decode_f32 =
    Real.fromLarge IEEEReal.TO_NEAREST o
    Real32.toLarge o
    PackReal32Big.fromBytes

val encode_f64 =
    PackReal64Big.toBytes o
    Real64.fromLarge IEEEReal.TO_NEAREST o
    Real.toLarge

val decode_f64 =
    Real.fromLarge IEEEReal.TO_NEAREST o
    Real64.toLarge o
    PackReal64Big.fromBytes

fun ntpr_ntp t =
    Real.toLargeInt IEEEReal.TO_NEAREST (t * Math.pow(2.0, 32.0))

fun utc_ntp t =
    let val secdif = (70.0 * 365.0 + 17.0) * 24.0 * 60.0 * 60.0
    in ntpr_ntp (t + secdif)
    end

fun decode_str v =
    String.implode (L.map (Char.chr o Word8.toInt) (H.b_unpack v))

fun align n = ~n mod 4

fun extend p s = s @ H.replicate (align (length s)) p

val char_w8 = Word8.fromInt o Char.ord

fun encode_str s = B.fromList (L.map char_w8 (String.explode s))

fun str_cstr s = (L.map char_w8 (String.explode s)) @ [0wx0]

fun encode_string s =
    B.fromList (extend 0wx0 (str_cstr s))

fun encode_blob b =
    B.concat [ encode_i32 (length b)
             , B.fromList (extend 0wx0 b) ]

fun encode_datum (Int n) = encode_i32 n
  | encode_datum (Float n) = encode_f32 n
  | encode_datum (Double n) = encode_f64 n
  | encode_datum (String s) = encode_string s
  | encode_datum (Blob b) = encode_blob b

fun tag (Int _) = #"i"
  | tag (Float _) = #"f"
  | tag (Double _) = #"d"
  | tag (String _) = #"s"
  | tag (Blob _) = #"b"

fun descriptor l =
    String (String.implode (#"," :: L.map tag l))

fun encode_message c ds =
    B.concat [ encode_datum (String c)
             , encode_datum (descriptor ds)
             , B.concat (L.map encode_datum ds) ]

fun encode_bundle t ms =
    let fun f (Message (c, ds)) = 
            encode_datum (Blob (H.b_unpack (encode_message c ds)))
    in B.concat [ encode_datum (String "#bundle")
                , encode_u64 (utc_ntp t)
                , B.concat (L.map f ms) ]
    end

fun encode_osc (Message (c, l)) = encode_message c l
  | encode_osc (Bundle (t, l)) = encode_bundle t l

fun string_size v =
    let val r = B.findi (fn (i,x) => x = (Word8.fromInt 0)) v
    in H.fst (getOpt (r, (0,0wx0)))
    end

fun size #"i" _ = 4
  | size #"f" _ = 4
  | size #"d" _ = 8
  | size #"s" v = string_size v
  | size #"b" v = decode_i32 (H.b_take 4 v)
  | size c _ = raise OSC_Type_Error

fun storage #"s" v = let val n = size #"s" v + 1 in n + align n end
  | storage #"b" v = let val n = size #"b" v in n + align n + 4 end
  | storage c _ = size c (B.fromList [])

fun decode_datum #"i" v = Int (decode_i32 v)
  | decode_datum #"f" v = Float (decode_f32 v)
  | decode_datum #"d" v = Double (decode_f64 v)
  | decode_datum #"s" v = let val n = size #"s" v
                          in String (decode_str (H.b_take n v))
                          end
  | decode_datum #"b" v = let val n = size #"b" v
                          in Blob (H.b_unpack (H.b_take n (H.b_drop 4 v)))
                          end
  | decode_datum _ _ = raise OSC_Decode_Error

fun decode_data cs b =
    let fun swap (x, y) = (y, x)
        fun f b1 c = swap (H.b_split_at (storage c b1) b1)
    in H.zip_with decode_datum cs (H.snd (H.map_accum_l f b cs))
    end

fun decode_osc v =
    let val n = storage #"s" v
        val (String cmd) = decode_datum #"s" v
        val m = storage #"s" (H.b_drop n v)
        val (String dsc) = decode_datum #"s" (H.b_drop n v)
        val tags = String.explode (String.extract (dsc, 1, NONE))
        val arg = decode_data tags (H.b_drop (n + m) v)
    in Message (cmd, arg)
    end

fun show_datum (Int x) = "Int " ^ Int.toString x
  | show_datum (Float x) = "Float " ^ Real.toString x
  | show_datum (Double x) = "Double " ^ Real.toString x
  | show_datum (String x) = "String \"" ^ x ^ "\""
  | show_datum (Blob _) = "Blob"

fun show_osc (Message (c, xs)) =
    let val ss = H.intersperse ", " (L.map show_datum xs)
    in "(Message " ^ c ^ " [" ^ String.concat ss ^ "])"
    end
  | show_osc (Bundle (t, xs)) =
    let val ss = H.intersperse "; " (L.map show_osc xs)
    in "(Bundle " ^ Real.toString t ^ " [" ^ String.concat ss ^ "])"
    end

datatype transport = UDP of INetSock.dgram_sock

fun open_udp host port =
    let val s = INetSock.UDP.socket ()
        val h = Option.valOf (NetHostDB.fromString host)
    in Socket.connect (s, INetSock.toAddr (h, port));
       UDP s
    end

fun send (UDP fd) msg =
    let val x = Word8VectorSlice.full (encode_osc msg)
    in Socket.sendVec (fd, x)
    end

fun recv (UDP fd) =
    let val x = Socket.recvVec (fd, 8192)
    in decode_osc x
    end

fun close (UDP fd) =
    Socket.close fd

fun wait fd c = 
    let val m = recv fd
        val (Message (p, q)) = m 
    in if c = p then m else wait fd c
    end

end