define writer "monad" + bunch of other stuff

Author: smoothdeveloper

demo/scratch.fsx

@@ -9,7 +9,7 @@
 open System.IO
 open ZMidi.Internal.ParserMonad
 open ZMidi
-//ZMidi.Internal.ParserMonad.debug <- true
+ZMidi.Internal.ParserMonad.debug <- true
 (*
 
 

demo/writer.fsx

@@ -0,0 +1,68 @@
+#r "../build/Debug/AnyCPU/net462/zmidi-fs-core.dll"
+open ZMidi.Internal
+open System.IO
+open ZMidi
+open ZMidi.WriteFile
+open ZMidi.DataTypes
+open ZMidi.Internal.Utils
+open ZMidi.Internal.WriterMonad
+open ZMidi.Internal.DataTypes
+let rec putter op =
+    
+    match op with
+    | PutByte b -> System.Console.WriteLine (Text.prettyBits b)
+    | PutBytes bytes -> bytes |> Array.map Text.prettyBits |> Array.iter System.Console.WriteLine 
+    | NoOp -> ()
+    | Combined(op1,op2) ->
+        putter op1
+        putter op2
+open PutOps
+
+let putVarlen (varlen: word32) = PutBytes (ExtraTypes.encodeVarlen varlen)
+    
+let putDeltaTime (deltaTime: DeltaTime) =
+    putVarlen deltaTime.Value
+
+let putEvent event =
+    match event with
+    | MidiEvent.MetaEvent _        -> PutByte 0xffuy 
+    | MidiEvent.SysExEvent _       -> PutByte 0xf7uy 
+    | MidiEvent.VoiceEvent(_, e)   -> PutByte e.Status 
+    | MidiEvent.MidiEventOther b   -> PutByte b 
+    | MidiEvent.SysCommonEvent e   -> PutByte e.Status
+    | MidiEvent.SysRealtimeEvent e -> PutByte e.Status
+    
+let putMessage (message: MidiMessage) =
+    seq {
+        yield putDeltaTime message.timestamp
+        yield putEvent message.event
+    }
+let writeHeader header =
+    writeBytes putter {
+        do! putAscii "MThd";
+        do! putWord32be 6u
+        do! putFormat header.format
+        do! putWord16be header.trackCount
+        do! putTimeDivision header.timeDivision
+    }
+let writeTrack track =
+    writeBytes putter {
+        do! putAscii "MTrk"
+        do! putWord32be (uint32 (Array.length track))
+        for m in track do
+            do! putMessage m
+    }
+    
+let folder = 
+  Path.Combine(__SOURCE_DIRECTORY__ , ".." , "data", "midifiles")
+  |> DirectoryInfo
+
+for file in folder.EnumerateFiles() do
+  let buffer = File.ReadAllBytes file.FullName
+  match ParserMonad.runParser ReadFile.midiFile buffer ZMidi.Internal.ParserMonad.State.initial with
+  | Ok midiFile ->
+      try
+        writeTrack midiFile.tracks.[0]
+      with e ->
+          printfn "%A" e
+  | Error e -> printfn "%A" e

paket.dependencies

@@ -1,4 +1,6 @@
 source https://www.nuget.org/api/v2
-
+framework: netcore3, net472
+generate_load_scripts: on
+nuget FSharpPlus
 nuget System.Memory
 nuget Expecto.FsCheck

paket.lock

@@ -7,6 +7,9 @@ type word24 = uint32
 type word32 = uint32
 type bits7 = byte
 type midichannel = byte
+type midinote = byte
+type midivelocity = byte
+
 type [<Struct>] DeltaTime(value: word32) =
     member x.Value = value
     override x.ToString() = sprintf "DeltaTime:%i" value
@@ -57,7 +60,6 @@ type MidiEvent =
     | SysCommonEvent of MidiSysCommonEvent
     | SysRealtimeEvent of MidiSysRealtimeEvent
     | MetaEvent of MidiMetaEvent
-
 and MidiVoiceEvent =
     /// Note off.
     /// 
@@ -113,7 +115,16 @@ and MidiVoiceEvent =
     /// NOTE - as of v0.9.0 the value is interpreted.
     /// This is a Word14 value, the range is (0..16383).
     | PitchBend of status: bits7 * bend: word14
-
+    member x.Status =
+        match x with
+        | PitchBend(status,_)
+        | ChannelAftertouch(status,_)
+        | Controller(status,_,_)
+        | NoteAfterTouch(status,_,_)
+        | NoteOff(status,_,_)
+        | NoteOn(status,_,_)
+        | ProgramChange(status,_)
+         -> status
 
 and MidiTextType =
     | GenericText
@@ -320,7 +331,16 @@ and MidiSysCommonEvent =
     /// > F7
     /// 
     | EOX
-
+    member x.Status =
+        match x with
+        | QuarterFrame _   -> 0xf1uy
+        | SongPosPointer _ -> 0xf2uy
+        | SongSelect _     -> 0xf3uy
+        | UndefinedF4      -> 0xf4uy
+        | UndefinedF5      -> 0xf5uy
+        | TuneRequest      -> 0xf6uy
+        | EOX              -> 0xf7uy
+        
 /// System real-time event.
 ///
 /// These events may not be pertinent to MIDI files generated on a 
@@ -383,7 +403,15 @@ and MidiSysRealtimeEvent =
     /// > FF
     ///
     | SystemReset
-
-
+    member x.Status =
+        match x with
+        | TimingClock      -> 0xf8uy
+        | UndefinedF9      -> 0xf9uy
+        | StartSequence    -> 0xfauy
+        | ContinueSequence -> 0xfbuy
+        | StopSequence     -> 0xfcuy
+        | UndefinedFD      -> 0xfduy
+        | ActiveSensing    -> 0xfeuy
+        | SystemReset      -> 0xffuy 
 
 and [<RequireQualifiedAccess>] MidiScaleType = Major | Minor | OtherScale of word8

src/ZMidi/DataTypes.fs

@@ -1,4 +1,5 @@
 module ZMidi.Internal.ExtraTypes
+open ZMidi.DataTypes
 
 
 
@@ -26,4 +27,30 @@ let fromVarlen =
   function | V1 a            -> uint32 (up a)
            | V2 (a, b)       -> (left7  (uint32 (up a))) + (uint32 (up b))
            | V3 (a, b, c)    -> (left14 (uint32 (up a))) + (left7  (uint32 (up b))) + uint32 (up c)
-           | V4 (a, b, c, d) -> (left21 (uint32 (up a))) + (left14 (uint32 (up b))) + (left7 (uint32 (up c))) + uint32 (up d)
+           | V4 (a, b, c, d) -> (left21 (uint32 (up a))) + (left14 (uint32 (up b))) + (left7 (uint32 (up c))) + uint32 (up d)
+let inline encodeVarlen (myValue) =
+    let inline initMask nBits =
+        [|0 .. nBits - 1|]
+        |> Array.map (fun shift -> LanguagePrimitives.GenericOne <<< shift)
+        |> Array.fold ((|||)) LanguagePrimitives.GenericZero
+    let nBits = 7
+    let maxBits =
+        let nMaxBytes = System.Runtime.InteropServices.Marshal.SizeOf(myValue.GetType())
+        nMaxBytes * nBits
+    let maxValue = initMask maxBits
+    if maxValue < myValue then
+        failwithf "can't encode %i: to high, max being %i" myValue maxValue
+    let shiftAnd7Bits =
+        [|0 .. nBits .. maxBits - 1|]
+        |> Array.map (fun shift ->
+            let mask = initMask nBits <<< shift
+            let value =byte ((myValue &&& mask) >>> shift)
+            value
+            )
+        
+    shiftAnd7Bits
+    |> Array.rev
+    |> Array.skipWhile ((=) LanguagePrimitives.GenericZero)
+    |> function | [||] -> [|LanguagePrimitives.GenericZero|]
+                | bytes -> bytes 
+

src/ZMidi/ExtraTypes.fs

@@ -90,11 +90,12 @@ module ParserMonad =
 
     let nullOut = new StreamWriter(Stream.Null) :> TextWriter
     let mutable debug = false
-    let logf format = //format: Printf.TextWriterFormat<'a>) =
+    let logf format =
           if debug then
             printfn format
           else
             fprintfn nullOut format
+            //Unchecked.defaultof<_>
 
     let inline private apply1 (parser : ParserMonad<'a>) 
                        (midiData : byte[])
@@ -388,7 +389,7 @@ module ParserMonad =
             return (System.String arr)
         }
         <??> sprintf "readString failed at %i"
-
+    open ZMidi.Internal.DataTypes.FromBytes
     /// Parse a uint16 (big endian).
     let readUInt16be : ParserMonad<uint16>= 
         parseMidi { 

src/ZMidi/Internal/ParserMonad.fs

@@ -1,29 +1,98 @@
 namespace ZMidi.Internal
+open ZMidi.DataTypes
 
+module Evil =
+    let inline uncurry4 f = fun (a,b,c,d) -> f a b c d
+module DataTypes =
+    module FromBytes =
+
+        /// Builds a Word16 (big endian).
+        let word16be (a : byte) (b : byte) : uint16 = 
+            let a = uint16 a
+            let b = uint16 b
+            (a <<< 8) + b
+
+        /// Builds a Word14 (big endian).
+        let word14be (a: byte) (b: byte) : word14 = 
+            let a = uint16 a
+            let b = uint16 b
+            word14((a <<< 7) + b)
+
+        let word24be (a: byte) (b: byte) (c: byte) : word24 =
+            ((uint32 a) <<< 16)
+            + ((uint32 b) <<< 8)
+            + (uint32 c)
+
+        let word32be (a: byte) (b: byte) (c: byte) (d: byte) : word32 =
+              ((uint32 a) <<< 24)
+            + ((uint32 b) <<< 16)
+            + ((uint32 c) <<< 08)
+            + ((uint32 d) <<< 00)
+    module ToBytes =
+        let word32be (v: word32) =
+              (v &&& 0x000000ffu) >>> 00 |> byte
+            , (v &&& 0x0000ff00u) >>> 08 |> byte
+            , (v &&& 0x00ff0000u) >>> 16 |> byte
+            , (v &&& 0xff000000u) >>> 24 |> byte
+    module Isomorphisms =
+        type Iso<'a,'b> = ('a -> 'b) * ('b -> 'a)
+        module Iso =
+            let reverse iso = snd iso, fst iso
+            
+        let word32be : Iso<_,_> = (ToBytes.word32be), (Evil.uncurry4 FromBytes.word32be)
+        
 module Utils = 
-    open ZMidi.DataTypes
     open System.IO
-    
-    /// Builds a Word16 (big endian).
-    let word16be (a : byte) (b : byte) : uint16 = 
-        let a = uint16 a
-        let b = uint16 b
-        (a <<< 8) + b
-
-    /// Builds a Word14 (big endian).
-    let word14be (a: byte) (b: byte) : word14 = 
-        let a = uint16 a
-        let b = uint16 b
-        word14((a <<< 7) + b)
-
-    let word24be (a: byte) (b: byte) (c: byte) : word24 =
-        ((uint32 a) <<< 16)
-        + ((uint32 b) <<< 8)
-        + (uint32 c)
-
-    let word32be (a: byte) (b: byte) (c: byte) (d: byte) : uint32 =
-        ((uint32 a) <<< 24)
-        + ((uint32 b) <<< 16)
-        + ((uint32 c) <<< 8)
-        + (uint32 d)
-        
+
+    let inline (|TestBit|_|) (bit: int) (i: ^T) =
+      let mask = LanguagePrimitives.GenericOne <<< bit
+      if mask &&& i = mask then Some () else None
+
+    let inline clearBit (bit: int) (i: ^T) =
+      let mask = ~~~ (LanguagePrimitives.GenericOne <<< bit)
+      i &&& mask
+      
+    let inline setBit (bit: int) (i: ^T) =
+      let mask = (LanguagePrimitives.GenericOne <<< bit)
+      i ||| mask
+    let inline msbHigh i =
+      match i with
+      | TestBit 7 -> true
+      | _ -> false
+
+
+    module Text =
+        let prettyBytes (bytes : byte array) =
+          bytes 
+          |> Array.chunkBySize 32
+          |> Array.map (
+            fun bytesChunk ->
+              let bits =
+                bytesChunk 
+                |> Array.chunkBySize 16
+                |> Array.map (fun items ->
+                  items
+                  |> Array.map (sprintf "%02x")
+                  |> String.concat " "
+                )
+                |> String.concat "  -  "
+                
+              bits
+          )
+
+          |> String.concat System.Environment.NewLine
+        let inline prettyBits number =
+            let maxSize = 8 * System.Runtime.InteropServices.Marshal.SizeOf (number.GetType())
+            [|0 .. (maxSize - 1)|]
+            |> Array.rev
+            |> Array.map (fun shift ->
+                let mask = LanguagePrimitives.GenericOne <<< shift
+                if (number &&& mask <> LanguagePrimitives.GenericZero) then "■" else " "
+                )
+            |> String.concat ""
+            |> sprintf "[%s]"
+
+    module PreventPrintF =
+        open System
+        let [<Obsolete("please do not use printfn in this file", true)>] printfn () = () 
+        let [<Obsolete("please do not use printf in this file", true)>] printf () = ()