hback 0.0.1 → 0.0.2
raw patch · 2 files changed
+335/−184 lines, 2 files
Files
- hback.cabal +1/−1
- hback.hs +334/−183
hback.cabal view
@@ -1,5 +1,5 @@ Name: hback-Version: 0.0.1+Version: 0.0.2 Build-Depends: base,haskell98,process,glade,gtk,cairo Build-type: Simple License: BSD3
hback.hs view
@@ -1,9 +1,26 @@+{-|+ hback is a dual n-back memory test based primarily on the work of:+ Jaeggi, Buschkuehl, et al. (2008)+ Improving Fluid Intelligence With Training on Working Memory.+ Proceedings of the National Academy of Sciences of the United States of America, 105(19), 6829-6833++ Any reference in the comments to [Paper] refers to the above work.+-}++{-# OPTIONS -fbang-patterns #-}+ module Main where import System.Exit+import IO import System.Cmd (system) import Directory (getDirectoryContents) import System.Environment (getArgs)+import GHC.Conc (threadDelay)+import System.Posix.Unistd (usleep)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.List (intersperse)+import Text.Printf (hPrintf) import Control.Monad import Graphics.UI.Gtk hiding (fill) import Graphics.UI.Gtk.General.General@@ -19,23 +36,56 @@ type Visual = (Int, Int) type Audio = FilePath-data TotalScore = TotalScore TotalBlocks [(Int, Score, Score)]- deriving Show-type TotalBlocks = Int--- (TruePositive, FalsePositive, FalseNegative, TrueNegative)-type Score = (Int, Int, Int, Int)-data Stimuli a = Stimuli (Maybe a -> IO a) (Maybe a) [a] Score-data State = State Int (Stimuli Visual) (Stimuli Audio)-data TimerState = Timer Iteration Frac Total-type Iteration = Int++data Prediction = None | TruePositive | FalsePositive | FalseNegative | TrueNegative+ deriving (Eq, Show)+type Level = Int+data Timer = Timer Frac Total type Frac = Int type Total = Int+data Game = Game { gameLevel :: Level,+ gameVisuals :: [(Visual, Maybe Bool)],+ gameAudios :: [(Audio, Maybe Bool)],+ gameVPreds :: [Prediction],+ gameAPreds :: [Prediction]+ } deriving Show+data State = State { stateGames :: [Game],+ stateTimer :: Timer,+ stateGUI :: GUI,+ totalGames :: Int,+ statePaused :: Bool+ }+data GUI = GUI { guiWindow :: Window,+ guiLevelLabel :: Label,+ guiScoreLabel :: Label,+ guiDrawArea :: DrawingArea,+ guiVButton :: ToggleButton,+ guiAButton :: ToggleButton+ } -blockSize = 20- -imageList :: [Visual]-imageList = [(a,b) | a <- [0..2], b <- [0..2]]+turnOffLogging = False +-- |blocksize + n determines how many iterations each "game" takes+-- 20 + n is what [Paper] used+blockSize = 20+-- |timerFrac * timerFreq = 500ms shows stimuli + 2.5s pause ~ 3s per iteration (from [Paper])+timerFrac = 5 -- [0..5] = 6 loops+timerFreq = 500 -- 500 ms+-- |totalNumGames * (blockSize + n) * 3s / 60 =~ Total Gametime+-- Based on [Paper], default is 20 to give about 20 minutes of memory training;+totalNumGames = 20+-- |initLevel determines what N-Back level the game begins with; defaults to 1+initLevel = 1++gameTurn :: Game -> Int+gameTurn g = length $ gameVPreds g+ +newTimer :: Timer+newTimer = Timer 0 timerFrac++imageList :: IO [Visual]+imageList = return $ [(a,b) | a <- [0..2], b <- [0..2]]+ soundList :: IO [Audio] soundList = do d <- getDataDir@@ -43,14 +93,250 @@ l <- getDirectoryContents dir return $ map (dir ++) $ filter (/= ".") $ filter (/= "..") 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..]++-- ========== Scoring ==========++addPredictions :: Game -> Prediction -> Prediction -> Game+addPredictions (Game l v a vp ap) vp' ap' = Game l v a (vp ++ [vp']) (ap ++ [ap'])++realPredictions :: [Prediction] -> [Prediction]+realPredictions = filter (/= None)+ +-- |gamescore vs as takes all visual and audio predictions for a specific and calculates+-- a total score; for now naive score = (TruePositive + TrueNegative) / Total+gameScore :: [Prediction] -> [Prediction] -> Double+gameScore v' a' = num / den+ where+ v = realPredictions v'+ a = realPredictions a'+ s xs = fromIntegral (length (filter (\x -> x == TruePositive || x == TrueNegative) xs)) :: Double+ 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++-- |score trueValue guessValue returns the appropriate logical prediction+score :: Bool -> Bool -> Prediction+score val ans+ | val && ans = TruePositive+ | not val && ans = FalsePositive+ | val && not ans = FalseNegative+ | not val && not ans = TrueNegative+++-- ========== Main ==========+ +printUsage :: IO ()+printUsage = putStrLn "hback b n\n b is the number of tests [default=20]\n n determines the starting n-back test [default=1]"++main = do+ args <- getArgs+ printUsage+ (!totalNumGames', !initLevel') <- case args of+ [] -> return (totalNumGames, initLevel)+ (a:[]) -> return (read a :: Int, initLevel)+ (a:b:[]) -> return ((read a :: Int), (read b :: Int))+ initGUI+ gFile <- getDataFileName "hback.glade"+ windowXmlM <- xmlNew gFile+ let windowXml = case windowXmlM of+ (Just windowXml) -> windowXml+ Nothing -> error "Can't find the glade file \"hback.glade\" in the current directory"+ window <- xmlGetWidget windowXml castToWindow "hback"+ onDestroy window mainQuit++ label <- xmlGetWidget windowXml castToLabel "testLabel"+ scLabel <- xmlGetWidget windowXml castToLabel "scoreLabel"+ img <- xmlGetWidget windowXml castToDrawingArea "drawArea"+ visualBtn <- xmlGetWidget windowXml castToToggleButton "visualBtn"+ audioBtn <- xmlGetWidget windowXml castToToggleButton "audioBtn"++ stateRef <- newIORef $ State [] newTimer+ (GUI window label scLabel img visualBtn audioBtn)+ totalNumGames' False+ onKeyPress window (processEvent stateRef)+ + widgetShowAll window+ logInitGame+ startNewGame stateRef initLevel'+ mainGUI++startNewGame :: IORef State -> Level -> IO ()+startNewGame stateRef level = do+ imgList <- imageList+ sndList <- soundList+ visuals <- genStim imgList [] level (level + blockSize)+ audios <- genStim sndList [] level (level + blockSize)+ 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'++endGame :: IORef State -> IO ()+endGame stateRef = do+ state <- readIORef stateRef+ putStrLn "Game finished"+ sequence_ $ map (\(Game level _ _ vp ap) -> putStrLn ("Level " ++ show level ++ " : " ++ show (gameScore vp ap)))+ $ reverse $ stateGames state+ mainQuit+ exitWith ExitSuccess+ +-- ========== Timers and Events ==========++timerInit :: IORef State -> IO Bool+timerInit stateRef = do+ state <- readIORef stateRef+ timerInit' stateRef state+ where+ timerInit' :: IORef State -> State -> IO Bool+ timerInit' stateRef state@(State _ tm@(Timer t tt) gui _ _)+ | statePaused state = -- game is paused+ return True+ | t == 0 = do+ renderImage (guiDrawArea gui) renderNewGame+ stateTick stateRef+ return True+ | t == tt = do+ tmhandle <- timeoutAdd (timer stateRef) timerFreq+ stateTick stateRef+ return False+ | otherwise = do+ stateTick stateRef+ return True+ +timer :: IORef State -> IO Bool+timer stateRef = do s <- readIORef stateRef+ timer' stateRef s+timer' :: IORef State -> State -> IO Bool+timer' stateRef state@(State games@(game:prevGames) tm@(Timer t tt) gui total paused)+ | statePaused state = -- game is paused+ return True+ | turn >= blockSize + gameLevel game = do -- current game finished+ if (length games >= totalGames state)+ then do+ logGame stateRef+ endGame stateRef+ else do+ logGame stateRef+ startNewGame stateRef (chooseNextN (gameLevel game) (gameVPreds game) (gameAPreds game))+ return False+ | otherwise = do+ let (vZ, vB) = gameVisuals game !! turn+ let (aZ, aB) = gameAudios game !! turn+ case t of+ 0 -> do+ renderImage (guiDrawArea gui) $ renderRect vZ+ playSound aZ+ toggleButtonSetActive (guiVButton gui) False+ toggleButtonSetActive (guiAButton gui) False+ 1 -> do+ renderImage (guiDrawArea gui) renderBlank+ _ -> when (t == tt)+ (do+ (vs', as') <- case (vB, aB) of+ (Just vB', Just aB') -> do+ b1 <- toggleButtonGetActive (guiVButton gui)+ b2 <- toggleButtonGetActive (guiAButton gui)+ return ((score vB' b1), (score aB' b2))+ _ -> return (None, None)+ writeIORef stateRef $ State (addPredictions game vs' as' : prevGames) tm gui total paused)+ stateTick stateRef+ return True+ where+ turn = gameTurn game++stateTick :: IORef State -> IO ()+stateTick stateRef = do+ (State g' t' gui' tg' p') <- readIORef stateRef+ writeIORef stateRef $ State g' (tick t') gui' tg' p'++-- |processEvent stateRef event handles key events+-- (toggling ToggleButtons with arrows and pause with 'p')+processEvent :: IORef State -> Event -> IO Bool+processEvent stateRef (Key {eventKeyName = keyName, eventModifier = evModifier, eventKeyChar = char}) = do+ state@(State g t gui tt p) <- readIORef stateRef+ case char of+ Just 'p' -> do+ case p of+ True -> renderImage (guiDrawArea gui) renderBlank+ 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+ _ -> return False+ where+ flipToggle btn = do+ p <- toggleButtonGetActive btn+ toggleButtonSetActive btn (not p)+processEvent _ _ = return False+ +tick :: Timer -> Timer+tick (Timer t tt)+ | t' > tt = Timer 0 tt+ | otherwise = Timer t' tt+ where t' = inc t++-- ========== Rendering ==========+ renderNewGame :: Int -> Int -> Render () renderNewGame w' h' = do setSourceRGB 0 0 0 paint setSourceRGB 1 1 1+ setFontSize 30+ moveTo (w/2 - 70) (h/4)+ showText "Ready?"+ setFontSize 20+ moveTo (w/2 - 130) (h/6 * 3)+ showText "LeftArrow -> Sound"+ moveTo (w/2 - 130) (h/6 * 4)+ showText "RightArrow -> Graphic"+ moveTo (w/2 - 130) (h/6 * 5)+ showText " 'p' -> Pause"+ where w = fromIntegral w' :: Double+ 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 "Ready?"+ showText "Paused" where w = fromIntegral w' :: Double h = fromIntegral h' :: Double @@ -84,177 +370,42 @@ system $ "mplayer " ++ f ++ "> /dev/null &" return () -randomElem :: [a] -> Maybe a -> IO a-randomElem [] _ = error "randomElem: List should not be empty"-randomElem lst c' =- do- case c' of- (Just c) -> do- x <- getStdRandom (randomR (0.0, 1.0)) :: IO Double- case (x <= 0.5) of- True -> return c- False -> aux lst- Nothing -> aux lst- where- aux l = do- y <- getStdRandom (randomR (1, length l))- return $ l !! (y - 1)---- ========== Main ==========--startNewGame :: IORef TotalScore -> Int -> DrawingArea -> Label -> Label -> ToggleButton -> ToggleButton -> IO ()-startNewGame gameScoreRef nTest drawArea tLabel scLabel visualBtn audioBtn = do- sndList <- soundList- state <- newIORef $ State nTest (Stimuli (randomElem imageList) Nothing [] (0,0,0,0))- (Stimuli (randomElem sndList) Nothing [] (0,0,0,0))- timerState <- newIORef $ Timer 0 0 5- labelSetText tLabel $ show nTest ++ "-Back Test"- tmhandle <- timeoutAdd (timer (blockSize + nTest) gameScoreRef timerState state scLabel drawArea visualBtn audioBtn tLabel) 500- return ()--tick :: TimerState -> TimerState-tick (Timer n t tt)- | t' > tt = Timer (inc n) 0 tt- | otherwise = Timer n t' tt- where t' = inc t--chooseNextN :: Int -> Score -> Score -> Int-chooseNextN n (tp, fp, fn, tn) (tp', fp', fn', tn')- | s >= 0.75 = n + 1- | s < 0.35 = max 1 $ n - 1- | otherwise = n- where num = fromIntegral (tp + tn + tp' + tn') :: Double- den = fromIntegral (2 * (tp + fp + fn + tn)) :: Double- s = num / den- -timer :: Int -> IORef TotalScore -> IORef TimerState -> IORef State -> Label -> DrawingArea -> ToggleButton -> ToggleButton -> Label -> IO Bool-timer block gameScoreRef ref state scLabel drawArea visualBtn audioBtn tLabel = do- (Timer iter t tt) <- readIORef ref- (State nTest vs@(Stimuli fn1 c1 h1 p1) as@(Stimuli fn2 c2 h2 p2)) <- readIORef state- if iter > block- then do- TotalScore n lst <- readIORef gameScoreRef- let lst' = (nTest, p1, p2) : lst- writeIORef gameScoreRef $ TotalScore n lst'- if n > length lst'- then do- let nTest' = chooseNextN nTest p1 p2- startNewGame gameScoreRef nTest' drawArea tLabel scLabel visualBtn audioBtn -- this is a hack; timer should not need to initiate the next game- else do- print $ TotalScore n $ reverse lst'- mainQuit- exitWith ExitSuccess - return False -- finish block- else do- if iter == 0- then do- renderImage drawArea renderNewGame- else do- case t of- 0 -> do- let (h1', h2') = case (c1,c2) of- (Nothing, Nothing) -> (h1, h2)- (Just x, Just y) -> (take nTest (x : h1), take nTest (y : h2))- c1' <- fn1 (maybeLast h1')- c2' <- fn2 (maybeLast h2')- writeIORef state $ State nTest (Stimuli fn1 (Just c1') h1' p1) (Stimuli fn2 (Just c2') h2' p2)- renderImage drawArea $ renderRect c1'- playSound c2'- -- labelSetText scLabel $ gameScore p1 p2- toggleButtonSetActive audioBtn False- toggleButtonSetActive visualBtn False- return ()- 1 -> do- renderImage drawArea renderBlank- _ -> when (t == tt && iter > nTest)- (do- b1 <- toggleButtonGetActive visualBtn- b2 <- toggleButtonGetActive audioBtn- writeIORef state $ State nTest (updateStimuli vs b1) (updateStimuli as b2))-- writeIORef ref $ tick (Timer iter t tt)- return True--updateStimuli :: Eq a => Stimuli a -> Bool -> Stimuli a-updateStimuli (Stimuli fn (Just c) h p) b =- Stimuli fn (Just c) h $ score (c == (last h)) b p--main = do- args <- getArgs- (totalBlocks, defaultN) <- case args of- [] -> return (10, 1)- (a:[]) -> return $ (read a :: Int, 1)- (a:b:[]) -> return $ ((read a :: Int), (read b :: Int))- otherwise -> do- printUsage- mainQuit- exitWith ExitSuccess- when (totalBlocks < 1 || defaultN < 1)- (do- printUsage- mainQuit- exitWith ExitSuccess)- initGUI- gFile <- getDataFileName "hback.glade"- windowXmlM <- xmlNew gFile- let windowXml = case windowXmlM of- (Just windowXml) -> windowXml- Nothing -> error "Can’t find the glade file \"hback.glade\" in the current directory"- window <- xmlGetWidget windowXml castToWindow "hback"- onDestroy window mainQuit-- label <- xmlGetWidget windowXml castToLabel "testLabel"- scLabel <- xmlGetWidget windowXml castToLabel "scoreLabel"- img <- xmlGetWidget windowXml castToDrawingArea "drawArea"- visualBtn <- xmlGetWidget windowXml castToToggleButton "visualBtn"- audioBtn <- xmlGetWidget windowXml castToToggleButton "audioBtn"-- gameScoreRef <- newIORef $ TotalScore totalBlocks []-- widgetShowAll window- startNewGame gameScoreRef defaultN img label scLabel visualBtn audioBtn- mainGUI--printUsage :: IO ()-printUsage = putStrLn "hback b n\n b is the number of tests [default=10]\n n determines the starting n-back test [default=1]"- -- ========== Utils ========== -inc :: Int -> Int-inc = (+1)--maybeLast :: [a] -> Maybe a-maybeLast [] = Nothing-maybeLast l = Just $ last l---- ========== Predictions ==========--score :: Bool -> Bool -> Score -> Score-score val ans (tp, fp, fn, tn)- | val && ans = (tp + 1, fp, fn, tn)- | not val && ans = (tp, fp + 1, fn, tn)- | val && not ans = (tp, fp, fn + 1, tn)- | not val && not ans = (tp, fp, fn, tn + 1)--gameScore :: Score -> Score -> String-gameScore (tp, fp, fn, tn) (tp', fp', fn', tn') = "[ " ++ show (tp + tn + tp' + tn') ++ " / " ++ show (2 * (tp + fp + fn + tn)) ++ " ]"+logInitGame :: IO ()+logInitGame = do+ unless (turnOffLogging)+ (do + t <- getPOSIXTime+ bracket (openFile "user_score_history.db" AppendMode) hClose+ (\h -> hPrintf h "%s\n" $ show t)) -totalScore :: Score -> String-totalScore (tp', fp', fn', tn') =- let tp = fromIntegral tp' :: Float- fp = fromIntegral fp' :: Float- fn = fromIntegral fn' :: Float- tn = fromIntegral tn' :: Float- in- foldr1 (++) $- zipWith (\s n -> s ++ show n ++ "\n")- [ "Precision TP / (TP + FP) = "- , "Recall TP / (TP + FN) = "- , "Specificity TN / (TN + FP) = "- , "Accuracy (TP + TN) / (TP + TN + FP + FN) = "]- [tp / (tp + fp),- tp / (tp + fn),- tn / (tn + fp),- (tp + tn) / (tp + tn + fp + fn)]+logGame :: IORef State -> IO ()+logGame stateRef = do+ unless (turnOffLogging)+ (do + state <- readIORef stateRef+ let game = head $ stateGames state+ bracket (openFile "user_score_history.db" 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)))))) +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)