1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
{-# LANGUAGE ExplicitForAll #-}
module Midi where
import BasePrelude
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Char8 (pack, unpack)
import Prelude hiding (id, (.))
-- import Sound.MIDI.ALSA
import System.Clock
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow ()
import qualified Sound.ALSA.Sequencer.Event as Event
-- import Sound.MIDI.ALSA
import Sound.MIDI.ALSA.Query
import qualified Sound.MIDI.ALSA.Construct as Construct
import Sound.MIDI.Message
import Codec.Midi
import Codec.ByteString.Builder
import Codec.ByteString.Parser
-- import qualified Sound.ALSA.Sequencer
-- import qualified Sound.ALSA.Sequencer.Address
-- import qualified Sound.ALSA.Sequencer.Port
-- import qualified Sound.ALSA.Sequencer.Queue
-- import qualified Sound.ALSA.Sequencer.Time as Time
-- import qualified Sound.ALSA.Sequencer.RealTime as RealTime
-- type RecordedEvent = (TimeSpec, Event.Data)
type RecordedEvent = (TimeSpec, Codec.Midi.Message)
data Recording = StartRecording TimeSpec |
RecordingInProgress TimeSpec TimeSpec [RecordedEvent]
data CompleteRecording = CompleteRecording {
_recStart :: TimeSpec,
_recEnd :: TimeSpec,
_recFirst :: TimeSpec,
_recLast :: TimeSpec,
_recEvents :: [RecordedEvent]
}
class Playable p where
playableEvents :: p -> [RecordedEvent]
instance Playable Recording where
playableEvents (StartRecording _) = []
playableEvents (RecordingInProgress _ _ ls) = ls
instance Playable CompleteRecording where
playableEvents = _recEvents
instance FromRow CompleteRecording where
fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
where
cons a a' b b' c c' d d' z = CompleteRecording (TimeSpec a a') (TimeSpec b b') (TimeSpec c c') (TimeSpec d d') (bytesToMidi z)
instance ToRow CompleteRecording where
toRow reco = toRow (s, ns, s', ns', s'', ns'', s''', ns''', midiToBytes midi)
where
(CompleteRecording (TimeSpec s ns) (TimeSpec s' ns') (TimeSpec s'' ns'') (TimeSpec s''' ns''') midi) = reco
instance Monoid CompleteRecording where
mempty = CompleteRecording 0 0 0 0 []
(CompleteRecording s _e f _l evts) `mappend` (CompleteRecording _s' e' _f' l' evts') =
CompleteRecording s e' f l' (evts' ++ evts)
maybesnd :: forall t t1. (t, Maybe t1) -> Maybe (t, t1)
maybesnd (_, Nothing) = Nothing
maybesnd (x, Just y) = Just (x, y)
convertEvents' :: [(TimeSpec, Event.Data)] -> [(TimeSpec, Sound.MIDI.Message.T)]
convertEvents' = mapMaybe (maybesnd . fmap conv)
where
conv :: Event.Data -> Maybe Sound.MIDI.Message.T
conv x@(Event.NoteEv _ _) = uncurry Construct.note <$> note x
conv _ = Nothing
unConvertEvents' :: [(TimeSpec, Sound.MIDI.Message.T)] -> [(TimeSpec, Event.Data)]
unConvertEvents' = mapMaybe (maybesnd . fmap conv)
where
conv :: Sound.MIDI.Message.T -> Maybe Event.Data
conv msg = uncurry Construct.note <$> note msg
convertEvents :: [(TimeSpec, Event.Data)] -> [(TimeSpec, Codec.Midi.Message)]
convertEvents = mapMaybe (maybesnd . fmap conv)
where
conv :: Event.Data -> Maybe Codec.Midi.Message
conv (Event.NoteEv Event.NoteOn (Event.Note c p v _ _)) = Just $ cpv Codec.Midi.NoteOn c p v
conv (Event.NoteEv Event.NoteOff (Event.Note c p v _ _)) = Just $ cpv Codec.Midi.NoteOff c p v
conv _ = Nothing
cpv f c p v = f (fi $ Event.unChannel c) (fi $ Event.unPitch p) (fi $ Event.unVelocity v)
fi = fromIntegral
setChannel :: Codec.Midi.Channel -> Codec.Midi.Message -> Codec.Midi.Message
setChannel c (NoteOff _ k v) = (NoteOff c k v)
setChannel c (NoteOn _ k v) = (NoteOn c k v)
setChannel c (ProgramChange _ p) = (ProgramChange c p)
setChannel c (ControlChange _ n v) = (ControlChange c n v)
setChannel c (KeyPressure _ k p) = (KeyPressure c k p)
setChannel c (ChannelPressure _ p) = (ChannelPressure c p)
setChannel c (PitchWheel _ p) = (PitchWheel c p)
setChannel _ x = x
unConvertEvents :: [(TimeSpec, Codec.Midi.Message)] -> [(TimeSpec, Event.Data)]
unConvertEvents = mapMaybe (maybesnd . fmap conv)
where
conv :: Codec.Midi.Message -> Maybe Event.Data
conv (Codec.Midi.NoteOn c p v) = Just $ cpv c p v Event.NoteOn
conv (Codec.Midi.NoteOff c p v) = Just $ cpv c p v Event.NoteOff
conv _ = Nothing
cpv c p v f = Event.NoteEv f (Event.Note (Event.Channel $ fi c) (Event.Pitch $ fi p) (Event.Velocity $ fi v) (Event.Velocity $ fi v) (Event.Duration 0))
fi = fromIntegral
recordEvents :: Recording -> [(TimeSpec, Event.Data)] -> Recording
recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ convertEvents new ++ orig
recordEvents i@(StartRecording _) [] = i
recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y (convertEvents new)
where y = fst $ last new
stopRecording :: Recording -> TimeSpec -> Maybe CompleteRecording
stopRecording (RecordingInProgress x y ls@((z,_):_)) end = Just $ CompleteRecording x end y z ls
stopRecording _ _ = Nothing
midiToBytes :: [RecordedEvent] -> BS.ByteString
midiToBytes = pack . show . overFirsts toDeltas . map (first timeSpecAsNanoSecs) . (fmap . fmap) (toLazyByteString . buildMessage) . reverse
bytesToMidi :: BS.ByteString -> [RecordedEvent]
bytesToMidi = unpack >>> read >>> overFirsts fromDeltas >>> map (first fromInteger) >>> (fmap . fmap) f >>> reverse
where f :: LBS.ByteString -> Codec.Midi.Message
f = runParser (parseMessage Nothing) >>> either error id
overFirsts :: ([a1] -> [a]) -> [(a1, b)] -> [(a, b)]
overFirsts f = uncurry zip . first f . unzip
toDeltas :: Num n => [n] -> [n]
toDeltas xs = zipWith (-) xs (0:xs)
fromDeltas :: Num n => [n] -> [n]
fromDeltas = helper 0
where
helper _ [] = []
helper n (x:xs) = (n+x) : helper (n+x) xs
-- fromDeltas :: Num n => [n] -> [n]
-- fromDeltas = foldr (\a b -> a:map (a +) b) []
|
