diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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/ diff --git a/Paths_hback.hs b/Paths_hback.hs deleted file mode 100644 --- a/Paths_hback.hs +++ /dev/null @@ -1,8 +0,0 @@ - -module Paths_hback where - -getDataFileName :: FilePath -> IO FilePath -getDataFileName = return - -getDataDir :: IO FilePath -getDataDir = return "." diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -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: diff --git a/hback.cabal b/hback.cabal --- a/hback.cabal +++ b/hback.cabal @@ -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 @@ -11,20 +11,29 @@ Description: N-back memory game using gtk2hs. . Instructions on installation and gameplay available at: - -Homepage: http://pithyless.com/blog/2008/05/18/hback-haskell-n-back-memory-game/ + +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 diff --git a/hback.glade b/hback.glade --- a/hback.glade +++ b/hback.glade @@ -1,10 +1,10 @@ - + - 300 - 400 + 308 + 416 True @@ -52,20 +52,20 @@ 4 True - + True True True - Sound + Graphic - "A" 0 - + True True True - Graphic + Sound - "L" 0 diff --git a/hback.hs b/hback.hs --- a/hback.hs +++ b/hback.hs @@ -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 "" w h) + ++ (printf "" w h) + ++ (printf "" (c * 6)) + ++ "[Paused]" + ++ "" + 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 "" w h) + ++ (printf "" w h) + ++ (printf "" marg line x2 y2) + ++ squareString + ++ (printf "" 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 ("") + 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) diff --git a/sounds/a.wav b/sounds/a.wav deleted file mode 100644 Binary files a/sounds/a.wav and /dev/null differ diff --git a/sounds/b.wav b/sounds/b.wav deleted file mode 100644 Binary files a/sounds/b.wav and /dev/null differ diff --git a/sounds/c.wav b/sounds/c.wav new file mode 100644 Binary files /dev/null and b/sounds/c.wav differ diff --git a/sounds/d.wav b/sounds/d.wav deleted file mode 100644 Binary files a/sounds/d.wav and /dev/null differ diff --git a/sounds/e.wav b/sounds/e.wav deleted file mode 100644 Binary files a/sounds/e.wav and /dev/null differ diff --git a/sounds/f.wav b/sounds/f.wav deleted file mode 100644 Binary files a/sounds/f.wav and /dev/null differ diff --git a/sounds/g.wav b/sounds/g.wav deleted file mode 100644 Binary files a/sounds/g.wav and /dev/null differ diff --git a/sounds/h.wav b/sounds/h.wav Binary files a/sounds/h.wav and b/sounds/h.wav differ diff --git a/sounds/k.wav b/sounds/k.wav Binary files a/sounds/k.wav and b/sounds/k.wav differ diff --git a/sounds/l.wav b/sounds/l.wav new file mode 100644 Binary files /dev/null and b/sounds/l.wav differ diff --git a/sounds/q.wav b/sounds/q.wav new file mode 100644 Binary files /dev/null and b/sounds/q.wav differ diff --git a/sounds/r.wav b/sounds/r.wav new file mode 100644 Binary files /dev/null and b/sounds/r.wav differ diff --git a/sounds/s.wav b/sounds/s.wav new file mode 100644 Binary files /dev/null and b/sounds/s.wav differ diff --git a/sounds/t.wav b/sounds/t.wav Binary files a/sounds/t.wav and b/sounds/t.wav differ