midimory 0.0.0.3 → 0.0.1
raw patch · 5 files changed
+291/−73 lines, 5 filesdep +arraydep +optparse-applicativedep +utility-ht
Dependencies added: array, optparse-applicative, utility-ht
Files
- midimory.cabal +18/−7
- src/Configuration.hs +149/−0
- src/MIDI.hs +14/−7
- src/Main.hs +53/−59
- src/Option.hs +57/−0
midimory.cabal view
@@ -1,5 +1,5 @@ Name: midimory-Version: 0.0.0.3+Version: 0.0.1 Maintainer: Henning Thielemann <alsa@henning-thielemann.de> Author: Henning Thielemann <alsa@henning-thielemann.de> 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
+ src/Configuration.hs view
@@ -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
src/MIDI.hs view
@@ -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
src/Main.hs view
@@ -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
+ src/Option.hs view
@@ -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)