Skip to content

Commit 5bec185

Browse files
smoothdevelopersmoothdeveloper
committed
some more functions in Read.fs
1 parent f21a803 commit 5bec185

File tree

3 files changed

+226
-36
lines changed

3 files changed

+226
-36
lines changed

‎src/ZMidi/DataTypes.fs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -100,7 +100,7 @@ and MidiVoiceEvent =
100100
///
101101
/// > D0 to DF (0 to F is channel number) * pressure_value
102102
///
103-
| ChannelAfterTouch of status: bits7 * pressure: bits7
103+
| ChannelAftertouch of status: bits7 * pressure: bits7
104104

105105
/// Pitch bend
106106
///
@@ -150,7 +150,7 @@ and MidiSysExEvent =
150150
///
151151
/// > F0 * length * packet1 ... [SysExContPacket]
152152
///
153-
| SysExCont of byte array * MidiSysExContPacket array
153+
| SysExCont of byte array * MidiSysExContPacket list
154154

155155
/// Escape sequence of one-or-more SysEx events.
156156
///

‎src/ZMidi/Internal/ParserMonad.fs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ module ParserMonad =
77

88
open ZMidi.Internal.Utils
99

10-
/// Status is either OFF of the previous VoiceEvent * Channel.
10+
/// Status is either OFF or the previous VoiceEvent * Channel.
1111
type VoiceEvent =
1212
| StatusOff
1313
| NoteOn of byte

‎src/ZMidi/Read.fs

Lines changed: 223 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,13 @@ module ReadFile =
5353
return (uint32 result) }
5454

5555
let getVarlenText = gencount getVarlen readChar (fun _ b -> System.String b)
56-
56+
let getVarlenBytes = gencount getVarlen readByte (fun _ b -> b)
57+
let deltaTime =
58+
parseMidi {
59+
let! v = getVarlen
60+
return DeltaTime(v)
61+
} <??> (fun p -> "delta time")
62+
5763
let fileFormat =
5864
parseMidi {
5965
match! readUInt16be with
@@ -103,23 +109,18 @@ module ReadFile =
103109
let metaEvent i =
104110
parseMidi {
105111
match i with
106-
| 0x00 -> return! metaEventSequenceNumber
107-
| 0x01 -> return! textEvent GenericText
108-
| 0x02 -> return! textEvent CopyrightNotice
109-
| 0x03 -> return! textEvent SequenceName
110-
| 0x04 -> return! textEvent InstrumentName
111-
| 0x05 -> return! textEvent Lyrics
112-
| 0x06 -> return! textEvent Marker
113-
| 0x07 -> return! textEvent CuePoint
112+
| 0x00uy -> return! metaEventSequenceNumber
113+
| 0x01uy -> return! textEvent GenericText
114+
| 0x02uy -> return! textEvent CopyrightNotice
115+
| 0x03uy -> return! textEvent SequenceName
116+
| 0x04uy -> return! textEvent InstrumentName
117+
| 0x05uy -> return! textEvent Lyrics
118+
| 0x06uy -> return! textEvent Marker
119+
| 0x07uy -> return! textEvent CuePoint
114120
}
115121
// let (<*>) af ma =
116122

117123

118-
let runningStatus : ParserMonad<MidiRunningStatus> =
119-
parseMidi {
120-
121-
return MidiRunningStatus.ON
122-
}
123124
//let metaEvent n = //: ParserMonad<MetaEvent> =
124125
// match n with
125126
// ///| 0x00uy -> ( SequenceNumber <~> (assertWord8 2uy *> word16be)) <??> (sprintf "sequence number: failed at %i" )
@@ -136,34 +137,223 @@ module ReadFile =
136137
//parseMidi {
137138
//
138139
//}
140+
141+
//sysExContPackets =
142+
// deltaTime >>= \dt -> getVarlenBytes (,) >>= \(n,xs) ->
143+
// let ans1 = MidiSysExContPacket dt n xs
144+
// in if isTerminated xs then return [ans1]
145+
// else sysExContPackets >>= \ks ->
146+
// return $ ans1:ks
147+
148+
let isTerminated bytes =
149+
bytes
150+
|> Array.tryFind ((=) 0xf7uy)
151+
|> function | Some i -> true
152+
| None -> false
153+
154+
let rec sysExContPackets =
155+
parseMidi {
156+
let! d = deltaTime
157+
let! b = getVarlenBytes
158+
let answer = MidiSysExContPacket (d, b)
159+
if isTerminated b then return List.singleton answer
160+
else
161+
let! answer2 = sysExContPackets
162+
return (answer :: answer2)
163+
}
164+
let sysExEvent =
165+
parseMidi {
166+
let! b = getVarlenBytes
167+
if isTerminated b then
168+
return SysExSingle b
169+
else
170+
let! cont = sysExContPackets
171+
return SysExCont(b, cont)
172+
} <??> (fun _ -> "sysExEvent")
173+
let sysExEscape =
174+
parseMidi {
175+
let! bytes = getVarlenBytes
176+
return SysExEscape bytes
177+
} <??> (fun _ -> "sysExEscape")
178+
let impossibleMatch text =
179+
fatalError (ErrMsg.Other (sprintf "impossible match: %s" text))
180+
181+
let sysCommonEvent n =
182+
match n with
183+
| 0xf1uy -> readByte >>= (QuarterFrame >> mreturn) <??> (fun p -> "quarter frame")
184+
| 0xf2uy ->
185+
parseMidi {
186+
let! a = readByte
187+
let! b = readByte
188+
return SongPosPointer(a,b)
189+
} <??> (fun p -> "song pos. pointer")
190+
| 0xf3uy -> readByte >>= (QuarterFrame >> mreturn) <??> (fun p -> "song select")
191+
| 0xf4uy -> mreturn UndefinedF4
192+
| 0xf5uy -> mreturn UndefinedF5
193+
| 0xf6uy -> mreturn TuneRequest
194+
| 0xf7uy -> mreturn EOX
195+
| tag -> impossibleMatch (sprintf "sysCommonEvent %x" tag)
196+
197+
let sysRealtimeEvent n =
198+
match n with
199+
| 0xf8uy -> mreturn TimingClock
200+
| 0xf9uy -> mreturn TimingClock
201+
| 0xfauy -> mreturn TimingClock
202+
| 0xfbuy -> mreturn TimingClock
203+
| 0xfcuy -> mreturn TimingClock
204+
| 0xfduy -> mreturn TimingClock
205+
| 0xfeuy -> mreturn TimingClock
206+
| 0xffuy -> mreturn TimingClock
207+
| tag -> impossibleMatch (sprintf "sysRealtimeEvent %x" tag)
208+
209+
let inline (|SB|) b =
210+
b &&& 0xf0uy, b &&& 0x0fuy
211+
212+
let noteOff ch =
213+
parseMidi {
214+
let! a = readByte
215+
let! b = readByte
216+
return MidiVoiceEvent.NoteOff(ch, a, b)
217+
} <??> (fun p -> "note-off")
218+
219+
let noteOn ch =
220+
parseMidi {
221+
let! a = readByte
222+
let! b = readByte
223+
return MidiVoiceEvent.NoteOn(ch, a, b)
224+
} <??> (fun p -> "note-on")
225+
226+
let noteAftertouch ch =
227+
parseMidi {
228+
let! a = readByte
229+
let! b = readByte
230+
return MidiVoiceEvent.NoteAfterTouch(ch, a, b)
231+
} <??> (fun p -> "noteAftertouch")
232+
233+
let controller ch =
234+
parseMidi {
235+
let! a = readByte
236+
let! b = readByte
237+
return MidiVoiceEvent.Controller(ch, a, b)
238+
} <??> (fun p -> "controller")
239+
240+
let programChange ch =
241+
parseMidi {
242+
let! a = readByte
243+
return MidiVoiceEvent.ProgramChange(ch, a)
244+
} <??> (fun p -> "controller")
245+
246+
let channelAftertouch ch =
247+
parseMidi {
248+
let! a = readByte
249+
return MidiVoiceEvent.ChannelAftertouch(ch, a)
250+
} <??> (fun p -> "channelAftertouch")
251+
let pitchBend ch =
252+
parseMidi {
253+
let! a = readWord14be
254+
return MidiVoiceEvent.PitchBend(ch, a)
255+
} <??> (fun p -> "pitchBend")
256+
257+
258+
let voiceEvent n =
259+
match n with
260+
| SB(0x80uy, ch) -> parseMidi { do! setRunningEvent (NoteOff ch)
261+
return! noteOff ch }
262+
| SB(0x90uy, ch) -> parseMidi { do! setRunningEvent (NoteOn ch)
263+
return! noteOn ch }
264+
| SB(0xa0uy, ch) -> parseMidi { do! setRunningEvent (NoteAftertoucuh ch)
265+
return! noteAftertouch ch }
266+
| SB(0xb0uy, ch) -> parseMidi { do! setRunningEvent (Control ch)
267+
return! controller ch }
268+
| SB(0xc0uy, ch) -> parseMidi { do! setRunningEvent (Program ch)
269+
return! programChange ch }
270+
| SB(0xd0uy, ch) -> parseMidi { do! setRunningEvent (ChannelAftertouch ch)
271+
return! channelAftertouch ch }
272+
| SB(0xe0uy, ch) -> parseMidi { do! setRunningEvent (PitchBend ch)
273+
return! pitchBend ch }
274+
| otherwise -> impossibleMatch (sprintf "voiceEvent: %x" otherwise)
275+
let runningStatus (event: VoiceEvent) : ParserMonad<MidiEvent> =
276+
let mVoiceEvent e = mreturn (VoiceEvent(MidiRunningStatus.ON, e))
277+
match event with
278+
| NoteOff ch -> (noteOff ch) >>= mVoiceEvent
279+
| NoteOn ch -> (noteOn ch) >>= mVoiceEvent
280+
| NoteAftertoucuh ch -> (noteAftertouch ch) >>= mVoiceEvent
281+
| Control ch -> (controller ch) >>= mVoiceEvent
282+
| Program ch -> (programChange ch) >>= mVoiceEvent
283+
| ChannelAftertouch ch -> (channelAftertouch ch) >>= mVoiceEvent
284+
| PitchBend ch -> (pitchBend ch) >>= mVoiceEvent
285+
| StatusOff -> readByte >>= (MidiEventOther >> mreturn)
286+
//parseMidi {
287+
//
288+
// //return MidiRunningStatus.ON
289+
//}
290+
291+
(*
292+
event :: ParserM MidiEvent
293+
event = peek >>= step
294+
where
295+
-- 00..7f -- /data/
296+
step n
297+
| n == 0xFF = MetaEvent <$> (dropW8 *> (word8 >>= metaEvent))
298+
| n >= 0xF8 = SysRealTimeEvent <$> (dropW8 *> sysRealTimeEvent n)
299+
| n == 0xF7 = SysExEvent <$> (dropW8 *> sysExEscape)
300+
| n >= 0xF1 = SysCommonEvent <$> (dropW8 *> sysCommonEvent n)
301+
| n == 0xF0 = SysExEvent <$> (dropW8 *> sysExEvent)
302+
| n >= 0x80 = VoiceEvent RS_OFF <$> (dropW8 *> voiceEvent (splitByte n))
303+
| otherwise = getRunningEvent >>= runningStatus
304+
*)
305+
306+
/// Parse an event - for valid input this function should parse
307+
/// without error (i.e all cases of event types are fully
308+
/// enumerated).
309+
///
310+
/// Malformed input (syntactically bad events, or truncated data)
311+
/// can cause fatal parse errors.
312+
139313
let event : ParserMonad<MidiEvent> =
140-
let step n : ParserMonad<MidiMetaEvent>=
141-
//parseMidi {
314+
//let foo = (readByte >>= metaEvent)
315+
let step n : ParserMonad<MidiEvent>=
316+
parseMidi {
142317
match n with
143-
| 0xffuy -> failwithf "" //MetaEvent <~> (dropByte *> (readByte >>= metaEvent))
144-
//| 0xf7uy -> ()//SysexEvent
145-
//| 0xf0uy -> ()//SysexEvent
146-
//| 0x80uy -> ()//VoiceEvent
147-
//| n when n >= 0xf8uy -> ()//SysRealtimeEvent
148-
//| n when n >= 0xf1uy -> ()//SysCommonEvent
149-
//| n when n >= 0x80uy -> ()//VoiceEvent
150-
//| _ -> getRunningEvent >>= runningStatus
151-
//}
152-
parseMidi {
153-
let! p = peek
154-
step p
155-
return! fatalError (Other "event: not implemented") }
318+
| 0xffuy ->
319+
do! dropByte
320+
let! event = readByte >>= metaEvent
321+
return MetaEvent event
322+
//MetaEvent <~> (dropByte *> (fun _ -> (readByte >>= metaEvent))) // failwithf "event ff"
323+
| 0xf7uy ->
324+
do! dropByte
325+
let! sysexEvent = sysExEscape
326+
return SysExEvent sysexEvent
327+
| 0xf0uy ->
328+
do! dropByte
329+
let! sysexEvent = sysExEvent
330+
return SysExEvent sysexEvent
331+
| x when x >= 0xf8uy ->
332+
do! dropByte
333+
let! event = sysRealtimeEvent x
334+
return SysRealtimeEvent event
335+
| x when x >= 0xf1uy ->
336+
do! dropByte
337+
let! event = sysCommonEvent x
338+
return SysCommonEvent event
339+
| x when x >= 0x80uy ->
340+
do! dropByte
341+
let! voiceEvent = voiceEvent x
342+
return VoiceEvent(MidiRunningStatus.OFF, voiceEvent)
343+
| otherwise ->
344+
return! (getRunningEvent >>= runningStatus)
156345

157-
let deltaTime =
346+
}
158347
parseMidi {
159-
return! getVarlen
160-
} <??> (fun p -> "delta time")
348+
let! p = peek
349+
return! step p
350+
}
161351

162352
let message =
163353
parseMidi {
164354
let! deltaTime = deltaTime
165355
let! event = event
166-
return { timestamp = DeltaTime(deltaTime); event = event }
356+
return { timestamp = deltaTime; event = event }
167357
}
168358
let messages i =
169359
parseMidi {

0 commit comments

Comments
 (0)