diff --git a/midimory.cabal b/midimory.cabal --- a/midimory.cabal +++ b/midimory.cabal @@ -1,5 +1,5 @@ Name: midimory -Version: 0.0.0.3 +Version: 0.0.1 Maintainer: Henning Thielemann Author: Henning Thielemann Category: Sound, Music, Game, GUI @@ -17,8 +17,9 @@ Every tone is connected to two buttons. The players must find the pairs of buttons with equal tones. The two players alternatingly test pairs of buttons. - If they select a pair of buttons with equal tones, - there score is increased by one. + If one selects a pair of buttons with equal tones, + then his score is increased by one + and he is allowed to perform another attempt. . In order to play the tones you must connect it to a hardware or software synthesizer @@ -26,9 +27,13 @@ . > timidity -A300 -iA -B4,4 . - Then start the midimory game and - connect the game to the synthesizer. + Then start the midimory game and connect the game to the synthesizer: . + > midimory --connect-to TiMidity + . + or alternatively: + . + > midimory & > aconnect Midimory TiMidity Source-Repository head @@ -37,12 +42,15 @@ Source-Repository this type: darcs - tag: 0.0.0.3 + tag: 0.0.1 location: http://code.haskell.org/~thielema/midimory/ Executable midimory Main-Is: Main.hs - Other-Modules: MIDI + Other-Modules: + Configuration + MIDI + Option Hs-Source-Dirs: src GHC-Options: -Wall Build-Depends: @@ -50,7 +58,10 @@ wxcore >=0.12.1.6 && <0.93, alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, + optparse-applicative >=0.14 && <0.15, random >=1.0 && <1.2, transformers >=0.2 && <0.6, containers >=0.2 && <0.6, + array >=0.4 && <0.6, + utility-ht >=0.0.12 && <0.1, base >=3 && <5 diff --git a/src/Configuration.hs b/src/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Configuration.hs @@ -0,0 +1,149 @@ +module Configuration where + +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Options.Applicative as OP + +import qualified Control.Functor.HT as FuncHT +import Control.Applicative (liftA2, liftA3) + +import qualified Data.Map as Map +import qualified Data.List as List +import Data.Map (Map) +import Data.Bool.HT (if') +import Data.Monoid ((<>)) + + +data T = + Cons { + rows, columns :: Int, + texts :: [[String]], + pitches :: [Event.Pitch] + } + +create :: [[String]] -> [Event.Pitch] -> T +create ts ps = + Cons { + rows = length ts, + columns = maximum (map length ts), + texts = ts, + pitches = ps + } + +board4x4, board4x4sg, board4x6sg, board6x6sg :: T +board4x4 = + create + (FuncHT.outerProduct (\r c -> [r,c]) ['A'..'D'] ['0'..'3']) + (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12]) + +board4x4sg = + create + (map (map (:[])) ["SPR*", "*ACH", "GIT*", "*TER"]) + (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12]) + +board4x6sg = + create + (map (map (:[])) $ concat $ replicate 2 ["SPRACH", "GITTER"]) + (map (Event.Pitch . (60+)) [0..11]) + +board6x6sg = + create + (map (map (:[])) $ concat $ replicate 3 ["SPRACH", "GITTER"]) + (map (Event.Pitch . (60+)) [0..17]) + + +parseSize :: String -> Either String (Int,Int) +parseSize str = + let parser str0 = do + (width, 'x':str1) <- reads str0 + (height, "") <- reads str1 + return (width,height) + in case parser str of + [(width,height)] -> + if' (width<0) (Left "Negative width") $ + if' (height<0) (Left "Negative height") $ + if' (width>10) (Left "Width larger than 10") $ + if' (height>10) (Left "Height larger than 10") $ + if' (mod (width*height) 2 /= 0) + (Left "Board needs an even number of fields") $ + Right (fromInteger width, fromInteger height) + _ -> Left "MIDI pitch must be a number" + +optionBoardSize :: OP.Parser (Int,Int) +optionBoardSize = + OP.option (OP.eitherReader parseSize) $ + OP.long "board-size" <> + OP.metavar "WIDTHxHEIGHT" <> + OP.value (4,4) <> + OP.help "Board geometry (default: 4x4)" + + +majorScale, minorScale, chromaticScale :: [Int] +majorScale = [0,2,4,5,7,9,11] +minorScale = [0,2,3,5,7,8,10] +chromaticScale = [0..11] + +scales :: Map String [Int] +scales = + Map.fromList $ + ("major", majorScale) : + ("minor", minorScale) : + ("chromatic", chromaticScale) : + [] + +parseScale :: String -> Either String [Int] +parseScale str = + case Map.lookup str scales of + Just scale -> Right scale + Nothing -> + Left $ + "Scale must be one of: " ++ List.intercalate ", " (Map.keys scales) + +optionScale :: OP.Parser [Int] +optionScale = + OP.option (OP.eitherReader parseScale) + (OP.long "musical-scale" <> + OP.metavar "NAME" <> + OP.value [] <> + OP.help "Musical scale for notes") + + +parsePitch :: String -> Either String Event.Pitch +parsePitch str = + case reads str of + [(pitch, "")] -> + if' (pitch<0) (Left "Negative MIDI pitch") $ + if' (pitch>=128) (Left "MIDI pitch larger than 127") $ + Right $ Event.Pitch $ fromInteger pitch + _ -> Left "MIDI pitch must be a number" + +optionZerokey :: OP.Parser Event.Pitch +optionZerokey = + OP.option (OP.eitherReader parsePitch) + (OP.long "zerokey" <> + OP.metavar "INT" <> + OP.value (Event.Pitch 60) <> + OP.help "MIDI pitch for the lowest note (default: 60)") + + +option :: OP.Parser (Either String T) +option = + liftA3 + (\(w,h) scalePlain zeroKey -> + let numTones = div (w*h) 2 + zk = Event.unPitch zeroKey + in if' (fromIntegral zk + numTones >= 128) + (Left "Highest pitch outside MIDI scale") $ + Right $ + create + (FuncHT.outerProduct (\r c -> [r,c]) + (take h ['A'..]) (take w ['0'..])) + (let scale = + if null scalePlain + then if numTones>8 then chromaticScale else majorScale + else scalePlain + in map (Event.Pitch . (zk +) . fromIntegral) $ + take numTones $ liftA2 (+) [0,12..] scale)) + optionBoardSize + optionScale + optionZerokey diff --git a/src/MIDI.hs b/src/MIDI.hs --- a/src/MIDI.hs +++ b/src/MIDI.hs @@ -1,5 +1,6 @@ module MIDI where +import qualified Sound.ALSA.Sequencer.Connect as Connect import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port @@ -12,19 +13,21 @@ import qualified System.IO as IO +import Control.Monad.HT ((<=<)) + {- The queue is required by the ANote event type. -} data Sequencer = - Sequencer (SndSeq.T SndSeq.OutputMode) Queue.T Port.T + Sequencer (SndSeq.T SndSeq.OutputMode) Queue.T Port.T Event.Channel sendNote :: Sequencer -> Event.Pitch -> IO () -sendNote h p = do +sendNote h@(Sequencer _ _ _ chan) p = do sendEvent h $ Event.NoteEv Event.ANote $ Event.Note { - Event.noteChannel = Event.Channel 0, + Event.noteChannel = chan, Event.noteNote = p, Event.noteVelocity = Event.normalVelocity, Event.noteOffVelocity = Event.normalVelocity, @@ -34,7 +37,7 @@ sendEvent :: Sequencer -> Event.Data -> IO () -sendEvent (Sequencer h q p) ev = do +sendEvent (Sequencer h q p _) ev = do c <- Client.getId h _ <- Event.outputDirect h $ @@ -44,10 +47,14 @@ } return () +parseAndConnect :: Sequencer -> String -> IO Connect.T +parseAndConnect (Sequencer h _ p _) = + Connect.createTo h p <=< Addr.parse h + withSequencer :: - String -> (Sequencer -> IO ()) -> IO () -withSequencer name act = + String -> Event.Channel -> (Sequencer -> IO ()) -> IO () +withSequencer name chan act = flip AlsaExc.catch (\e -> IO.hPutStrLn IO.stderr $ "alsa_exception: " ++ AlsaExc.show e) $ do SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do @@ -58,4 +65,4 @@ Port.withSimple h "inout" (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]) Port.typeApplication $ \ port -> do - act $ Sequencer h q port + act $ Sequencer h q port chan diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,64 +1,29 @@ module Main where -import MIDI +import qualified Configuration as Config +import qualified Option +import qualified MIDI import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Graphics.UI.WX as WX import Graphics.UI.WX (Prop((:=)), set, get, text, selection, command, on, close, container, widget, layout, margin, row, column, ) -import qualified Graphics.UI.WX as WX - import qualified System.Random as Rnd -import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef, ) - import qualified Control.Monad.Trans.State as MS -import Control.Monad.IO.Class (liftIO, ) +import qualified Control.Monad.Trans.Class as MT import Control.Monad (forM, ) +import Control.Applicative ((<$>)) import qualified Data.Sequence as Seq +import qualified Data.Array as Array import Data.Sequence (Seq, ViewL((:<)), (><), ) - - -data Config = - Config { - rows, columns :: Int, - texts :: [[String]], - pitches :: [Event.Pitch] - } - -makeConfig :: [[String]] -> [Event.Pitch] -> Config -makeConfig ts ps = - Config { - rows = length ts, - columns = maximum (map length ts), - texts = ts, - pitches = ps - } - -config4x4, config4x4sg, config4x6sg, config6x6sg :: Config -config4x4 = - makeConfig - (map (\r -> map (\c -> [r,c]) ['0'..'3']) ['A'..'D']) - (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12]) - -config4x4sg = - makeConfig - (map (map (:[])) ["SPR*", "*ACH", "GIT*", "*TER"]) - (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12]) - -config4x6sg = - makeConfig - (map (map (:[])) $ concat $ replicate 2 ["SPRACH", "GITTER"]) - (map (Event.Pitch . (60+)) [0..11]) - -config6x6sg = - makeConfig - (map (map (:[])) $ concat $ replicate 3 ["SPRACH", "GITTER"]) - (map (Event.Pitch . (60+)) [0..17]) +import Data.Array ((!)) +import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef, ) pick :: Int -> Seq a -> (a, Seq a) @@ -68,6 +33,15 @@ Seq.EmptyL -> error "pick: index too large" a :< rest -> (a, prefix >< rest) +shuffle :: (Rnd.RandomGen g) => g -> [a] -> [a] +shuffle g xs = + flip MS.evalState g $ + flip MS.evalStateT (Seq.fromList xs) $ + forM (takeWhile (>=0) $ tail $ iterate (subtract 1) (length xs)) $ \maxN -> do + n <- MT.lift $ MS.state $ Rnd.randomR (0, maxN) + MS.state $ pick n + + data Player = PlayerA | PlayerB switchPlayer :: Player -> Player @@ -85,14 +59,23 @@ " button!" -makeGUI :: Config -> Sequencer -> IO () +shufflePitches :: Config.T -> IO (Array.Array (Int, Int) Event.Pitch) +shufflePitches cfg = do + seed <- Rnd.randomIO + return $ + Array.listArray + ((0, 0), (Config.rows cfg - 1, Config.columns cfg - 1)) + (shuffle (Rnd.mkStdGen seed) ((\ps -> ps++ps) $ Config.pitches cfg)) + +makeGUI :: Config.T -> MIDI.Sequencer -> IO () makeGUI cfg sequ = do f <- WX.frame [text := "Midimory"] p <- WX.panel f [] + pitches <- newIORef =<< shufflePitches cfg selected <- newIORef Nothing player <- newIORef PlayerA message <- WX.staticText p [ text := makeMessage PlayerA 0 ] - let maxScore = div (rows cfg * columns cfg) 2 + let maxScore = div (Config.rows cfg * Config.columns cfg) 2 scoreA <- WX.vgauge p maxScore [] scoreB <- WX.vgauge p maxScore [] let playerScore pl = @@ -111,17 +94,13 @@ GT -> [PlayerA] EQ -> [PlayerA, PlayerB] matrix <- - flip MS.evalStateT ((\ps -> ps >< ps) $ Seq.fromList $ pitches cfg) $ - forM (texts cfg) $ \ln -> forM ln $ \c -> do - pitch <- do - maxN <- MS.gets Seq.length - n <- liftIO $ Rnd.randomRIO (0, maxN - 1) - MS.StateT (return . pick n) - liftIO $ do - b <- WX.button p [ text := c ] + forM (zip [0..] (Config.texts cfg)) $ \(r,ln) -> + forM (zip [0..] ln) $ \(c,label) -> do + b <- WX.button p [ text := label ] set b [ on command := do - sendNote sequ pitch + pitch <- (! (r,c)) <$> readIORef pitches + MIDI.sendNote sequ pitch mfirst <- readIORef selected case mfirst of Nothing -> do @@ -152,6 +131,18 @@ _ -> "Game Over! Stalemate!" ] ] return b + restart <- + WX.button p [ + text := "Restart", + on command := do + mapM_ (mapM_ (\b -> set b [ WX.enabled := True ])) matrix + set scoreA [ selection := 0 ] + set scoreB [ selection := 0 ] + set message [ text := makeMessage PlayerA 0 ] + writeIORef selected Nothing + writeIORef player PlayerA + writeIORef pitches =<< shufflePitches cfg + ] quit <- WX.button p [text := "Quit", on command := close f] set f [layout := container p $ margin 10 $ @@ -159,9 +150,9 @@ WX.vfill (widget scoreA) : (column 5 $ WX.hfill (widget message) : - WX.grid (columns cfg) (rows cfg) + WX.grid (Config.columns cfg) (Config.rows cfg) (map (map (WX.fill . widget)) matrix) : - WX.hfill (widget quit) : + row 5 [WX.hfill (widget restart), WX.hfill (widget quit)] : []) : WX.vfill (widget scoreB) : [] @@ -169,5 +160,8 @@ main :: IO () -main = - withSequencer "Midimory" $ WX.start . makeGUI config4x4 +main = do + (config, (dests,chan)) <- Option.multiArgs "Concentration game for tones" + MIDI.withSequencer "Midimory" chan $ \sequ -> do + mapM_ (MIDI.parseAndConnect sequ) dests + WX.start $ makeGUI config sequ diff --git a/src/Option.hs b/src/Option.hs new file mode 100644 --- /dev/null +++ b/src/Option.hs @@ -0,0 +1,57 @@ +module Option where + +import qualified Configuration as Config + +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified System.Exit as Exit +import qualified System.IO as IO + +import qualified Options.Applicative as OP + +import qualified Control.Functor.HT as FuncHT +import Control.Applicative ((<*>), ) + +import Data.Bool.HT (if') +import Data.Monoid ((<>)) + + +exitFailureMsg :: String -> IO a +exitFailureMsg msg = do + IO.hPutStrLn IO.stderr msg + Exit.exitFailure + +parseChannel :: String -> Either String Event.Channel +parseChannel str = + case reads str of + [(ch, "")] -> + if' (ch<0) (Left "negative MIDI channel") $ + if' (ch>=16) (Left "MIDI channel larger than 15") $ + Right $ Event.Channel $ fromInteger ch + _ -> Left "MIDI channel must be a number" + +parseArgs :: OP.Parser (Either String Config.T, ([String], Event.Channel)) +parseArgs = + OP.liftA2 (,) Config.option $ + OP.liftA2 (,) + (OP.many $ OP.strOption $ + OP.short 'p' <> + OP.long "connect-to" <> + OP.metavar "ADDRESS" <> + OP.help "Connect with synthesizer at startup") + (OP.option (OP.eitherReader parseChannel) $ + OP.long "midi-channel" <> + OP.value (Event.Channel 0) <> + OP.metavar "CHANNEL" <> + OP.help "Send on a certain MIDI channel (default: 0)") + +info :: String -> OP.Parser a -> OP.ParserInfo a +info desc parser = + OP.info + (OP.helper <*> parser) + (OP.fullDesc <> OP.progDesc desc) + +multiArgs :: String -> IO (Config.T, ([String], Event.Channel)) +multiArgs desc = do + FuncHT.mapFst (either exitFailureMsg return) + =<< OP.execParser (info desc parseArgs)