hback 0.0.2 → 0.0.3
raw patch · 20 files changed
+185/−118 lines, 20 filesdep +filepathdep +svgcairodep +timedep ~basebinary-added
Dependencies added: filepath, svgcairo, time, unix
Dependency ranges changed: base
Files
- Makefile +17/−2
- Paths_hback.hs +0/−8
- README.txt +5/−3
- hback.cabal +23/−14
- hback.glade +7/−7
- hback.hs +133/−84
- sounds/a.wav binary
- sounds/b.wav binary
- sounds/c.wav binary
- sounds/d.wav binary
- sounds/e.wav binary
- sounds/f.wav binary
- sounds/g.wav binary
- sounds/h.wav binary
- sounds/k.wav binary
- sounds/l.wav binary
- sounds/q.wav binary
- sounds/r.wav binary
- sounds/s.wav binary
- sounds/t.wav binary
Makefile view
@@ -3,9 +3,22 @@ configure: runhaskell Setup.lhs configure-trial: configure- ghc --make hback.hs -o hback +# If configuring for a trial, we configure as user (perhaps not necessary since+# we use copy instead of install) and specify the hback project directory as the+# prefix to use. When installed (using install or copy), this results in the+# hback executable ending up in the bin subdirectory of the hback project.+configure_trial:+ runhaskell Setup.lhs configure --user --prefix=${PWD}++# Make a trial version of the app that will be available at ./bin/hback. We use+# copy rather than install here in order to register the app (which install+# does in either the user-specific (if --user) package database or the+# global database).+trial: configure_trial+ runhaskell Setup.lhs build+ runhaskell Setup.lhs copy+ build: configure runhaskell Setup.lhs build install:@@ -16,3 +29,5 @@ rm -f *.hi rm -f *.o rm -rf ./dist/+ rm -rf ./bin/+ rm -rf ./share/
− Paths_hback.hs
@@ -1,8 +0,0 @@--module Paths_hback where--getDataFileName :: FilePath -> IO FilePath-getDataFileName = return--getDataDir :: IO FilePath-getDataDir = return "."
README.txt view
@@ -1,6 +1,8 @@ Based on a recent [research paper](http://www.pnas.org/cgi/content/abstract/0801268105v1) that claims fluid intelligence could be improved by training working memory, I wrote up a dual n-back test memory game in Haskell and gtk2hs. This is an alpha release: all comments are most welcome. +Project homepage: [http://hback.googlecode.com/]+ Gameplay -------- @@ -13,13 +15,13 @@ Installation ------------ - % tar -xzf hback-0.0.tar.gz- % cd hback-0.0+ % tar -xzf hback-x.y.tar.gz+ % cd hback-x.y Game can be played without system-wide installation: % make trial- % ./hback+ % ./bin/hback If you like what you see, feel free to install it:
hback.cabal view
@@ -1,7 +1,7 @@ Name: hback-Version: 0.0.2-Build-Depends: base,haskell98,process,glade,gtk,cairo+Version: 0.0.3 Build-type: Simple+cabal-version: >= 1.2 License: BSD3 License-file: LICENSE Author: Norbert Wojtowicz <wojtowicz.norbert@gmail.com>@@ -11,20 +11,29 @@ Description: N-back memory game using gtk2hs. . Instructions on installation and gameplay available at:- <http://pithyless.com/blog/2008/05/18/hback-haskell-n-back-memory-game/>-Homepage: http://pithyless.com/blog/2008/05/18/hback-haskell-n-back-memory-game/+ <http://hback.googlecode.com/>+Homepage: http://hback.googlecode.com/ Extra-Source-Files: README.txt,- Makefile,- Paths_hback.hs+ Makefile Data-Files: hback.glade,- sounds/a.wav,- sounds/b.wav,- sounds/d.wav,- sounds/e.wav,- sounds/f.wav,- sounds/g.wav,+ sounds/c.wav, sounds/h.wav, sounds/k.wav,+ sounds/l.wav,+ sounds/q.wav,+ sounds/r.wav,+ sounds/s.wav, sounds/t.wav-Executable: hback-Main-is: hback.hs++flag small_base+ description: Choose the new smaller, split-up base package.++executable hback+ Main-is: hback.hs++ if flag(small_base)+ build-depends: base >= 3, unix, time+ else+ build-depends: base < 3++ build-depends: haskell98, process, filepath, glade, gtk, cairo, svgcairo
hback.glade view
@@ -1,10 +1,10 @@ <?xml version="1.0" encoding="UTF-8" standalone="no"?> <!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">-<!--Generated with glade3 3.4.4 on Sat May 17 11:21:15 2008 -->+<!--Generated with glade3 3.4.4 on Thu Jun 5 11:25:54 2008 --> <glade-interface> <widget class="GtkWindow" id="hback">- <property name="width_request">300</property>- <property name="height_request">400</property>+ <property name="width_request">308</property>+ <property name="height_request">416</property> <child> <widget class="GtkVBox" id="vbox1"> <property name="visible">True</property>@@ -52,20 +52,20 @@ <property name="border_width">4</property> <property name="homogeneous">True</property> <child>- <widget class="GtkToggleButton" id="audioBtn">+ <widget class="GtkToggleButton" id="visualBtn"> <property name="visible">True</property> <property name="can_focus">True</property> <property name="receives_default">True</property>- <property name="label" translatable="yes">Sound</property>+ <property name="label" translatable="yes">Graphic - "A"</property> <property name="response_id">0</property> </widget> </child> <child>- <widget class="GtkToggleButton" id="visualBtn">+ <widget class="GtkToggleButton" id="audioBtn"> <property name="visible">True</property> <property name="can_focus">True</property> <property name="receives_default">True</property>- <property name="label" translatable="yes">Graphic</property>+ <property name="label" translatable="yes">Sound - "L"</property> <property name="response_id">0</property> </widget> <packing>
hback.hs view
@@ -11,21 +11,25 @@ module Main where +import Debug.Trace+ import System.Exit import IO import System.Cmd (system) import Directory (getDirectoryContents)-import System.Environment (getArgs)+import System.Environment (getArgs, getEnv)+import System.FilePath (joinPath) import GHC.Conc (threadDelay) import System.Posix.Unistd (usleep) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.List (intersperse)-import Text.Printf (hPrintf)+import Text.Printf import Control.Monad import Graphics.UI.Gtk hiding (fill) import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.Glade import Graphics.Rendering.Cairo+import Graphics.Rendering.Cairo.SVG import Data.IORef import Random@@ -38,7 +42,7 @@ type Audio = FilePath data Prediction = None | TruePositive | FalsePositive | FalseNegative | TrueNegative- deriving (Eq, Show)+ deriving (Eq, Show, Enum) type Level = Int data Timer = Timer Frac Total type Frac = Int@@ -84,21 +88,17 @@ newTimer = Timer 0 timerFrac imageList :: IO [Visual]-imageList = return $ [(a,b) | a <- [0..2], b <- [0..2]]+imageList = return $ remove (1,1) [(a,b) | a <- [0..2], b <- [0..2]] soundList :: IO [Audio] soundList = do d <- getDataDir- let dir = d ++ "/sounds/"+ let dir = joinPath [d, "sounds/"] l <- getDirectoryContents dir- return $ map (dir ++) $ filter (/= ".") $ filter (/= "..") l+ return $ map (dir ++) $ filter (\f -> tail f == ".wav") l predictionToInt :: Prediction -> Int-predictionToInt p = case (lookup p preds) of- Just n -> n- Nothing -> error "Something went terribly wrong (predictionToInt)"- where- preds = zip [None, TruePositive, FalsePositive, FalseNegative, TrueNegative] [0..]+predictionToInt = fromEnum -- ========== Scoring ========== @@ -119,14 +119,17 @@ num = (s v) + (s a) den = fromIntegral (2 * length v) :: Double --- |chooseNextN old vPredictions aPredictions returns the next game level--- based on performance on the previous game; current limits are (< 0.35) and (>= 0.75)-chooseNextN :: Int -> [Prediction] -> [Prediction] -> Int-chooseNextN n v a- | s >= 0.75 = n + 1- | s < 0.35 = max 1 $ n - 1- | otherwise = n- where s = gameScore v a+-- |chooseNextLevel old vPredictions aPredictions returns the next game level+-- based on performance on the previous game; Same as protocol in [Paper]+chooseNextLevel :: Int -> [Prediction] -> [Prediction] -> Int+chooseNextLevel n v a+ | m1 < 3 && m2 < 3 = inc n+ | m1 + m2 > 5 = max 1 $ dec n+ | otherwise = n+ where+ m1 = miss v+ m2 = miss a+ miss xs = length $ filter (\x -> x == FalseNegative || x == FalsePositive) xs -- |score trueValue guessValue returns the appropriate logical prediction score :: Bool -> Bool -> Prediction@@ -178,25 +181,42 @@ startNewGame stateRef level = do imgList <- imageList sndList <- soundList- visuals <- genStim imgList [] level (level + blockSize)- audios <- genStim sndList [] level (level + blockSize)+ preds <- shuffledPredictions level+ visuals <- matchStim imgList level (map fst preds) []+ audios <- matchStim sndList level (map snd preds) [] let game = Game level visuals audios [] [] (State games _ gui tL p) <- readIORef stateRef writeIORef stateRef $ State (game:games) newTimer gui tL p labelSetText (guiLevelLabel gui) $ show level ++ "-Back Test" tmhandle <- timeoutAdd (timerInit stateRef) 500 return ()- where- genStim :: Ord a => [a] -> [a] -> Int -> Int -> IO ([(a, Maybe Bool)])- genStim lst hist n cnt- | cnt < 1 = return []- | otherwise = do- c <- if (length hist < n)- then (randomElem lst Nothing)- else (randomElem lst (Just (head hist)))- lst' <- genStim lst (hist ++ [fst c]) n (cnt - 1)- return $ c : lst' +makePredictions = take 2 (repeat (Just True, Just True)) +++ take 4 (repeat (Just True, Just False)) +++ take 4 (repeat (Just False, Just True)) +++ take (blockSize - 10) (repeat (Just False, Just False))++shuffledPredictions level = do+ let preds = makePredictions+ rands <- getRandomDecList ((length preds) - 1)+ return $ take level (repeat (Nothing, Nothing)) ++ shuffle preds rands++matchStim :: Ord a => [a] -> Int -> [Maybe Bool] -> [(a, Maybe Bool)] -> IO [(a, Maybe Bool)]+matchStim _ _ [] acc = return $ reverse acc+matchStim orig level (p:ps) acc = do+ e <- case p of+ Nothing -> do+ e' <- randomElem orig+ return (e', Nothing)+ Just True -> do+ let e = fst $ head $ drop (dec level) acc+ return (e, Just True)+ Just False -> do+ let e = fst $ head $ drop (dec level) acc+ e' <- randomElem (remove e orig)+ return (e', Just False)+ matchStim orig level ps (e : acc)+ endGame :: IORef State -> IO () endGame stateRef = do state <- readIORef stateRef@@ -237,13 +257,12 @@ | statePaused state = -- game is paused return True | turn >= blockSize + gameLevel game = do -- current game finished+ logGame stateRef if (length games >= totalGames state) then do- logGame stateRef endGame stateRef else do- logGame stateRef- startNewGame stateRef (chooseNextN (gameLevel game) (gameVPreds game) (gameAPreds game))+ startNewGame stateRef (chooseNextLevel (gameLevel game) (gameVPreds game) (gameAPreds game)) return False | otherwise = do let (vZ, vB) = gameVisuals game !! turn@@ -287,14 +306,12 @@ False -> renderImage (guiDrawArea gui) renderPause writeIORef stateRef $ State g t gui tt $ not p return True- Nothing -> case keyName of- "Left" -> do- flipToggle $ guiAButton gui- return True- "Right" -> do- flipToggle $ guiVButton gui- return True- _ -> return False+ Just 'l' -> do+ flipToggle $ guiAButton gui+ return True+ Just 'a' -> do+ flipToggle $ guiVButton gui+ return True _ -> return False where flipToggle btn = do@@ -329,35 +346,48 @@ h = fromIntegral h' :: Double renderPause :: Int -> Int -> Render ()-renderPause w' h' = do- save- setSourceRGB 0 0 0- paintWithAlpha 0.5- setSourceRGB 1 1 1- moveTo (w/2 - 80) (h/2)- setFontSize 40- showText "Paused"- where w = fromIntegral w' :: Double- h = fromIntegral h' :: Double+renderPause wU hU = do+ svgRenderFromString s+ where+ s = (printf "<svg width=\"%d\" height=\"%d\">" w h)+ ++ (printf "<rect style=\"fill:black\" opacity=\"0.7\" width=\"%d\" height=\"%d\" x=\"0\" y=\"0\" />" w h)+ ++ (printf "<text x=\"%d\" y=\"%d\"" ((w `div` 2) - (c*13)) ((h `div` 2) + c))+ ++ (printf " font-family=\"Verdana\" font-size=\"%d\" fill=\"orange\" >" (c * 6))+ ++ "[Paused]"+ ++ "</text></svg>"+ w = min wU hU+ h = w -- make sure w and h make square+ c = (w `div` 150) * 5 -- a multiplier when window gets resized renderBlank :: Int -> Int -> Render ()-renderBlank _ _ = do- setSourceRGB 0 0 0- paint+renderBlank w h = renderCross w h Nothing renderRect :: Visual -> Int -> Int -> Render ()-renderRect (x',y') w' h' = do- setSourceRGB 0 0 0- paint- rectangle x y (w / 3) (h /3 )- setSourceRGB 0 0 1- fill- where- w = fromIntegral w' :: Double- h = fromIntegral h' :: Double- x = fromIntegral x' * (w / 3) :: Double- y = fromIntegral y' * (h / 3) :: Double- +renderRect (x,y) w h = renderCross w h $ Just (x,y)++renderCross wU hU m =+ svgRenderFromString s+ where+ s = (printf "<svg width=\"%d\" height=\"%d\">" w h)+ ++ (printf "<rect style=\"fill:black\" width=\"%d\" height=\"%d\" x=\"0\" y=\"0\" />" w h)+ ++ (printf "<rect style=\"fill:white\" width=\"%d\" height=\"%d\" x=\"%d\" y=\"%d\" />" marg line x2 y2)+ ++ squareString+ ++ (printf "<rect style=\"fill:white\" width=\"%d\" height=\"%d\" x=\"%d\" y=\"%d\" /></svg>" line marg y2 x2)+ w = min wU hU+ h = w -- make sure w and h make square+ sq = w `div` 3+ marg = sq `div` 10+ line = marg * 8+ x2 = sq + (sq `div` 2) - (marg `div` 2)+ y2 = sq + marg+ squareString = case m of+ Nothing -> ""+ Just (x, y) -> let x1 = marg + (sq * x) in+ let y1 = marg + (sq * y) in+ printf ("<rect style=\"fill:white\" width=\"%d\" height=\"%d\" "+ ++ "x=\"%d\" y=\"%d\" />")+ line line x1 y1+ renderImage :: DrawingArea -> (Int -> Int -> Render ()) -> IO () renderImage drawArea img = do (w,h) <- widgetGetSize drawArea@@ -372,12 +402,18 @@ -- ========== Utils ========== +getLogFile :: IO FilePath+getLogFile = do+ l <- getEnv "HOME"+ return $ joinPath [l, ".hback.scores.db"]+ logInitGame :: IO () logInitGame = do unless (turnOffLogging) (do t <- getPOSIXTime- bracket (openFile "user_score_history.db" AppendMode) hClose+ f <- getLogFile+ bracket (openFile f AppendMode) hClose (\h -> hPrintf h "%s\n" $ show t)) logGame :: IORef State -> IO ()@@ -385,8 +421,9 @@ unless (turnOffLogging) (do state <- readIORef stateRef+ f <- getLogFile let game = head $ stateGames state- bracket (openFile "user_score_history.db" AppendMode) hClose+ bracket (openFile f AppendMode) hClose (\h -> do hPrintf h "Level %d\n%s\n%s\n" (gameLevel game) (concat (intersperse " " (map (show . predictionToInt) (gameVPreds game)))) (concat (intersperse " " (map (show . predictionToInt) (gameAPreds game))))))@@ -394,18 +431,30 @@ inc :: Int -> Int inc = (1+) --- |randomElem lst c : 50% chance it returns c; else return random elem from lst (equal probabilities)-randomElem :: Ord a => [a] -> Maybe a -> IO (a, Maybe Bool)-randomElem lst c' = do- case c' of- Nothing -> aux lst Nothing- Just c -> do- x <- getStdRandom (randomR (0.0, 1.0)) :: IO Double- case (x <= 0.5) of- True -> return (c, Just True)- False -> aux (filter (c /=) lst) $ Just False- where- aux [] _ = error "randomElem: List should not be empty"- aux l v = do- y <- getStdRandom (randomR (1, length l))- return $ (l !! (y - 1), v)+dec :: Int -> Int+dec n = n - 1++-- naive list shuffle+-- shuffle elems choices. where: length choices == length elems - 1+shuffle :: [a] -> [Int] -> [a]+shuffle [] _ = []+shuffle [e] [] = [e]+shuffle elems (x:xs)+ | x >= (length elems) = error "shuffle: index too large"+ | otherwise = let (a,(e:rest)) = splitAt x elems+ in e : shuffle (a ++ rest) xs++getRandomDecList :: Int -> IO [Int]+getRandomDecList 0 = return []+getRandomDecList n = do+ r <- getStdRandom $ randomR (0, n)+ rs <- getRandomDecList $ dec n+ return $ r : rs++randomElem :: [a] -> IO a+randomElem lst = do+ i <- getStdRandom (randomR (0, dec (length lst)))+ return $ lst !! i++remove :: Ord a => a -> [a] -> [a]+remove a = filter (/= a)
− sounds/a.wav
binary file changed (13484 → absent bytes)
− sounds/b.wav
binary file changed (19884 → absent bytes)
+ sounds/c.wav view
binary file changed (absent → 19884 bytes)
− sounds/d.wav
binary file changed (20524 → absent bytes)
− sounds/e.wav
binary file changed (17964 → absent bytes)
− sounds/f.wav
binary file changed (20204 → absent bytes)
− sounds/g.wav
binary file changed (19884 → absent bytes)
sounds/h.wav view
binary file changed (21484 → 24364 bytes)
sounds/k.wav view
binary file changed (20844 → 23084 bytes)
+ sounds/l.wav view
binary file changed (absent → 19884 bytes)
+ sounds/q.wav view
binary file changed (absent → 23724 bytes)
+ sounds/r.wav view
binary file changed (absent → 20524 bytes)
+ sounds/s.wav view
binary file changed (absent → 24684 bytes)
sounds/t.wav view
binary file changed (19244 → 19564 bytes)