Adding TicTacToe Monad and Matrix library

.gitignore

@@ -0,0 +1,5 @@
+*.swp
+*.swo
+*.~
+dist/*
+tests/dist/*

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

src/Data/Internal/TicTacToe.hs

@@ -0,0 +1,76 @@
+module Data.Internal.TicTacToe 
+  (
+    TicTacToe 
+  , PlayerId (..)
+  , runGame 
+  , setMatrix
+  , play
+  , getWinner
+  ) where
+
+  import Control.Monad (when, sequence)
+  import Control.Monad.State (MonadState, get, put, StateT, runStateT)
+  import Control.Monad.Trans (MonadIO, MonadTrans)
+  import Data.Matrix (Matrix, buildMatrix, getRows, getCols, getDiagonals, update)
+  import Data.Maybe (catMaybes)
+  import Data.Monoid (First(..), getFirst, mconcat)
+
+  newtype TicTacToe m a 
+    = TTT (StateT GameInfo m a) 
+    deriving (Monad, MonadState GameInfo, MonadTrans, MonadIO)
+
+  data PlayerId
+    = X 
+    | O
+    deriving (Eq, Show)
+
+  data GameInfo
+    = GameInfo {
+      gameMatrix :: Matrix (Maybe PlayerId)
+    } deriving (Show)
+
+  newGameMatrix :: Matrix (Maybe PlayerId)
+  newGameMatrix = 
+      buildMatrix  [
+        replicate 3 Nothing
+      , replicate 3 Nothing
+      , replicate 3 Nothing 
+      ]
+
+
+  runGame :: (Monad m) => TicTacToe m a -> m (a, GameInfo)
+  runGame (TTT m) = runStateT m (GameInfo newGameMatrix)
+
+  updateGameInfo :: (MonadState GameInfo m) => (GameInfo -> GameInfo) -> m ()
+  updateGameInfo fn = get >>= put . fn
+
+  setMatrix :: (MonadState GameInfo m) => Matrix (Maybe PlayerId) -> m ()
+  setMatrix matrix = updateGameInfo (\gi -> gi { gameMatrix = matrix })
+
+  play :: (MonadState GameInfo m) => (Int,Int) -> PlayerId -> m Bool
+  play key value = do
+    gameInfo <- get
+    let (b, matrix') = update key (const $ Just (Just value)) (gameMatrix gameInfo)
+    when b (put $ gameInfo { gameMatrix = matrix' })
+    return b
+
+  getWinner :: (MonadState GameInfo m) => m (Maybe PlayerId)
+  getWinner = get >>= return . checkMatrix . gameMatrix
+    where
+      checkMatrix :: Matrix (Maybe PlayerId) -> Maybe PlayerId
+      checkMatrix matrix = 
+          getFirst .
+          mconcat . 
+          map (findWinner True) .
+          catMaybes . 
+          map sequence $ 
+            getRows matrix ++ 
+            getCols matrix ++
+            getDiagonals matrix
+
+      findWinner :: Bool -> [PlayerId] -> First PlayerId
+      findWinner False _  = First Nothing
+      findWinner True [x] = First $ Just x
+      findWinner True (x:y:xs) = findWinner (x == y) (y:xs)
+
+

src/Data/Matrix.hs

@@ -0,0 +1,57 @@
+module Data.Matrix 
+  (
+    Matrix  
+  , buildMatrix
+  , getRows
+  , getCols
+  , getDiagonals
+  , lookup
+  , update
+  ) where
+
+  import           Prelude hiding (lookup)
+  import           Data.List (transpose)
+  import           Data.Maybe (fromMaybe)
+
+  safeHead :: [a] -> Maybe a
+  safeHead []     = Nothing
+  safeHead xs = Just $ head xs
+
+  safeTail :: [a] -> Maybe [a]
+  safeTail [] = Nothing
+  safeTail xs = Just $ tail xs
+
+  newtype Matrix a 
+    = Matrix { getRows :: [[a]] } deriving (Show)
+
+  buildMatrix :: [[a]] -> Matrix a
+  buildMatrix = Matrix
+
+  getCols :: Matrix a -> [[a]]
+  getCols = transpose . getRows
+
+  getDiagonals :: Matrix a -> [[a]]
+  getDiagonals m = (helper 0 $ getRows m) : (helper 0 . reverse $ getRows m) : []
+    where
+      helper _ [] = []
+      helper n (x:xs) = head (drop n x) : helper (n + 1) xs
+
+  lookup :: (Int, Int) -> Matrix a -> Maybe a
+  lookup (x,y) m = do 
+    row <- safeHead . drop (x - 1) . getRows $ m
+    safeHead $ drop (y - 1) row
+
+  update :: (Int, Int) -> (a -> Maybe a) -> Matrix a -> (Bool, Matrix a)
+  update (x,y) fn matrix = 
+      fromMaybe (False, matrix) $ do
+        let (preR, postR) = splitAt (x - 1) (getRows matrix) 
+        row <- safeHead postR 
+        let (preC, postC) = splitAt (y - 1) row 
+        value  <- safeHead postC
+        value' <- fn value
+        postR' <- safeTail postR
+        postC' <- safeTail postC
+        return (True, buildMatrix $ preR ++ 
+                                    [preC ++ [value'] ++ postC'] ++ 
+                                    postR')
+

src/Data/TicTacToe.hs

@@ -0,0 +1,7 @@
+module Data.TicTacToe 
+  (
+    module Data.Internal.TicTacToe
+  ) where
+
+  import Data.Internal.TicTacToe
+

tests/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

tests/runTests.sh

@@ -0,0 +1,50 @@
+#!/bin/sh
+
+set -e
+
+if [ -z "$DEBUG" ]; then
+    export DEBUG="testsuite"
+fi
+
+SUITE=./dist/build/testsuite/testsuite
+
+export LC_ALL=C
+export LANG=C
+
+rm -f testsuite.tix
+
+if [ ! -f $SUITE ]; then
+    cat <<EOF
+Testsuite executable not found, please run:
+    cabal configure -ftest
+then
+    cabal build
+EOF
+    exit;
+fi
+
+./dist/build/testsuite/testsuite -j4 -a1000 $*
+
+DIR=dist/hpc
+
+rm -Rf $DIR
+mkdir -p $DIR
+
+EXCLUDES='Main'
+
+EXCL=""
+
+for m in $EXCLUDES; do
+    EXCL="$EXCL --exclude=$m"
+done
+
+hpc markup $EXCL --destdir=$DIR testsuite >/dev/null 2>&1
+
+rm -f testsuite.tix
+
+cat <<EOF
+
+Test coverage report written to $DIR.
+EOF
+
+

tests/suite/Data/Matrix/Tests.hs

@@ -0,0 +1,84 @@
+module Data.Matrix.Tests 
+  (
+  tests
+  ) 
+  where
+
+  import           Prelude hiding (lookup)
+  import           Test.Framework (Test)
+  import           Test.Framework.Providers.HUnit (testCase)
+  import           Test.HUnit (assertEqual, assertBool)
+  import           Data.Matrix 
+
+  tests :: [Test]
+  tests = [
+            testGetRows 
+          , testGetCols
+          , testGetDiagonals
+          , testLookup
+          , testUpdate
+          ]
+
+  testGetRows :: Test
+  testGetRows = testCase "matrix/getRows" $ do
+    let matrix = buildMatrix [ [1,2,3]
+                             , [4,5,6]
+                             , [7,8,9]
+                             ]
+    assertEqual "getRows is not working" 
+                [[1,2,3], [4,5,6], [7,8,9]]
+                (getRows matrix)
+
+  testGetCols :: Test
+  testGetCols = testCase "matrix/getCols" $ do
+    let matrix = buildMatrix [ [1,2,3]
+                             , [4,5,6]
+                             , [7,8,9]
+                             ]
+    assertEqual "getCols is not working"
+                [[1,4,7], [2,5,8], [3,6,9]]
+                (getCols matrix)
+
+  testGetDiagonals :: Test
+  testGetDiagonals = testCase "matrix/getDiagonals" $ do
+    let matrix = buildMatrix [ [1,2,3]
+                             , [4,5,6]
+                             , [7,8,9]
+                             ]
+    assertEqual "getDiagonals is not working"
+                [[1,5,9], [7,5,3]]
+                (getDiagonals matrix)
+
+  testLookup :: Test
+  testLookup = testCase "matrix/lookup" $ do
+    let matrix = buildMatrix [ [1,2,3]
+                             , [4,5,6]
+                             , [7,8,9]
+                             ]
+    assertEqual "lookup is not working"
+                 (Just 6)
+                 (lookup (2,3) matrix)
+
+  testUpdate :: Test 
+  testUpdate = testCase "matrix/update" $ do
+    let matrix = buildMatrix [ [1,2,3]
+                             , [4,5,6]
+                             , [7,8,9]
+                             ]
+    assertBool "update returns true when index is valid" 
+               (fst $ update (1,3) (const $ Just 4) matrix)
+
+    assertEqual "update modifies the matrix when index is valid" 
+                [[1,2,4], [4,5,6], [7,8,9]]
+                (getRows . snd $ update (1,3) (const $ Just 4) matrix)
+
+    assertBool "update returns false when index is invalid"
+               (not . fst $ update (4,5) (const $ Just 4) matrix)
+
+    assertEqual "update doesn't modify the matrix when index is invalid"
+                [[1,2,3], [4,5,6], [7,8,9]]
+                (getRows . snd $ update (4,5) (const $ Just 4) matrix)
+
+
+
+