diff --git a/hback.cabal b/hback.cabal --- a/hback.cabal +++ b/hback.cabal @@ -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 diff --git a/hback.hs b/hback.hs --- a/hback.hs +++ b/hback.hs @@ -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)