midimory (empty) → 0.0
raw patch · 5 files changed
+329/−0 lines, 5 filesdep +alsa-coredep +alsa-seqdep +basesetup-changed
Dependencies added: alsa-core, alsa-seq, base, containers, random, transformers, wx, wxcore
Files
- LICENSE +31/−0
- Setup.lhs +8/−0
- midimory.cabal +56/−0
- src/MIDI.hs +61/−0
- src/Main.hs +173/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2011, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of contributors may not be used to endorse or promote+ products derived from this software without specific prior+ written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ midimory.cabal view
@@ -0,0 +1,56 @@+Name: midimory+Version: 0.0+Maintainer: Henning Thielemann <alsa@henning-thielemann.de>+Author: Henning Thielemann <alsa@henning-thielemann.de>+Category: Sound, Music, Game, GUI+License: BSD3+License-file: LICENSE+-- Homepage: http://www.haskell.org/haskellwiki/ALSA+Stability: Experimental+Build-Type: Simple+Cabal-Version: >= 1.8+Synopsis: A Memory-like (Concentration, Pairs, ...) game for tones+Description:+ This is a game like Memory but with tones instead of images.+ .+ There is a grid of buttons and each button plays a tone when pressed.+ 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.+ .+ In order to play the tones+ you must connect it to a hardware or software synthesizer+ like Timidity or FluidSynth.+ .+ > timidity -A300 -iA -B4,4+ .+ Then start the midimory game and+ connect the game to the synthesizer.+ .+ > aconnect Midimory TiMidity++Source-Repository head+ type: darcs+ location: http://code.haskell.org/~thielema/midimory/++Source-Repository this+ type: darcs+ tag: 0.0+ location: http://code.haskell.org/~thielema/midimory/++Executable midimory+ Main-Is: Main.hs+ Other-Modules: MIDI+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Build-Depends:+ wx >=0.12.1.6 && <0.13,+ wxcore >=0.12.1.6 && <0.13,+ alsa-seq >=0.6 && <0.7,+ alsa-core >=0.5 && <0.6,+ random >=1.0 && <1.1,+ transformers >=0.2 && <0.4,+ containers >=0.2 && <0.5,+ base >=3 && <5
+ src/MIDI.hs view
@@ -0,0 +1,61 @@+module MIDI where++import qualified Sound.ALSA.Sequencer.Address as Addr+import qualified Sound.ALSA.Sequencer.Client as Client+import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Sound.ALSA.Sequencer.Queue as Queue+import qualified Sound.ALSA.Sequencer.Time as Time+import qualified Sound.ALSA.Sequencer.RealTime as RealTime+import qualified Sound.ALSA.Sequencer as SndSeq+import qualified Sound.ALSA.Exception as AlsaExc++import qualified System.IO as IO+++{-+The queue is required by the ANote event type.+-}+data Sequencer =+ Sequencer (SndSeq.T SndSeq.OutputMode) Queue.T Port.T+++sendNote :: Sequencer -> Event.Pitch -> IO ()+sendNote h p = do+ sendEvent h $+ Event.NoteEv Event.ANote $ Event.Note {+ Event.noteChannel = Event.Channel 0,+ Event.noteNote = p,+ Event.noteVelocity = Event.normalVelocity,+ Event.noteOffVelocity = Event.normalVelocity,+ Event.noteDuration = Event.Duration 1000+ }+++sendEvent ::+ Sequencer -> Event.Data -> IO ()+sendEvent (Sequencer h q p) ev = do+ c <- Client.getId h+ _ <-+ Event.outputDirect h $+ (Event.simple (Addr.Cons c p) ev) {+ Event.queue = q,+ Event.time = Time.consRel $ Time.Real $ RealTime.fromDouble 0+ }+ return ()+++withSequencer ::+ String -> (Sequencer -> IO ()) -> IO ()+withSequencer name act =+ flip AlsaExc.catch+ (\e -> IO.hPutStrLn IO.stderr $ "alsa_exception: " ++ AlsaExc.show e) $ do+ SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do+ Client.setName h name+ Queue.with h $ \q -> do+ Queue.control h q Event.QueueStart Nothing+ _ <- Event.drainOutput h+ Port.withSimple h "inout"+ (Port.caps [Port.capRead, Port.capSubsRead,+ Port.capWrite, Port.capSubsWrite]) Port.typeApplication $ \ port -> do+ act $ Sequencer h q port
+ src/Main.hs view
@@ -0,0 +1,173 @@+module Main where++import MIDI++import qualified Sound.ALSA.Sequencer.Event as Event++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 Control.Monad (forM, )++import qualified Data.Sequence as Seq+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])+++pick :: Int -> Seq a -> (a, Seq a)+pick n as =+ let (prefix, suffix) = Seq.splitAt n as+ in case Seq.viewl suffix of+ Seq.EmptyL -> error "pick: index too large"+ a :< rest -> (a, prefix >< rest)++data Player = PlayerA | PlayerB++switchPlayer :: Player -> Player+switchPlayer PlayerA = PlayerB+switchPlayer PlayerB = PlayerA++formatPlayer :: Player -> String+formatPlayer PlayerA = "Player A"+formatPlayer PlayerB = "Player B"++makeMessage :: Player -> Int -> String+makeMessage player count =+ formatPlayer player ++ ": Hit " +++ (if count == 0 then "first" else "second") +++ " button!"+++makeGUI :: Config -> Sequencer -> IO ()+makeGUI cfg sequ = do+ f <- WX.frame [text := "Midimory"]+ p <- WX.panel f []+ selected <- newIORef Nothing+ player <- newIORef PlayerA+ message <- WX.staticText p [ text := makeMessage PlayerA 0 ]+ let maxScore = div (rows cfg * columns cfg) 2+ scoreA <- WX.vgauge p maxScore []+ scoreB <- WX.vgauge p maxScore []+ let playerScore pl =+ case pl of+ PlayerA -> scoreA+ PlayerB -> scoreB+ isGameOver = do+ a <- get scoreA selection+ b <- get scoreB selection+ return $+ if a+b < maxScore+ then []+ else+ case compare a b of+ LT -> [PlayerB]+ 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 ]+ set b [+ on command := do+ sendNote sequ pitch+ mfirst <- readIORef selected+ case mfirst of+ Nothing -> do+ writeIORef selected $ Just (b, pitch)+ set b [ WX.enabled := False ]+ pl <- readIORef player+ set message [ text := makeMessage pl 1 ]+ Just (firstButton, firstPitch) -> do+ writeIORef selected Nothing+ pl <- readIORef player+ if firstPitch == pitch+ then do+ set b [ WX.enabled := False ]+ let score = playerScore pl+ n <- get score selection+ set score [ selection := succ n ]+ else do+ set firstButton [ WX.enabled := True ]+ modifyIORef player switchPlayer+ newpl <- readIORef player+ gameOver <- isGameOver+ set message [ text :=+ case gameOver of+ [] -> makeMessage newpl 0+ [winner] ->+ "Game Over! The winner is " +++ formatPlayer winner+ _ -> "Game Over! Stalemate!" ]+ ]+ return b+ quit <- WX.button p [text := "Quit", on command := close f]+ set f [layout :=+ container p $ margin 10 $+ row 5 $+ WX.vfill (widget scoreA) :+ (column 5 $+ WX.hfill (widget message) :+ WX.grid (columns cfg) (rows cfg)+ (map (map (WX.fill . widget)) matrix) :+ WX.hfill (widget quit) :+ []) :+ WX.vfill (widget scoreB) :+ []+ ]+++main :: IO ()+main =+ withSequencer "Midimory" $ WX.start . makeGUI config4x4