hback (empty) → 0.0
raw patch · 17 files changed
+464/−0 lines, 17 filesdep +basedep +cairodep +gladesetup-changedbinary-added
Dependencies added: base, cairo, glade, gtk, haskell98, process
Files
- LICENSE +30/−0
- Makefile +18/−0
- Paths_hback.hs +8/−0
- README.txt +35/−0
- Setup.lhs +3/−0
- hback.cabal +26/−0
- hback.glade +84/−0
- hback.hs +260/−0
- sounds/a.wav binary
- sounds/b.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/t.wav binary
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Norbert Wojtowicz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
+ Makefile view
@@ -0,0 +1,18 @@++all: build++configure:+ runhaskell Setup.lhs configure+trial: configure+ ghc --make hback.hs -o hback++build: configure+ runhaskell Setup.lhs build+install:+ runhaskell Setup.lhs install++clean:+ rm -f hback+ rm -f *.hi+ rm -f *.o+ rm -rf ./dist/
+ Paths_hback.hs view
@@ -0,0 +1,8 @@++module Paths_hback where++getDataFileName :: FilePath -> IO FilePath+getDataFileName = return++getDataDir :: IO FilePath+getDataDir = return "."
+ README.txt view
@@ -0,0 +1,35 @@++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.++Gameplay+--------++The n-back memory game tests whether the player can remember if the nth previous turn matches the current one. The dual n-back test will measure how well the player can remember both visual and graphic stimuli simultaneously.++Given a difficulty level n, the player is expected to remember on each turn whether the nth previous sound or graphic (or both) matches the current one, and toggle the appropriate button(s). The graphic flashes for 500ms and the player has another 2.5 seconds to answer.++The training game consists of b block iterations, where each block will present (20+n) visual and audio stimuli. After each iteration, the difficulty of the n-back test may increase or decrease, depending on the performance of the player: the goal is to constantly keep the player at peak concentration.++Installation+------------++ % tar -xzf hback-0.0.tar.gz+ % cd hback-0.0++Game can be played without system-wide installation:++ % make trial+ % ./hback++If you like what you see, feel free to install it:++ % make build+ % make install # you may need root privileges for this+ % rehash+ % hback++hback takes two optional arguments:++ % ./hback b n+ - b determines the number of block iterations (eg. try 20 for an effective daily workout)+ - n determines the initial level (defaults to 1)
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ hback.cabal view
@@ -0,0 +1,26 @@+Name: hback+Version: 0.0+Build-Depends: base,haskell98,process,glade,gtk,cairo+Build-type: Simple+License: BSD3+License-file: LICENSE+Author: Norbert Wojtowicz <wojtowicz.norbert@gmail.com>+Maintainer: Norbert Wojtowicz <wojtowicz.norbert@gmail.com>+Category: Game+Synopsis: N-back memory game+Description: N-back memory game using gtk2hs+Extra-Source-Files: README.txt,+ Makefile,+ Paths_hback.hs+Data-Files: hback.glade,+ sounds/a.wav,+ sounds/b.wav,+ sounds/d.wav,+ sounds/e.wav,+ sounds/f.wav,+ sounds/g.wav,+ sounds/h.wav,+ sounds/k.wav,+ sounds/t.wav+Executable: hback+Main-is: hback.hs
+ hback.glade view
@@ -0,0 +1,84 @@+<?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 -->+<glade-interface>+ <widget class="GtkWindow" id="hback">+ <property name="width_request">300</property>+ <property name="height_request">400</property>+ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <property name="border_width">4</property>+ <property name="spacing">4</property>+ <child>+ <widget class="GtkHBox" id="hbox2">+ <property name="height_request">50</property>+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="testLabel">+ <property name="visible">True</property>+ <property name="xalign">0.20000000298023224</property>+ <property name="label" translatable="yes">N-Back</property>+ </widget>+ </child>+ <child>+ <widget class="GtkLabel" id="scoreLabel">+ <property name="visible">True</property>+ <property name="xalign">0.80000001192092896</property>+ <property name="label" translatable="yes">Score</property>+ <property name="justify">GTK_JUSTIFY_RIGHT</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ </packing>+ </child>+ <child>+ <widget class="GtkDrawingArea" id="drawArea">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox1">+ <property name="height_request">50</property>+ <property name="visible">True</property>+ <property name="border_width">4</property>+ <property name="homogeneous">True</property>+ <child>+ <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">Sound</property>+ <property name="response_id">0</property>+ </widget>+ </child>+ <child>+ <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">Graphic</property>+ <property name="response_id">0</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">2</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+</glade-interface>
+ hback.hs view
@@ -0,0 +1,260 @@+module Main where++import System.Exit+import System.Cmd (system)+import Directory (getDirectoryContents)+import System.Environment (getArgs)+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 Data.IORef+import Random++import Paths_hback++-- ========== Data ========== ++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+type Frac = Int+type Total = Int++blockSize = 20+ +imageList :: [Visual]+imageList = [(a,b) | a <- [0..2], b <- [0..2]]++soundList :: IO [Audio]+soundList = do+ d <- getDataDir+ let dir = d ++ "/sounds/"+ l <- getDirectoryContents dir+ return $ map (dir ++) $ filter (/= ".") $ filter (/= "..") l++renderNewGame :: Int -> Int -> Render ()+renderNewGame w' h' = do+ setSourceRGB 0 0 0+ paint + setSourceRGB 1 1 1+ moveTo (w/2 - 80) (h/2)+ setFontSize 40+ showText "Ready?"+ where w = fromIntegral w' :: Double+ h = fromIntegral h' :: Double++renderBlank :: Int -> Int -> Render ()+renderBlank _ _ = do+ setSourceRGB 0 0 0+ paint++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+ +renderImage :: DrawingArea -> (Int -> Int -> Render ()) -> IO ()+renderImage drawArea img = do+ (w,h) <- widgetGetSize drawArea+ drawin <- widgetGetDrawWindow drawArea+ renderWithDrawable drawin $ img w h+ return ()++playSound :: Audio -> IO ()+playSound f = do+ 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)) ++ " ]"++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)]++
+ sounds/a.wav view
binary file changed (absent → 13484 bytes)
+ sounds/b.wav view
binary file changed (absent → 19884 bytes)
+ sounds/d.wav view
binary file changed (absent → 20524 bytes)
+ sounds/e.wav view
binary file changed (absent → 17964 bytes)
+ sounds/f.wav view
binary file changed (absent → 20204 bytes)
+ sounds/g.wav view
binary file changed (absent → 19884 bytes)
+ sounds/h.wav view
binary file changed (absent → 21484 bytes)
+ sounds/k.wav view
binary file changed (absent → 20844 bytes)
+ sounds/t.wav view
binary file changed (absent → 19244 bytes)