modality-haskell.hs

{--
		(C)opyright 2015 by Miguel Negrão

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
--}
{-# LANGUAGE ScopedTypeVariables #-}

module Sound.MN.MIDI where

import Text.Show.Pretty
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Writer.Lazy
import Control.Monad.Trans.Reader
import Data.Functor.Identity
import Control.Monad.Trans.Class (lift)
import Data.Map (fromList, toList, Map, lookup)
import Reactive.Banana
import Reactive.Banana.Frameworks

data StringOrInt = IsString String | IsInt Int deriving (Show, Read)

instance Eq StringOrInt where
    (IsString _) == (IsInt _) = False
    (IsInt _) == (IsString _) = False
    (IsString a) == (IsString b) = a == b
    (IsInt a) == (IsInt b) = a == b

instance Ord StringOrInt where
    (IsString _) <= (IsInt _) = True
    (IsInt _) <= (IsString _) = False
    (IsString a) <= (IsString b) = a <= b
    (IsInt a) <= (IsInt b) = a <= b

data KtlControlType = Slider | Knob | Button deriving (Show)

-- make chan word8 and midinum word32, possibly more efficient
data MKtlObj = MKtlObj{ midiChan::Int, midiNum::Int, ktltype::KtlControlType } deriving (Show)
--type MKtlObject = Int

data MKtlNode a = MKtlEndNode a | MKtlArrayNode [MKtlNode a] | MKtlMapNode (Map String (MKtlNode a)) deriving (Show)
data MKtl0 a = MKtl0 (Map String (MKtlNode a)) deriving (Show)
type MKtl = MKtl0 MKtlObj

type KtlTag = [StringOrInt]

type Channel = Int
type CC = Int
type MIDIValue = Double
type MIDIMessage = (Channel, CC, MIDIValue)

ktl :: String -> [StringOrInt]
ktl s = [IsString s]

--(!) :: CanBeStringOrInt a => [StringOrInt] -> a -> [StringOrInt]
--(!) xs x =  (toStringOrInt x) : xs

(!) :: [StringOrInt] -> Int -> [StringOrInt]
(!) xs x =  (IsInt x) : xs

(<!) :: [StringOrInt] -> String -> [StringOrInt]
(<!) xs x =  (IsString x) : xs

createDict' :: MKtlNode MKtlObj -> ReaderT KtlTag (Writer [(KtlTag,(Int,Int))]) ()
createDict' (MKtlEndNode (MKtlObj midiChan midiNum ktltype)) = do
        tag <- ask
        (lift.tell) [(tag,(midiChan,midiNum))]
createDict' (MKtlArrayNode xs) = sequence_ $ zipWith f xs [0..(length xs - 1)] where
                                    f node i = local (! i) $ createDict' node
createDict' (MKtlMapNode m) = sequence_ $ fmap f (toList m) where
                                    f (tag,node) = local (<! tag) $ createDict' node

createDict :: MKtl0 MKtlObj -> Map KtlTag (Int, Int)
createDict (MKtl0 m) = fromList $ (snd . runIdentity . runWriterT . runReaderT z) [] where
    z = sequence_ $ fmap f (toList m)
    f (tag,node) = local (<! tag) $ createDict' node


f ktltype = fmap (\(xs,ys) -> MKtlArrayNode $ zipWith (\cc ch -> MKtlEndNode MKtlObj{ midiChan=ch, midiNum=cc, ktltype=ktltype }) xs ys)
nano = MKtl0 $ fromList [
    ("sl", MKtlArrayNode sl),
    ("kn", MKtlArrayNode kn),
    ("bt", MKtlArrayNode bt),
    ("rew", MKtlEndNode MKtlObj{ midiChan=0, midiNum=47, ktltype=Button }),
    ("play", MKtlEndNode MKtlObj{ midiChan=0, midiNum=45, ktltype=Button }),
    ("fwd", MKtlEndNode MKtlObj{ midiChan=0, midiNum=48, ktltype=Button }),
    ("loop", MKtlEndNode MKtlObj{ midiChan=0, midiNum=49, ktltype=Button }),
    ("stop", MKtlEndNode MKtlObj{ midiChan=0, midiNum=46, ktltype=Button }),
    ("rec", MKtlEndNode MKtlObj{ midiChan=0, midiNum=44, ktltype=Button })
    ] where
    bt = fmap (MKtlArrayNode.(fmap (\(xs,ys) -> MKtlArrayNode $ zipWith (\cc ch -> MKtlEndNode MKtlObj{ midiChan=ch, midiNum=cc, ktltype=Button }) xs ys))) [
        [ ([23..31], replicate 9 0 ),   ([33..41], replicate 9 0 )  ],
        [ ([67..75], replicate 9 0 ),   ([76..84], replicate 9 0 )  ],
        [ ([107..115], replicate 9 0 ), ([116..124], replicate 9 0 )],
        [ (replicate 9 16, 16:[1..8] ), ( replicate 9 17, [0..8] )  ]
        ]
    sl = f Slider [
        ( [ 2, 3, 4, 5, 6, 8, 9, 12, 13 ], replicate 9 0 ),
        ( [ 42, 43, 50, 51, 52, 53, 54, 55, 56 ], replicate 9 0 ),
        ( [ 85, 86, 87, 88, 89, 90, 91, 92, 93 ], replicate 9 0 ),
        ( replicate 9 7, [ 0, 1, 2, 3, 4, 5, 6, 7, 8 ] )
        ]
    kn = f Knob [
        ( [14..22],             replicate 9 0 ),
        ( [57..63]++[65,66],    replicate 9 0 ),
        ( [94..97]++[102..106], replicate 9 0 ),
        ( replicate 9 10,       [0..8] )
        ]
--putStrLn $ ppShow nano

nanoDict = createDict nano

ktlE :: KtlTag -> Event t MIDIMessage -> Event t MIDIValue
ktlE ktlTag e = (\(ch,cc,x) -> x) <$> (filterE (\(ch,cc,x) -> Just (ch,cc) == Data.Map.lookup ktlTag nanoDict) e)