Split code into modules

.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+tictactoe.cabal
+*~

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for tictactoe
+
+## Unreleased changes

README.md

@@ -0,0 +1,13 @@
+# tictactoe
+
+## Building
+
+```
+stack build 
+```
+
+## Execute
+
+```
+stack exec tictactoe-exe
+```

Setup.hs

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

app/Main.hs

@@ -0,0 +1,14 @@
+module Main where
+
+import Lib
+import System.IO
+import Game
+
+main :: IO ()
+main = do hSetBuffering stdout NoBuffering
+          putStr "Do you wish to play first? (y/n)"
+          x <- getChar
+          getChar
+          putChar '\n'
+          let s = (empty, PlayerO)
+          play (gametree s) (if x == 'y' then PlayerO else PlayerX)

package.yaml

@@ -0,0 +1,48 @@
+name:                tictactoe
+version:             0.1.0.0
+github:              "githubuser/tictactoe"
+license:             BSD3
+author:              "Author name here"
+maintainer:          "[email protected]"
+copyright:           "2019 Author name here"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/githubuser/tictactoe#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+
+library:
+  source-dirs: src
+
+executables:
+  tictactoe-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - tictactoe
+
+tests:
+  tictactoe-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - tictactoe

src/Game.hs

@@ -0,0 +1,186 @@
+module Game (
+    Cell(..),
+    Grid,
+    Player(..),
+    Tree(..),
+    GameTree(..),
+    next,
+    showPlayer,
+    full,
+    gameover,
+    wins,
+    putGrid,
+    bestmoves,
+    root,
+    move,
+    empty,
+    gametree
+    ) where
+
+import Data.List
+import Data.Maybe
+import Utils
+
+-- Basic declarations
+
+size :: Int
+size = 4        
+
+depth :: Int
+depth = 4
+
+winninglength :: Int
+winninglength = 4
+
+data Cell = O | B | X
+              deriving (Eq, Ord, Show)
+
+type Grid = [[Cell]]
+
+data Player = PlayerO | PlayerX
+              deriving (Eq, Show)
+
+data Tree a = Node a [Tree a]
+              deriving Show              
+
+data GameTree = GtNode (Grid, Player) [Maybe GameTree]
+                deriving Show
+
+
+-- Grid Utils
+
+-- Example winning grid
+-- [[B,O,O],[O,X,O],[X,X,X]] :: Grid
+
+owns :: Player -> Cell -> Bool
+owns p c = c == playerCell p
+
+
+next :: Player -> Player
+next PlayerO = PlayerX
+next PlayerX = PlayerO
+
+playerCell :: Player -> Cell
+playerCell PlayerX = X
+playerCell PlayerO = O
+
+empty :: Grid
+empty = replicate size (replicate size B)
+
+full :: Grid -> Bool
+full = all (/= B) . concat
+
+won :: Grid -> Bool
+won g = wins PlayerO g || wins PlayerX g
+
+gameover :: Grid -> Bool
+gameover g = or [won g, full g]
+
+-- we assume player O goes first
+turn :: Grid -> Player
+turn g = if os <= xs then PlayerO else PlayerX
+  where
+    os = length (filter (== O) ps)
+    xs = length (filter (== X) ps)
+    ps = concat g
+
+
+groups :: Int -> [Cell] -> [[Cell]]
+groups _ [] = [[]]
+groups n xs = [take n xs'] ++  groups n (drop n xs)
+              where xs' = if ((length xs) >= n) then xs else []
+
+
+consecutive :: Int -> Player -> [Cell] -> Bool
+consecutive n p xs = or (map (all (owns p)) (filter (\x -> not (null x)) (groups n xs)))
+
+wins :: Player -> Grid -> Bool
+wins p g = any line (rows ++ cols ++ dias)
+  where
+    line = consecutive winninglength p
+    rows = g
+    cols = transpose g
+    dias = [diag g, diag (map reverse g)]
+
+diag :: Grid -> [Cell]
+diag g = [g !! n !! n | n <- [0..size-1]]
+
+
+
+-- Display Grid
+
+-- TODO: replace with pretty printer
+putGrid :: Grid -> IO ()
+putGrid = putStrLn . unlines . concat . interleave bar . map showRow
+  where bar = [replicate ((size*4)-1) '-']
+
+showRow :: [Cell] -> [String]
+showRow = beside . interleave bar . map showCell
+  where
+    beside = foldr1 (zipWith (++))
+    bar    = replicate 3 "|"
+
+showCell :: Cell -> [String]
+showCell O = ["   ", " O ", "   "]
+showCell B = ["   ", "   ", "   "]
+showCell X = ["   ", " X ", "   "]
+
+showPlayer PlayerX = "Player X"
+showPlayer PlayerO = "Player O"
+
+
+-- Making a move
+
+valid :: Grid -> Int -> Bool
+valid g i = 0 <= i && i < size ^ 2 && concat g !! i == B
+
+move :: (Grid, Player) -> Int -> Maybe (Grid, Player)
+move (g, p) i =
+    if valid g i then Just (chop size (xs ++ [c] ++ ys), next p) else Nothing
+    where (xs,B:ys) = splitAt i (concat g)
+          c = playerCell p
+
+
+-- Game Trees
+
+root :: GameTree -> (Grid, Player)
+root (GtNode a _) = a
+
+gametree :: (Grid, Player) -> GameTree
+gametree s = GtNode s [fmap gametree s' | s' <- moves s]
+
+moves :: (Grid, Player) -> [Maybe (Grid, Player)]
+moves s@(g, _)
+          | gameover g = []
+          | otherwise = [move s i | i <- [0..((size^2)-1)]]
+
+
+-- minimax algorithm
+minimax :: Int -> GameTree -> Tree (GameTree, Cell)
+minimax d t@(GtNode (g, _) ts)
+  | null ts || d == 0 =
+                 if | wins PlayerO g  -> Node (t,O) []
+                    | wins PlayerX g  -> Node (t,X) []
+                    | otherwise -> Node (t,B) []
+minimax d t@(GtNode (g, _) ts)
+                    | turn g == PlayerO = Node (t, minimum ps) ts'
+                    | turn g == PlayerX = Node (t, maximum ps) ts'
+                      where
+                        ts' = map (minimax (d-1)) (catMaybes ts)
+                        ps = [p | Node (_, p) _ <- ts']
+
+bestmoves :: GameTree -> [GameTree]
+bestmoves t = [t' | (t',d) <- bestSubtrees, d == minTreeDepth]
+               where
+                 (_, p)           = root t
+                 Node (_,best) ts = minimax depth t
+                 bestSubtrees     = [(t', minimum (if (null ts') then [0] else map treedepth ts')) | (Node (t', p') ts') <- ts, p' == best]
+                 minTreeDepth     = minimum [d | (_,d) <- bestSubtrees]          
+
+
+treesize :: Tree a -> Int
+treesize (Node _ nodes) = 1 + sum (map treesize nodes) 
+
+treedepth :: Tree a -> Int
+treedepth (Node _ []) = 0
+treedepth (Node _ nodes) = 1 + maximum (map treedepth nodes)

src/Interactions.hs

@@ -0,0 +1,14 @@
+module Interactions where
+
+import Data.Char    
+-- Reading a number 
+
+getNat :: String -> IO Int
+getNat prompt = do 
+    putStr prompt
+    xs <- getLine
+    if xs /= [] && all isDigit xs then
+        return (read xs)
+    else
+        do putStrLn "ERROR: Invalid number"
+           getNat prompt

src/Lib.hs

@@ -0,0 +1,80 @@
+module Lib where
+
+import Data.Char
+
+
+import System.IO
+import System.Random (randomRIO)
+import Game
+import Utils
+import Interactions
+
+
+-- Human vs human
+tictactoe :: IO ()
+tictactoe = run (empty, PlayerO)
+
+run :: (Grid, Player) -> IO ()
+run (g, p) = do
+    cls
+    goto (1,1)
+    putGrid g
+    run' (g, p)
+
+run' :: (Grid, Player) -> IO ()
+run' s@(g, p)   | wins PlayerO g = putStrLn "Player O wins!\n"
+                | wins PlayerX g = putStrLn "Player X wins!\n"
+                | full g   = putStrLn "It's a draw!\n"
+                | otherwise = do i <- getNat (prompt p)
+                                 case move s i of
+                                     Nothing -> do putStrLn "Error: Invalid move"
+                                                   run' s
+                                     Just s' -> run s'
+
+prompt :: Player -> String
+prompt p = showPlayer p ++ ", enter your move:"
+
+
+
+
+
+
+
+play :: GameTree -> Player -> IO ()
+play t h =
+             do cls
+                goto (1,1)
+                putGrid g
+                play' t h
+  where
+    s@(g, _) = root t
+
+lookupMaybe :: Int -> [Maybe a] -> Maybe a
+lookupMaybe _ [] = Nothing
+lookupMaybe 0 (x:_) = x
+lookupMaybe n (_:xs) =
+  if n > 0 then lookupMaybe (n-1) xs
+           else Nothing
+
+play' :: GameTree -> Player -> IO ()
+play' t@(GtNode (g,p) ts) h
+  | wins PlayerO g  = putStrLn "Player O wins!\n"
+  | wins PlayerX g  = putStrLn "Player X wins!\n"
+  | full g    = putStrLn "It's a draw!\n"
+  | p == h    = do i <- getNat (prompt p)
+                   case lookupMaybe i ts of 
+                     Nothing ->
+                           do putStrLn "Error: Invalid move"
+                              play' t h
+                     Just t' -> play t' h
+  | otherwise = do putStr (showPlayer (next h) ++ " is thinking...")
+                   t' <- selectRandom $ bestmoves t
+                   play t' h
+
+selectRandom :: [a] -> IO a
+selectRandom xs = do
+  n <- randomRIO (0, (length xs) - 1)
+  return (xs !! n)
+
+
+

src/Minimax.hs

@@ -0,0 +1,2 @@
+
+

src/Utils.hs

@@ -0,0 +1,19 @@
+module Utils where
+
+interleave :: a -> [a] -> [a]
+interleave x []     = []
+interleave x [y]    = [y]
+interleave x (y:ys) = y : x : interleave x ys
+
+
+chop :: Int -> [a] -> [[a]]
+chop n [] = []
+chop n xs = take n xs : chop n (drop n xs)
+
+-- Display
+
+cls :: IO ()
+cls = putStr "\ESC[2J"
+
+goto :: (Int,Int) -> IO ()
+goto (x,y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")