Skip to content

Commit 6459866

Browse files
smoothdevelopersmoothdeveloper
committed
various optimisations
* simplify event and voiceEvent * remove some usage of *printf / %A in inner loops * print parsing time in scratch script seems to parse properly now
1 parent df8483b commit 6459866

File tree

3 files changed

+73
-64
lines changed

3 files changed

+73
-64
lines changed

‎demo/scratch.fsx‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55
//#load "../src/zmidi/internal/utils.fs"
66
//#load "../src/zmidi/internal/parsermonad.fs"
77
//#load "../src/zmidi/read.fs"
8-
#r "../build/Debug/AnyCPU/net45/zmidi-fs-core.dll"
8+
#r "../build/Release/AnyCPU/net45/zmidi-fs-core.dll"
99
open System.IO
1010
open ZMidi.Internal.ParserMonad
1111
open ZMidi
@@ -33,13 +33,13 @@ let folder =
3333
for file in folder.EnumerateFiles() do
3434
let buffer = File.ReadAllBytes file.FullName
3535
printfn "======================= %s" file.FullName
36-
36+
let watch = System.Diagnostics.Stopwatch.StartNew()
3737
let parseResult =
3838
ZMidi.Internal.ParserMonad.runParser
3939
ZMidi.ReadFile.midiFile
4040
buffer
4141
State.initial
42-
42+
printfn "ellapsed parse time : %A" watch.Elapsed
4343
match parseResult with
4444
| Ok result ->
4545

@@ -49,7 +49,7 @@ for file in folder.EnumerateFiles() do
4949

5050
| Error something -> printfn "ERR: %s %A" file.FullName something
5151

52-
52+
(*
5353
let cases =
5454
[|
5555
{| expected = 0x00000000u; input = [|0x00uy|] |}
@@ -154,4 +154,4 @@ let pp = parseMidi {
154154
155155
let (Ok(ParserMonad f)) = (ZMidi.Internal.ParserMonad.runParser pp [|1uy..5uy|] State.initial)
156156
157-
f [|1uy..5uy|] State.initial
157+
f [|1uy..5uy|] State.initial*)

‎src/ZMidi/Internal/ParserMonad.fs‎

Lines changed: 22 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -17,8 +17,17 @@ module ParserMonad =
1717
| Program of byte
1818
| ChannelAftertouch of byte
1919
| PitchBend of byte
20+
override x.ToString() =
21+
match x with
22+
| StatusOff -> "StatusOff"
23+
| NoteOn o -> "NoteOn " + string o
24+
| NoteOff o -> "NoteOff " + string o
25+
| NoteAftertoucuh o -> "NoteAftertoucuh " + string o
26+
| Control o -> "Control " + string o
27+
| Program o -> "Program " + string o
28+
| ChannelAftertouch o -> "ChannelAftertouch " + string o
29+
| PitchBend o -> "PitchBend " + string o
2030

21-
2231
type MidiData = byte array
2332

2433
type Pos = int
@@ -48,7 +57,7 @@ module ParserMonad =
4857

4958
(sprintf "%A" x.LastParse)
5059
#else
51-
sprintf "(Pos:%i;Status:%30s)" x.Position (sprintf "%A" x.RunningStatus)
60+
System.String.Format("(Pos:{0};Status:{1})", x.Position, string x.RunningStatus)
5261
#endif
5362
type ParseError =
5463
ParseError of
@@ -93,9 +102,12 @@ module ParserMonad =
93102
let (ParserMonad fn) = parser
94103
try
95104
let result = fn midiData state
105+
let oldState = state
96106
match result with
97107
| Ok (r, state) ->
98-
logf "parse ok: %50s %O" (sprintf "%O" r) state
108+
if debug then
109+
if state <> oldState then
110+
logf "parse ok: %O" state
99111
#if DEBUG_LASTPARSE
100112
let state = { state with LastParse = r }
101113
#endif
@@ -145,15 +157,15 @@ module ParserMonad =
145157
bindM m k
146158

147159
type ParserBuilder() =
148-
member self.ReturnFrom (ma:ParserMonad<'a>) : ParserMonad<'a> = ma
149-
member self.Return x = mreturn x
150-
member self.Bind (p,f) = bindM p f
151-
member self.Zero a = ParserMonad (fun input state -> Ok(a, state))
160+
member inline self.ReturnFrom (ma:ParserMonad<'a>) : ParserMonad<'a> = ma
161+
member inline self.Return x = mreturn x
162+
member inline self.Bind (p,f) = bindM p f
163+
member inline self.Zero a = ParserMonad (fun input state -> Ok(a, state))
152164
//member self.Combine (ma, mb) = ma >>= mb
153165

154166
// inspired from http://www.fssnip.net/7UJ/title/ResultBuilder-Computational-Expression
155167
// probably broken
156-
member self.TryFinally(m, compensation) =
168+
member inline self.TryFinally(m, compensation) =
157169
try self.ReturnFrom(m)
158170
finally compensation()
159171

@@ -183,7 +195,7 @@ module ParserMonad =
183195
ParserMonad <| fun _ st -> Error (mkOtherParseError st genMessage)
184196

185197
/// Run the parser, if it fails swap the error message.
186-
let ( <??> ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> =
198+
let inline ( <??> ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> =
187199
ParserMonad <| fun input st ->
188200
match apply1 parser input st with
189201
| Ok result -> Ok result
@@ -231,7 +243,7 @@ module ParserMonad =
231243
let getRunningEvent : ParserMonad<VoiceEvent> =
232244
ParserMonad <| fun _ st -> Ok (st.RunningStatus , st)
233245

234-
let setRunningEvent (runningStatus : VoiceEvent) : ParserMonad<unit> =
246+
let inline setRunningEvent (runningStatus : VoiceEvent) : ParserMonad<unit> =
235247
ParserMonad <| fun _ st -> Ok ((), { st with RunningStatus = runningStatus })
236248

237249
let getPos : ParserMonad<int> =

‎src/ZMidi/Read.fs‎

Lines changed: 46 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -329,22 +329,25 @@ module ReadFile =
329329

330330

331331
let voiceEvent n =
332-
match n with
333-
| SB(0x80uy, ch) -> parseMidi { do! setRunningEvent (NoteOff ch)
334-
return! noteOff ch }
335-
| SB(0x90uy, ch) -> parseMidi { do! setRunningEvent (NoteOn ch)
336-
return! noteOn ch }
337-
| SB(0xa0uy, ch) -> parseMidi { do! setRunningEvent (NoteAftertoucuh ch)
338-
return! noteAftertouch ch }
339-
| SB(0xb0uy, ch) -> parseMidi { do! setRunningEvent (Control ch)
340-
return! controller ch }
341-
| SB(0xc0uy, ch) -> parseMidi { do! setRunningEvent (Program ch)
342-
return! programChange ch }
343-
| SB(0xd0uy, ch) -> parseMidi { do! setRunningEvent (ChannelAftertouch ch)
344-
return! channelAftertouch ch }
345-
| SB(0xe0uy, ch) -> parseMidi { do! setRunningEvent (PitchBend ch)
346-
return! pitchBend ch }
347-
| otherwise -> impossibleMatch (sprintf "voiceEvent: %x" otherwise)
332+
parseMidi {
333+
match n with
334+
| SB(0x80uy, ch) -> do! setRunningEvent (NoteOff ch)
335+
return! noteOff ch
336+
| SB(0x90uy, ch) -> do! setRunningEvent (NoteOn ch)
337+
return! noteOn ch
338+
| SB(0xa0uy, ch) -> do! setRunningEvent (NoteAftertoucuh ch)
339+
return! noteAftertouch ch
340+
| SB(0xb0uy, ch) -> do! setRunningEvent (Control ch)
341+
return! controller ch
342+
| SB(0xc0uy, ch) -> do! setRunningEvent (Program ch)
343+
return! programChange ch
344+
| SB(0xd0uy, ch) -> do! setRunningEvent (ChannelAftertouch ch)
345+
return! channelAftertouch ch
346+
| SB(0xe0uy, ch) -> do! setRunningEvent (PitchBend ch)
347+
return! pitchBend ch
348+
| otherwise -> return! impossibleMatch (sprintf "voiceEvent: %x" otherwise)
349+
}
350+
348351
let runningStatus (event: VoiceEvent) : ParserMonad<MidiEvent> =
349352
let mVoiceEvent e = mreturn (VoiceEvent(MidiRunningStatus.ON, e))
350353
match event with
@@ -384,40 +387,34 @@ event = peek >>= step
384387
/// can cause fatal parse errors.
385388
386389
let event : ParserMonad<MidiEvent> =
387-
let step n : ParserMonad<MidiEvent> =
388-
parseMidi {
389-
match n with
390-
| 0xffuy ->
391-
do! dropByte
392-
let! event = readByte >>= metaEvent
393-
return MetaEvent event
394-
| 0xf7uy ->
395-
do! dropByte
396-
let! sysexEvent = sysExEscape
397-
return SysExEvent sysexEvent
398-
| 0xf0uy ->
399-
do! dropByte
400-
let! sysexEvent = sysExEvent
401-
return SysExEvent sysexEvent
402-
| x when x >= 0xf8uy ->
403-
do! dropByte
404-
let! event = sysRealtimeEvent x
405-
return SysRealtimeEvent event
406-
| x when x >= 0xf1uy ->
407-
do! dropByte
408-
let! event = sysCommonEvent x
409-
return SysCommonEvent event
410-
| x when x >= 0x80uy ->
411-
do! dropByte
412-
let! voiceEvent = voiceEvent x
413-
return VoiceEvent(MidiRunningStatus.OFF, voiceEvent)
414-
| otherwise ->
415-
return! (getRunningEvent >>= runningStatus)
416-
417-
}
418390
parseMidi {
419-
let! p = peek
420-
return! step p
391+
match! peek with
392+
| 0xffuy ->
393+
do! dropByte
394+
let! event = readByte >>= metaEvent
395+
return MetaEvent event
396+
| 0xf7uy ->
397+
do! dropByte
398+
let! sysexEvent = sysExEscape
399+
return SysExEvent sysexEvent
400+
| 0xf0uy ->
401+
do! dropByte
402+
let! sysexEvent = sysExEvent
403+
return SysExEvent sysexEvent
404+
| x when x >= 0xf8uy ->
405+
do! dropByte
406+
let! event = sysRealtimeEvent x
407+
return SysRealtimeEvent event
408+
| x when x >= 0xf1uy ->
409+
do! dropByte
410+
let! event = sysCommonEvent x
411+
return SysCommonEvent event
412+
| x when x >= 0x80uy ->
413+
do! dropByte
414+
let! voiceEvent = voiceEvent x
415+
return VoiceEvent(MidiRunningStatus.OFF, voiceEvent)
416+
| otherwise ->
417+
return! (getRunningEvent >>= runningStatus)
421418
}
422419

423420
let message =

0 commit comments

Comments
 (0)