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
|
{-# 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
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
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) []
|
