(*     smf2txt.sml                            *)
(*     Copyright (C) 2000 Daikoku Manabu      *)
(*     Friday, 3 March 2000                   *)

exception FileName

fun smfToText (infilename,outfilename) =
    let
        open TextIO Vector Int

        (* open files *)

        val _ = if infilename=outfilename then raise FileName
                else ()
        val instr = BinIO.openIn infilename
        val outstr = openOut outfilename

        (* hexadecimal utilities *)

        fun left w = Word8.>> (w,0wx4)

        fun right w = Word8.andb (w,0wxf)

        fun isFlagTrue w = Word8.andb (w,0wx80) = 0wx80

        fun delFlag w = Word8.andb (w,0wx7f)

        fun wtoi w = Word8.toInt w

        fun wtois w = toString (wtoi w)

        fun wtos w = str (chr (wtoi w))

        fun wtoh w =
            let
                open String
                val hexdigit = "0123456789ABCDEF"
            in
                  extract (hexdigit,wtoi (left w),SOME 1)
                ^ extract (hexdigit,wtoi (right w),SOME 1)
                ^ "H"
            end

        fun wvtos wv =
            let
                val len = length wv
                val s = ref ""
                val i = ref 0
            in
                while (!i<len) do (
                    s := !s ^ wtos (sub (wv,!i));
                    i := !i + 1
                );
                !s
            end

        fun wvtoi wv =
            let
                val len = length wv
                val n = ref 0
                val i = ref 0
            in
                while (!i<len) do (
                    n := !n * 256;
                    n := !n + Word8.toInt (sub (wv,!i));
                    i := !i + 1
                );
                !n
            end

        fun wvtois wv = toString (wvtoi wv)

        (* integer utilities *)

        fun power n m =
            if m<=0 then 1
            else n * (power n (m-1))

        (* reading and output *)

        exception EOF

        fun readW () = valOf (BinIO.input1 instr) handle
            Option => raise EOF

        fun readN n =
            let
                val v = ref #[]
                val i = ref 0
            in
                while (!i<n) do (
                    v := concat [!v,#[readW ()]];
                    i := !i + 1
                );
                !v
            end

        val remain = ref 0

        fun readDown () =
            let
                val w = readW ()
            in
                remain := !remain - 1;
                w
            end

        fun outputS s = output (outstr,s)

        fun outputL [] = ()
          | outputL (x::xs) = (
                output (outstr,x);
                outputL xs
            )

        fun printL [] = ()
          | printL (x::xs) = (
                print x;
                printL xs
            )

        (* global references *)

        val timebase = ref 0
        val numerator = ref 4
        val denominator = ref 4
        val currenttime = ref 0

        (* functions for SMF *)

        exception TrackHeader

        fun trackHeader () =
            let
                val mtrk = wvtos (readN 4)
                val length = readN 4
            in
                if mtrk<>"MTrk" then
                    raise TrackHeader
                else (
                    outputL [mtrk,"\n",
                        "length=",wvtois length,"\n",
                        "[measure:beat:tick]\n"];
                    wvtoi length
                )
            end

        fun longValue () =
            let
                val v = ref #[]
                val w = ref 0wx0
                val continue = ref true
            in
                while !continue do (
                    w := readDown ();
                    v := concat [!v,#[delFlag (!w)]];
                    if not (isFlagTrue (!w)) then
                        continue := false
                    else ()
                );
                wvtoi (!v)
            end

        fun hexDump length =
            let
                val count = ref 0
            in
                while !count<length do (
                    outputL [wtoh (readDown ())," "];
                    count := !count + 1
                )
            end

        fun deltaTime delta =
            let
                val currentbeat = ref 0
                val tick = ref 0
                val beat = ref 0
                val measure = ref 0
            in
                currenttime := !currenttime + delta;
                currentbeat := !currenttime div !timebase;
                tick := !currenttime mod !timebase;
                beat := (!currentbeat mod !numerator) + 1;
                measure := (!currentbeat div !numerator) + 1;
                outputL ["[",toString (!measure),
                         ":",toString (!beat),
                         ":",toString (!tick),
                         "] "]
            end

        fun endOfTrack () = (
            outputS "end of track";
            readDown ();
            ()
        )

        fun tempo () =
            let
                val wv = ref #[]
                val t = ref 0
                val count = ref 0
            in
                outputS "tempo ";
                readDown ();
                while !count<3 do (
                    wv := concat [!wv,#[readDown ()]];
                    count := !count + 1
                );
                t := wvtoi (!wv);
                outputL [toString (!t)," microseconds (MM=",
                         toString (60000000 div (!t)),
                         ")"]
            end

        fun smpteOffset () =
            let
                val w = ref 0wx0
                val count = ref 0
            in
                outputS "SMPTE offset ";
                readDown ();
                while !count<5 do (
                    w := readDown ();
                    outputL [wtois (!w)," "];
                    count := !count + 1
                )
            end

        fun timeSignature () = (
            outputS "time signature ";
            readDown ();
            numerator := wtoi (readDown ());
            denominator := power 2 (wtoi (readDown ()));
            outputL [toString (!numerator),"/"];
            outputL [toString (!denominator)," "];
            outputL ["cc=",wtois (readDown ())," "];
            outputL ["bb=",wtois (readDown ())]
        )

        fun keySignature () =
            let
                val sf = ref 0wx0
            in
                outputS "key signature ";
                readDown ();
                sf := readDown ();
                if isFlagTrue (!sf) then
                    outputL ["flat=",wtois (delFlag (!sf))]
                else
                    outputL ["sharp=",wtois (!sf)];
                if readDown () = 0wx0 then
                    outputS " major"
                else
                    outputS " minor"
            end

        fun sequencerSpecific () = (
            outputS "sequencer specific ";
            hexDump (longValue ())
        )

        fun unknownMetaEvent () = (
            outputS "unknown meta event ";
            hexDump (longValue ())
        )

        fun isTextEvent w =
                       w=0wx0
                orelse Word8.andb (w,0wxf8) = 0wx0

        fun textEvent eventtype =
            let
                val length = longValue ()
                val i = ref 0
            in
                case eventtype of
                    0wx1 => outputS "text "
                  | 0wx2 => outputS "copyright "
                  | 0wx3 => outputS "sequence/track name "
                  | 0wx4 => outputS "instrument name "
                  | 0wx5 => outputS "lyric "
                  | 0wx6 => outputS "marker "
                  | 0wx7 => outputS "cue point "
                  | _    => outputL [wtoh eventtype," "];
                outputS "\"";
                while !i<length do (
                    outputS (wtos (readDown ()));
                    i := !i + 1
                );
                outputS "\""
            end

        fun isStatusOnly w = Word8.>=(w,0wxf6)

        fun outputStatus status =
            let
                val ls = left status
                val rs = right status
            in
                if Word8.<=(ls,0wxe) then (
                    outputL ["Ch ",
                             toString ((wtoi rs)+1)," "];
                    case ls of
                        0wx8 => outputS "noteoff "
                      | 0wx9 => outputS "noteon "
                      | 0wxa =>
                            outputS "polyphonic key pressure "
                      | 0wxb => outputS "control change "
                      | 0wxc => outputS "program change "
                      | 0wxd =>
                            outputS "channel key pressure "
                      | 0wxe => outputS "pitch bend change "
                      | _    => outputL [wtoh status," "]
                ) else
                    outputL [wtoh status," "]
            end

        fun isLengthTwo status =
            let
                val ls = left status
            in
                       Word8.<=(ls,0wxb)
                orelse ls=0wxe
                orelse status=0wxf2
            end

        fun midiEventData (status,dataone) =
            let
                val ls = left status
                val rs = right status
            in
                outputStatus status;
                if isLengthTwo status then
                    outputL [wtois dataone, " ",
                        wtois (readDown ())," "]
                else
                    outputL [wtois dataone, " "]
            end

        fun sysEx status =
            let
                val length = longValue ()
                val i = ref 0
            in
                outputL ["SysEx(",wtoh status,") "];
                while !i<length do (
                    outputL [wtoh (readDown ())," "];
                    i := !i + 1
                )
            end

        fun metaEvent () =
            let
                val eventtype = readDown ()
            in
                outputS "Meta ";
                if isTextEvent eventtype then
                    textEvent eventtype
                else
                    case eventtype of
                        0wx2f => endOfTrack ()
                      | 0wx51 => tempo ()
                      | 0wx54 => smpteOffset ()
                      | 0wx58 => timeSignature ()
                      | 0wx59 => keySignature ()
                      | 0wx7f => sequencerSpecific ()
                      | _     => unknownMetaEvent ()
            end

        val running = ref 0wx0

        fun midiEvent w =
            if isFlagTrue w then (
                running := w;
                if isStatusOnly w then ()
                else midiEventData (w,readDown ())
            ) else (
                if isStatusOnly (!running) then ()
                else midiEventData (!running,w)
            )

        fun event () =
            let
                val w = ref 0wx0
            in
                deltaTime (longValue ());
                w := readDown ();
                case !w of
                    0wxf0 => sysEx (!w)
                  | 0wxf7 => sysEx (!w)
                  | 0wxff => metaEvent ()
                  | _     => midiEvent (!w);
                outputS "\n"
            end

        fun track () =
            while !remain>0 do
                    event ()

        fun trackToText () = (
            currenttime := 0;
            remain := trackHeader ();
            track ()
        )

        fun nTracksToText ntracks =
            let
                val i = ref 0
            in
                while !i<ntracks do (
                    outputL ["\ntrack ",toString (!i),"\n"];
                    trackToText ();
                    i := !i + 1
                )
            end

        exception Timebase

        fun setTimebase () =
            let
                val v1 = readW ()
                val v2 = readW ()
                val v1a = delFlag v1
            in
                if isFlagTrue v1 then
                    raise Timebase
                else (
                    timebase := wvtoi #[v1a,v2];
                    if !timebase=0 then
                        timebase := 48 (* supposed *)
                    else ();
                    outputL ["timebase=",
                        toString (!timebase),"\n"]
                )
            end

        exception SMFHeader

        fun header () =
            let
                val mthd = wvtos (readN 4)
                val _ = readN 4
                val format = readN 2
                val ntracks = readN 2
            in
                if mthd<>"MThd" then
                    raise SMFHeader
                else (
                    outputL [mthd,"\n",
                        "format=",wvtois format,"\n",
                        "ntracks=",wvtois ntracks,"\n"];
                    setTimebase ();
                    (wvtoi format,wvtoi ntracks)
                )
            end

        fun smfToText2 () =
            let
                val (format,ntracks) = header ()
            in
                case format of
                    0 => nTracksToText 1
                  | 1 => nTracksToText ntracks
                  | _ => printL ["Format",toString format,
                             " is not supported.\n"]
            end

        fun smfToText1 () =
            smfToText2 () handle
                SMFHeader =>
                    print "Illegal SMF header.\n"
              | Timebase =>
                    print "Absolute time is not supported.\n"
              | EOF =>
                    print "Unexpected EOF.\n"
              | TrackHeader =>
                    print "Illegal track header.\n"

    in
        smfToText1 ();
        BinIO.closeIn instr;
        closeOut outstr
    end