module System.MIDI.Launchpad.Apps.MonoSeq where
import Data.List
import Control.Monad
import System.MIDI
import Data.Array.Unboxed
import Data.Array.IArray
import System.MIDI.Launchpad.Control
import System.MIDI.Launchpad.AppFramework
data Scale
= Chromatic
| Pentatonic
| CMinor
| CMajor
deriving (Eq,Show)
data Cfg = Cfg
{ seqSteps :: !Int
, stepResolution :: !Int
, midiFrom :: !Int
, midiScale :: !Scale
, ccFrom :: !Int
}
deriving Show
defaultCfg :: Cfg
defaultCfg = Cfg
{ seqSteps = 8
, stepResolution = 12
, midiFrom = 48
, midiScale = Pentatonic
, ccFrom = 90
}
data Mode
= Notes
| Params !Int
deriving (Eq,Ord,Show)
data State = State
{ _playing :: !Bool
, _screenPos :: !Int
, _notes :: !(UArray Int Int)
, _params :: !(UArray (Int,Int) Int)
, _playNotes :: [PlayNote]
}
deriving (Eq,Ord,Show)
data PlayNote = PlayNote
{ _note :: !Int
, _stopAt :: !Int
}
deriving (Eq,Ord,Show)
monoSequencer :: Cfg -> PureApp Cfg Mode State
monoSequencer cfg = PureApp
{ pAppConfig = cfg
, pAppIniState = (Notes, initialState cfg)
, pAppStartStop = startStop
, pAppRender = render
, pAppButton = button
, pAppSync = sync
}
initialState :: Cfg -> State
initialState cfg@(Cfg seqSteps stepResolution _ _ _) = State
{ _playing = False
, _screenPos = 0
, _notes = listArray (0,seqSteps+7) (repeat (1))
, _params = listArray ((0,0),(seqSteps+7,7))
$ concat $ transpose $
[ rep 5 , rep 3 , rep 0 , rep 4
, rep 4 , rep 4 , rep 4 , rep 4 ]
, _playNotes = []
}
where
rep = replicate seqSteps
startStop :: Cfg -> Bool -> State -> State
startStop cfg playing state = state { _playing = playing }
button :: Cfg -> ButtonPress -> (Mode,State) -> ((Mode,State),[MidiMessage'])
button cfg@(Cfg seqSteps stepResolution _ _ _) (Release _) old = (old,[])
button cfg@(Cfg seqSteps stepResolution _ _ _) (Press but) (mode,state) =
case but of
Dir d -> case d of
L -> ((mode, state { _screenPos = max (pos8) 0 }) , [])
R -> ((mode, state { _screenPos = min (pos+8) lastScreenPos }) , [])
_ -> ((mode,state),[])
Side k -> case mode of
Notes -> ( ( Params k , state ) , [] )
Params u -> ( ( if u/=k then Params k else Notes , state )
, if _playing state then [] else [CC (ccNumber cfg k) 64] )
Pad x y -> case mode of
Notes -> ( ( mode, state { _notes = notes // [(pos+x, new)] } ) , [] ) where
new = if old==y then 1 else y
old = notes!(pos+x)
Params u -> ( ( mode, state { _params = params // [((pos+x,u), 7y)] } ) , [] ) where
old = params!(pos+x,u)
_ -> ((mode,state),[])
where
lastScreenPos = 8 * div (seqSteps 1) 8
pos = _screenPos state
notes = _notes state
params = _params state
counterStep :: Cfg -> Int -> Int
counterStep (Cfg seqSteps stepResolution _ _ _) cnt = ((div cnt stepResolution) `mod` seqSteps)
invCounterStep :: Cfg -> Int -> Int
invCounterStep (Cfg seqSteps stepResolution _ _ _) step = step*stepResolution
totalTicks :: Cfg -> Int
totalTicks (Cfg seqSteps stepResolution _ _ _) = stepResolution * seqSteps
ccNumber :: Cfg -> Int -> Int
ccNumber (Cfg _ _ _ _ ccFrom) y = ccFrom + y 3
noteNumber :: Cfg -> Int -> Int
noteNumber (Cfg _ _ midiFrom midiScale _) y =
case midiScale of
Chromatic -> midiFrom + y
Pentatonic -> midiFrom + penta !! y
CMajor -> midiFrom + cmajor !! y
CMinor -> midiFrom + cminor !! y
where
penta = [ 0,2,4, 7,9, 12,14,16, 19,21 ]
cmajor = [ 0,2,4,5,7,9,11, 12,14,16,17,19,21,23]
cminor = [ 0,2,3,5,7,8,10, 12,14,15,17,19,20,22]
sync :: Cfg -> Mode -> State -> Int -> (State,[MidiMessage'])
sync cfg@(Cfg seqSteps stepResolution midiFrom midiScale ccFrom) mode state counter = (state',msgs) where
state' = state { _playNotes = newNotes ++ contNotes }
newNotes = [ PlayNote note (counter + 2*(len+1))
| x <- newIdx, let len = (div stepResolution 4) * (1+params!(x,1))
, let note = notes!x, note>=0 ]
newIdx = [ x | x <- [0..seqSteps1], let y = notes!x, y>=0
, invCounterStep cfg x + delay x == mod counter (totalTicks cfg) ]
(stopNotes, contNotes) = partition (\(PlayNote note stop) -> stop == counter) (_playNotes state)
notes = _notes state
params = _params state
delay x = params!(x,2)
msgs = [ NoteOff (toNote stop) 64 | PlayNote stop _ <- stopNotes ]
++ [ CC (ccNumber cfg y) value | x <- newIdx, let start = notes!x
, y <-[3..7] , let value = (params!(x,y))*16 ]
++ [ NoteOn (toNote start) vel | x <- newIdx, let start = notes!x
, let vel = (params!(x,0)+1)*161 ]
toNote y = if y>=0 then noteNumber cfg (7y) else error "MonoSeq/sync/toNote: shouldn't happen"
renderArrows :: Cfg -> State -> [(Button,Color)]
renderArrows cfg@(Cfg seqSteps _ _ _ _) state = concat
[ if _screenPos state > 0 then [(Dir L, green)] else []
, if _screenPos state < seqSteps8 then [(Dir R, green)] else []
]
render :: Cfg -> Mode -> State -> Maybe Int -> [(Button,Color)]
render cfg mode state msync = renderArrows cfg state ++ stuff where
pos = _screenPos state
notes = _notes state
params = _params state
steps = seqSteps cfg
column = case msync of
Nothing -> (1)
Just cnt -> counterStep cfg cnt pos
stuff = case mode of
Notes -> time ++ note where
time = if column >= 0 && column < 8 then [ (Pad column y, amber) | y<-[0..7] ] else []
note = [ (Pad x y, color) | x<-[0..7], let y = notes!(pos+x), pos+x<steps, y>=0
, let color = if column==x then orange else red ]
Params u -> time ++ par ++ side where
time = if column >= 0 && column < 8 then [ (Pad column 0, amber) ] else []
par = [ (Pad x y, color) | x<-[0..7], let p = params!(pos+x,u), pos+x<steps, p>0, y<-[7p..7]
, let color = if column==x && y==0 then yellow else green ]
side = [ (Side u, green) ]