Skip to content

Commit 631247f

Browse files
smoothdevelopersmoothdeveloper
committed
define writer "monad" + bunch of other stuff
1 parent 6459866 commit 631247f

File tree

13 files changed

+529
-302
lines changed

13 files changed

+529
-302
lines changed

‎demo/scratch.fsx‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@
99
open System.IO
1010
open ZMidi.Internal.ParserMonad
1111
open ZMidi
12-
//ZMidi.Internal.ParserMonad.debug <- true
12+
ZMidi.Internal.ParserMonad.debug <- true
1313
(*
1414
1515

‎demo/writer.fsx‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
#r "../build/Debug/AnyCPU/net462/zmidi-fs-core.dll"
2+
open ZMidi.Internal
3+
open System.IO
4+
open ZMidi
5+
open ZMidi.WriteFile
6+
open ZMidi.DataTypes
7+
open ZMidi.Internal.Utils
8+
open ZMidi.Internal.WriterMonad
9+
open ZMidi.Internal.DataTypes
10+
let rec putter op =
11+
12+
match op with
13+
| PutByte b -> System.Console.WriteLine (Text.prettyBits b)
14+
| PutBytes bytes -> bytes |> Array.map Text.prettyBits |> Array.iter System.Console.WriteLine
15+
| NoOp -> ()
16+
| Combined(op1,op2) ->
17+
putter op1
18+
putter op2
19+
open PutOps
20+
21+
let putVarlen (varlen: word32) = PutBytes (ExtraTypes.encodeVarlen varlen)
22+
23+
let putDeltaTime (deltaTime: DeltaTime) =
24+
putVarlen deltaTime.Value
25+
26+
let putEvent event =
27+
match event with
28+
| MidiEvent.MetaEvent _ -> PutByte 0xffuy
29+
| MidiEvent.SysExEvent _ -> PutByte 0xf7uy
30+
| MidiEvent.VoiceEvent(_, e) -> PutByte e.Status
31+
| MidiEvent.MidiEventOther b -> PutByte b
32+
| MidiEvent.SysCommonEvent e -> PutByte e.Status
33+
| MidiEvent.SysRealtimeEvent e -> PutByte e.Status
34+
35+
let putMessage (message: MidiMessage) =
36+
seq {
37+
yield putDeltaTime message.timestamp
38+
yield putEvent message.event
39+
}
40+
let writeHeader header =
41+
writeBytes putter {
42+
do! putAscii "MThd";
43+
do! putWord32be 6u
44+
do! putFormat header.format
45+
do! putWord16be header.trackCount
46+
do! putTimeDivision header.timeDivision
47+
}
48+
let writeTrack track =
49+
writeBytes putter {
50+
do! putAscii "MTrk"
51+
do! putWord32be (uint32 (Array.length track))
52+
for m in track do
53+
do! putMessage m
54+
}
55+
56+
let folder =
57+
Path.Combine(__SOURCE_DIRECTORY__ , ".." , "data", "midifiles")
58+
|> DirectoryInfo
59+
60+
for file in folder.EnumerateFiles() do
61+
let buffer = File.ReadAllBytes file.FullName
62+
match ParserMonad.runParser ReadFile.midiFile buffer ZMidi.Internal.ParserMonad.State.initial with
63+
| Ok midiFile ->
64+
try
65+
writeTrack midiFile.tracks.[0]
66+
with e ->
67+
printfn "%A" e
68+
| Error e -> printfn "%A" e

‎paket.dependencies‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
11
source https://www.nuget.org/api/v2
2-
2+
framework: netcore3, net472
3+
generate_load_scripts: on
4+
nuget FSharpPlus
35
nuget System.Memory
46
nuget Expecto.FsCheck

‎paket.lock‎

Lines changed: 198 additions & 207 deletions
Large diffs are not rendered by default.

‎src/ZMidi/DataTypes.fs‎

Lines changed: 33 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,9 @@ type word24 = uint32
77
type word32 = uint32
88
type bits7 = byte
99
type midichannel = byte
10+
type midinote = byte
11+
type midivelocity = byte
12+
1013
type [<Struct>] DeltaTime(value: word32) =
1114
member x.Value = value
1215
override x.ToString() = sprintf "DeltaTime:%i" value
@@ -57,7 +60,6 @@ type MidiEvent =
5760
| SysCommonEvent of MidiSysCommonEvent
5861
| SysRealtimeEvent of MidiSysRealtimeEvent
5962
| MetaEvent of MidiMetaEvent
60-
6163
and MidiVoiceEvent =
6264
/// Note off.
6365
///
@@ -113,7 +115,16 @@ and MidiVoiceEvent =
113115
/// NOTE - as of v0.9.0 the value is interpreted.
114116
/// This is a Word14 value, the range is (0..16383).
115117
| PitchBend of status: bits7 * bend: word14
116-
118+
member x.Status =
119+
match x with
120+
| PitchBend(status,_)
121+
| ChannelAftertouch(status,_)
122+
| Controller(status,_,_)
123+
| NoteAfterTouch(status,_,_)
124+
| NoteOff(status,_,_)
125+
| NoteOn(status,_,_)
126+
| ProgramChange(status,_)
127+
-> status
117128

118129
and MidiTextType =
119130
| GenericText
@@ -320,7 +331,16 @@ and MidiSysCommonEvent =
320331
/// > F7
321332
///
322333
| EOX
323-
334+
member x.Status =
335+
match x with
336+
| QuarterFrame _ -> 0xf1uy
337+
| SongPosPointer _ -> 0xf2uy
338+
| SongSelect _ -> 0xf3uy
339+
| UndefinedF4 -> 0xf4uy
340+
| UndefinedF5 -> 0xf5uy
341+
| TuneRequest -> 0xf6uy
342+
| EOX -> 0xf7uy
343+
324344
/// System real-time event.
325345
///
326346
/// These events may not be pertinent to MIDI files generated on a
@@ -383,7 +403,15 @@ and MidiSysRealtimeEvent =
383403
/// > FF
384404
///
385405
| SystemReset
386-
387-
406+
member x.Status =
407+
match x with
408+
| TimingClock -> 0xf8uy
409+
| UndefinedF9 -> 0xf9uy
410+
| StartSequence -> 0xfauy
411+
| ContinueSequence -> 0xfbuy
412+
| StopSequence -> 0xfcuy
413+
| UndefinedFD -> 0xfduy
414+
| ActiveSensing -> 0xfeuy
415+
| SystemReset -> 0xffuy
388416

389417
and [<RequireQualifiedAccess>] MidiScaleType = Major | Minor | OtherScale of word8

‎src/ZMidi/ExtraTypes.fs‎

Lines changed: 28 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
module ZMidi.Internal.ExtraTypes
2+
open ZMidi.DataTypes
23

34

45

@@ -26,4 +27,30 @@ let fromVarlen =
2627
function | V1 a -> uint32 (up a)
2728
| V2 (a, b) -> (left7 (uint32 (up a))) + (uint32 (up b))
2829
| V3 (a, b, c) -> (left14 (uint32 (up a))) + (left7 (uint32 (up b))) + uint32 (up c)
29-
| V4 (a, b, c, d) -> (left21 (uint32 (up a))) + (left14 (uint32 (up b))) + (left7 (uint32 (up c))) + uint32 (up d)
30+
| V4 (a, b, c, d) -> (left21 (uint32 (up a))) + (left14 (uint32 (up b))) + (left7 (uint32 (up c))) + uint32 (up d)
31+
let inline encodeVarlen (myValue) =
32+
let inline initMask nBits =
33+
[|0 .. nBits - 1|]
34+
|> Array.map (fun shift -> LanguagePrimitives.GenericOne <<< shift)
35+
|> Array.fold ((|||)) LanguagePrimitives.GenericZero
36+
let nBits = 7
37+
let maxBits =
38+
let nMaxBytes = System.Runtime.InteropServices.Marshal.SizeOf(myValue.GetType())
39+
nMaxBytes * nBits
40+
let maxValue = initMask maxBits
41+
if maxValue < myValue then
42+
failwithf "can't encode %i: to high, max being %i" myValue maxValue
43+
let shiftAnd7Bits =
44+
[|0 .. nBits .. maxBits - 1|]
45+
|> Array.map (fun shift ->
46+
let mask = initMask nBits <<< shift
47+
let value =byte ((myValue &&& mask) >>> shift)
48+
value
49+
)
50+
51+
shiftAnd7Bits
52+
|> Array.rev
53+
|> Array.skipWhile ((=) LanguagePrimitives.GenericZero)
54+
|> function | [||] -> [|LanguagePrimitives.GenericZero|]
55+
| bytes -> bytes
56+

‎src/ZMidi/Internal/ParserMonad.fs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -90,11 +90,12 @@ module ParserMonad =
9090

9191
let nullOut = new StreamWriter(Stream.Null) :> TextWriter
9292
let mutable debug = false
93-
let logf format = //format: Printf.TextWriterFormat<'a>) =
93+
let logf format =
9494
if debug then
9595
printfn format
9696
else
9797
fprintfn nullOut format
98+
//Unchecked.defaultof<_>
9899

99100
let inline private apply1 (parser : ParserMonad<'a>)
100101
(midiData : byte[])
@@ -388,7 +389,7 @@ module ParserMonad =
388389
return (System.String arr)
389390
}
390391
<??> sprintf "readString failed at %i"
391-
392+
open ZMidi.Internal.DataTypes.FromBytes
392393
/// Parse a uint16 (big endian).
393394
let readUInt16be : ParserMonad<uint16>=
394395
parseMidi {

‎src/ZMidi/Internal/Utils.fs‎

Lines changed: 94 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,29 +1,98 @@
11
namespace ZMidi.Internal
2+
open ZMidi.DataTypes
23

4+
module Evil =
5+
let inline uncurry4 f = fun (a,b,c,d) -> f a b c d
6+
module DataTypes =
7+
module FromBytes =
8+
9+
/// Builds a Word16 (big endian).
10+
let word16be (a : byte) (b : byte) : uint16 =
11+
let a = uint16 a
12+
let b = uint16 b
13+
(a <<< 8) + b
14+
15+
/// Builds a Word14 (big endian).
16+
let word14be (a: byte) (b: byte) : word14 =
17+
let a = uint16 a
18+
let b = uint16 b
19+
word14((a <<< 7) + b)
20+
21+
let word24be (a: byte) (b: byte) (c: byte) : word24 =
22+
((uint32 a) <<< 16)
23+
+ ((uint32 b) <<< 8)
24+
+ (uint32 c)
25+
26+
let word32be (a: byte) (b: byte) (c: byte) (d: byte) : word32 =
27+
((uint32 a) <<< 24)
28+
+ ((uint32 b) <<< 16)
29+
+ ((uint32 c) <<< 08)
30+
+ ((uint32 d) <<< 00)
31+
module ToBytes =
32+
let word32be (v: word32) =
33+
(v &&& 0x000000ffu) >>> 00 |> byte
34+
, (v &&& 0x0000ff00u) >>> 08 |> byte
35+
, (v &&& 0x00ff0000u) >>> 16 |> byte
36+
, (v &&& 0xff000000u) >>> 24 |> byte
37+
module Isomorphisms =
38+
type Iso<'a,'b> = ('a -> 'b) * ('b -> 'a)
39+
module Iso =
40+
let reverse iso = snd iso, fst iso
41+
42+
let word32be : Iso<_,_> = (ToBytes.word32be), (Evil.uncurry4 FromBytes.word32be)
43+
344
module Utils =
4-
open ZMidi.DataTypes
545
open System.IO
6-
7-
/// Builds a Word16 (big endian).
8-
let word16be (a : byte) (b : byte) : uint16 =
9-
let a = uint16 a
10-
let b = uint16 b
11-
(a <<< 8) + b
12-
13-
/// Builds a Word14 (big endian).
14-
let word14be (a: byte) (b: byte) : word14 =
15-
let a = uint16 a
16-
let b = uint16 b
17-
word14((a <<< 7) + b)
18-
19-
let word24be (a: byte) (b: byte) (c: byte) : word24 =
20-
((uint32 a) <<< 16)
21-
+ ((uint32 b) <<< 8)
22-
+ (uint32 c)
23-
24-
let word32be (a: byte) (b: byte) (c: byte) (d: byte) : uint32 =
25-
((uint32 a) <<< 24)
26-
+ ((uint32 b) <<< 16)
27-
+ ((uint32 c) <<< 8)
28-
+ (uint32 d)
29-
46+
47+
let inline (|TestBit|_|) (bit: int) (i: ^T) =
48+
let mask = LanguagePrimitives.GenericOne <<< bit
49+
if mask &&& i = mask then Some () else None
50+
51+
let inline clearBit (bit: int) (i: ^T) =
52+
let mask = ~~~ (LanguagePrimitives.GenericOne <<< bit)
53+
i &&& mask
54+
55+
let inline setBit (bit: int) (i: ^T) =
56+
let mask = (LanguagePrimitives.GenericOne <<< bit)
57+
i ||| mask
58+
let inline msbHigh i =
59+
match i with
60+
| TestBit 7 -> true
61+
| _ -> false
62+
63+
64+
module Text =
65+
let prettyBytes (bytes : byte array) =
66+
bytes
67+
|> Array.chunkBySize 32
68+
|> Array.map (
69+
fun bytesChunk ->
70+
let bits =
71+
bytesChunk
72+
|> Array.chunkBySize 16
73+
|> Array.map (fun items ->
74+
items
75+
|> Array.map (sprintf "%02x")
76+
|> String.concat " "
77+
)
78+
|> String.concat " - "
79+
80+
bits
81+
)
82+
83+
|> String.concat System.Environment.NewLine
84+
let inline prettyBits number =
85+
let maxSize = 8 * System.Runtime.InteropServices.Marshal.SizeOf (number.GetType())
86+
[|0 .. (maxSize - 1)|]
87+
|> Array.rev
88+
|> Array.map (fun shift ->
89+
let mask = LanguagePrimitives.GenericOne <<< shift
90+
if (number &&& mask <> LanguagePrimitives.GenericZero) then "■" else " "
91+
)
92+
|> String.concat ""
93+
|> sprintf "[%s]"
94+
95+
module PreventPrintF =
96+
open System
97+
let [<Obsolete("please do not use printfn in this file", true)>] printfn () = ()
98+
let [<Obsolete("please do not use printf in this file", true)>] printf () = ()

0 commit comments

Comments
 (0)