summaryrefslogtreecommitdiff
path: root/Midi.hs
blob: eac587c6bc399afc5b1ad4677b1d843521a822f5 (plain)
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) []