diff --git a/Cross.png b/Cross.png new file mode 100644 Binary files /dev/null and b/Cross.png differ diff --git a/DataTypes.hs b/DataTypes.hs new file mode 100644 --- /dev/null +++ b/DataTypes.hs @@ -0,0 +1,60 @@ +module DataTypes + where + +import Data.List + +data TableMove = TableMove Board History CurrentMove deriving (Show,Ord) +data Move = X | O deriving (Eq, Show, Enum, Ord) + +type History = [Integer] +type CurrentMove = Maybe Move +type Board = [[Maybe Move]] + +size :: Int +size = 3 + +empty :: Board +empty = replicate size (replicate size Nothing) + +-- make use of symmetries +-- we try to see if there is a symmetry if the move we are about to make +-- has across from it, either horizontally, vertically, or diagonally, a Nothing slot. +-- The only position that may change is the position of the move we are about to make. +-- If the symmetrical move is already included in the current ply, we may take it out. +instance Eq TableMove where + (TableMove m1 h1 c1) == (TableMove m2 h2 c2) = + (horizontalSym m1 == m2) || (leftDiagonalSym m1 == m2) || (verticalSym m1 == m2) || (rightDiagonalSym m1 == m2) + +horizontalSym = reverse +leftDiagonalSym = transpose +verticalSym = transpose.reverse.transpose +rightDiagonalSym = verticalSym.reverse.transpose + +-- these are our accessors +accessMaybeMove :: TableMove -> [[Maybe Move]] +accessMaybeMove (TableMove m _ _) = m + +accessHistory :: TableMove -> [Integer] +accessHistory (TableMove _ h _) = h + +accessCurrentMove :: TableMove -> CurrentMove +accessCurrentMove (TableMove _ _ c) = c + +getOtherMove :: CurrentMove -> CurrentMove +getOtherMove (Just X) = Just (succ X) +getOtherMove (Just O) = Just (pred O) +getOtherMove Nothing = Nothing + +toTableMove :: [[Maybe Move]] -> History -> CurrentMove -> TableMove +toTableMove m h c = TableMove m h c + +chop :: Int -> [a] -> [[a]] +chop n [] = [] +chop n xs = take n xs : chop n (drop n xs) + +infinity :: Float +infinity = 1/0 + +-- gives us a list of the diagonal elements +diag :: [[a]] -> [a] +diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]] diff --git a/GetAgentMove.hs b/GetAgentMove.hs new file mode 100644 --- /dev/null +++ b/GetAgentMove.hs @@ -0,0 +1,23 @@ +module GetAgentMove + where + +import MyTree +import GetValue +import DataTypes +import Data.Tree + +-- This is the main driver function of the AI. It uses a composition of functions. +ans :: Board -> CurrentMove -> Integer -> TableMove +ans board currentMove diff = backtrackWith (findHistory board) $ maximise $ + myCustomTreeZip (myTreeValue $ prune diff $ gameTree (makeTableTree board currentMove)) (prune diff $ gameTree (makeTableTree board currentMove)) + +--test board currentMove = maximise $ myCustomTreeZip (myTreeValue $ prune 4 $ gameTree (makeTableTree board currentMove)) (prune 4 $ gameTree (makeTableTree board currentMove)) + +backtrackWith :: [Integer] -> (Float,TableMove) -> TableMove +backtrackWith h (m,tableMove) = remove h tableMove + +remove :: [Integer] -> TableMove -> TableMove +remove h tableMove = if tail (accessHistory tableMove) == h then tableMove + else (remove h (toTableMove (chop size (xs ++ (Nothing : ys))) + (tail (accessHistory tableMove)) ((getOtherMove . accessCurrentMove) tableMove))) + where (xs,y:ys) = splitAt (fromInteger $ head (accessHistory tableMove)) (concat (accessMaybeMove tableMove)) diff --git a/GetValue.hs b/GetValue.hs new file mode 100644 --- /dev/null +++ b/GetValue.hs @@ -0,0 +1,74 @@ +module GetValue + where + +import Data.List +import Data.Tree +import DataTypes +import MyTree + +-- since for each evaluation of a tree, we need to find the value in terms of one moves, +-- so that the moves do not alternate between each other. Kinda ugly but works. +myTreeValue :: Tree TableMove -> Tree Float +myTreeValue (Node node subTree) = myTreeMap (getValue ((getOtherMove.accessCurrentMove) node)) (Node node subTree) + +maximise :: (Ord a) => Tree (a,TableMove) -> (a,TableMove) +maximise = maximum . maximise' + +-- this is called alpha-beta pruning... +maximise' :: (Ord a) => Tree (a,TableMove) -> [(a,TableMove)] +maximise' (Node node []) = [node] +maximise' (Node n l) = mapmin (map minimise' l) + where mapmin (nums:rest) = (minimum nums) : (omit1 (minimum nums) rest) + +omit1 :: (Ord a) => a -> [[a]] -> [a] +omit1 pot [] = [] +omit1 pot (nums:rest) = if minleq nums pot then omit1 pot rest + else (minimum nums) : (omit1 (minimum nums) rest) + +minleq :: (Ord a) => [a] -> a -> Bool +minleq [] pot = False +minleq (num:rest) pot = if num <= pot then True + else minleq rest pot + + +minimise :: (Ord a) => Tree (a,TableMove) -> (a,TableMove) +minimise = minimum . minimise' + +minimise' :: (Ord a) => Tree (a,TableMove) -> [(a,TableMove)] +minimise' (Node node []) = [node] +minimise' (Node n l) = mapmax (map maximise' l) + where mapmax (nums:rest) = (maximum nums) : (omit2 (maximum nums) rest) + +omit2 :: (Ord a) => a -> [[a]] -> [a] +omit2 pot [] = [] +omit2 pot (nums:rest) = if maxleq nums pot then omit2 pot rest + else (maximum nums) : (omit2 (maximum nums) rest) + +maxleq :: (Ord a) => [a] -> a -> Bool +maxleq [] pot = False +maxleq (num:rest) pot = if num >= pot then True + else maxleq rest pot + + +prune :: Integer -> Tree TableMove -> Tree TableMove +prune 0 (Node node x) = Node node [] +prune n (Node node x) = Node node (map (prune (n-1)) x) + +-- this function evaluates a position and returns a value, based on how good it is +-- The function first takes the sum of the rows columns or diagonals it can form based on +-- the current move. It then takes the sum of the rows, columns or diagonals the opponent +-- can form, and subtracts that from its original sum, which it returns. If the function finds +-- that it has formed a full row, column, or diagonal, it returns 1/0 (infinity), or if it finds +-- the same condition for its opponent (it can't be both), it returns -1/0 (negative infinity). +-- If there is no more open spaces that it can use, the function returns 0. +getValue :: CurrentMove -> TableMove -> Float +getValue curr t = (getValueOfMove curr (accessMaybeMove t)) - (getValueOfMove (getOtherMove curr) (accessMaybeMove t)) + where getValueOfMove c l = (rowValues c l) + (rowValues c (transpose l)) + (diagValues c l) + (diagValues c (map reverse l)) + +rowValues :: Maybe Move -> [[Maybe Move]] -> Float +rowValues cMove table = if (any (==True) (findEndGame cMove table)) then 1/0 else foldr (\x y -> if x then (1+y) else (0+y)) 0 (findStatic cMove table) + where findEndGame c m = map (all (\x -> x == c)) m + findStatic c m = map (all (\x -> (x == c) || (x == Nothing))) m + +diagValues :: Maybe Move -> [[Maybe Move]] -> Float +diagValues cMove xL = if (all (==cMove) (diag xL)) then 1/0 else if (all (\x -> (x == cMove) || (x == Nothing)) (diag xL)) then 1 else 0 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2006, Wouter Swierstra +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +* 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. + +* Neither the name of the University of Nottingham nor the names of +its contributors may be used to endorse or promote products derived +from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER 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. diff --git a/MyTree.hs b/MyTree.hs new file mode 100644 --- /dev/null +++ b/MyTree.hs @@ -0,0 +1,84 @@ +module MyTree + where + +import DataTypes +import Data.Tree +import Data.Maybe +import Data.List +import Data.Ord + +-- this is an implementation without monads: +myTreeMap :: (a -> b) -> Tree a -> Tree b +myTreeMap f (Node node subTree) = Node (f node) (myTreeMap' f subTree) + where myTreeMap' f [] = [] + myTreeMap' f (first:rest) = (myTreeMap f first) : (myTreeMap' f rest) + +-- this is an implementation with monads: +--myTreeMap :: (a -> b) -> Tree a -> Tree b +--myTreeMap f tree = do +-- move <- tree +-- return (f move) + +-- regular zipper, except that during execution, if a node finds that it has won or lost, +-- further generation of the tree stops. We need this so that we dont get weird results when +-- we use minimax. +myCustomTreeZip :: Tree Float -> Tree TableMove -> Tree (Float,TableMove) +myCustomTreeZip (Node n1 s1) (Node n2 s2) = if n1 == 1/0 || n1 == -1/0 then Node (n1,n2) [] else Node (n1,n2) (myTreeZip' s1 s2) + where myTreeZip' [] _ = [] + myTreeZip' _ [] = [] + myTreeZip' (f1:r1) (f2:r2) = (myCustomTreeZip f1 f2) : (myTreeZip' r1 r2) + +gameTree :: Tree TableMove -> Tree TableMove +gameTree p = reptree moves p + +-- initialize a non-empty board +makeTableTree :: Board -> CurrentMove -> Tree TableMove +makeTableTree board currentMove = Node (toTableMove board (findHistory board) currentMove) [] + +-- given a board, returns the history of moves already taken +findHistory :: Board -> [Integer] +findHistory board = foldr (\(p,n) xL -> if p == (Just O) || p == (Just X) then n:xL else xL) [] (zip (concat board) [0..]) + +reptree :: (TableMove -> [Tree TableMove]) -> Tree TableMove -> Tree TableMove +reptree f (Node node []) = + Node node (map (reptree f) (f node)) + +-- function responsible for generating a tree and making the input the parent +-- of all the other subtrees. It does this by getting each possibility of the input +-- excluding the ones in the history that have already been processed. It then proceeds +-- to remove the symmetries from the generated possibilities, after which it it converts +-- the TableMove to a Tree of TableMove. For each input, it generates all the possible moves +-- that the node can make in a list. +moves :: TableMove -> [Tree TableMove] +moves thisNode = map (makeLeafs) (removeSymmetries (map (possibilities thisNode) ([0..8] \\ (accessHistory thisNode)))) + +-- makes a TableMove into a Tree of TableMove with empty leafs +makeLeafs :: TableMove -> Tree TableMove +makeLeafs (xs) = Node xs [] + +-- a container that interfaces with the possibly function, converting +-- the data into its appropriate type. The Integer is the move placeholder +-- that we want to place a X or O. +possibilities :: TableMove -> Integer -> TableMove +possibilities node n = toTableMove (possibly (accessMaybeMove node) n (accessCurrentMove node)) (n : (accessHistory node)) (getOtherMove (accessCurrentMove node)) + +-- breaks down the current TableMove into three rows, +-- with x being the first, y being the second, and z being the third. +-- xs is an empty list. Note: I could probably simplify this to a lot +-- less code using the chop function. +possibly :: [[Maybe Move]] -> Integer -> Maybe Move -> [[Maybe Move]] +possibly (x:y:z:xs) n currentMove + | n >= 0 && n <= 2 = possibly' x (n `mod` 3) : y : z : xs + | n >= 3 && n <= 5 = x : possibly' y (n `mod` 3) : z : xs + | n >= 6 && n <= 8 = x : y : possibly' z (n `mod` 3) : xs + | otherwise = x : y : z : xs + where trulyNothing elem = if isNothing elem then (getOtherMove currentMove) else elem + possibly' (x:y:z:xs) m + | m == 0 = trulyNothing x : y : z : xs + | m == 1 = x : trulyNothing y : z : xs + | m == 2 = x : y : trulyNothing z : xs + | otherwise = x : y : z : xs + +removeSymmetries :: [TableMove] -> [TableMove] +removeSymmetries [] = [] +removeSymmetries (x:xL) = x : removeSymmetries (filter (/= x) xL) diff --git a/Nought.png b/Nought.png new file mode 100644 Binary files /dev/null and b/Nought.png differ diff --git a/NoughtyGlade.hs b/NoughtyGlade.hs new file mode 100644 --- /dev/null +++ b/NoughtyGlade.hs @@ -0,0 +1,174 @@ +-- Copyright (c) 2006, Wouter Swierstra +-- All rights reserved. +-- This code is released under the BSD license +-- included in this distribution + +-- Imports + +import IO +import Maybe +import Data.List +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Glade +import Data.IORef +import Control.Monad + +-- my own imports +import GetAgentMove +import DataTypes +import MyTree + +-- With n being the square that we want to move to, p being the +-- actual move, and b being the current board, we return +-- a board with the move placed on the square +move :: Int -> CurrentMove -> Board -> Maybe Board +move n p b = case y of + Nothing -> Just (chop size (xs ++ (p : ys))) + _ -> Nothing + where + (xs,y:ys) = splitAt n (concat b) + +full :: Board -> Bool +full b = all (all (/= Nothing)) b + +wins :: CurrentMove -> Board -> Bool +wins p b = any (all (== p)) b + || any (all (== p)) (transpose b) + || all (== p) (diag b) + || all (== p) (diag (reverse b)) + +won :: Board -> Bool +won b = wins (Just O) b || wins (Just X) b + +-- The state and GUI + +data State = State { + board :: Board, + turn :: CurrentMove, + difficulty :: Integer +} + +data GUI = GUI { + disableBoard :: IO (), + resetBoard :: IO (), + setSquare :: Int -> CurrentMove -> IO (), + setStatus :: String -> IO () +} + +-- reset the game +reset gui (State board turn difficulty) = do + setStatus gui "Player Cross: make your move." + resetBoard gui + return (State empty (Just X) difficulty) + +-- when a square is clicked on, try to make a move. +-- if the square is already occupied, nothing happens +-- otherwise, update the board, let the next player make his move, +-- and check whether someone has won or the board is full. +occupy gui square st@(State board currentMove difficulty) = do + case move square currentMove board of + Nothing -> return st + Just newBoard -> do + setSquare gui square currentMove + handleMove gui newBoard currentMove + return (State newBoard currentMove difficulty) + +-- main function responsible for controlling the AI of the game +-- if the previous move has resulted in a win or a full board, +-- then we return the State which was passed initially. +-- Otherwise we ask the agent for a move to return, and set its controls. +getAgentAns gui st@(State board currentMove difficulty) = do + setSquare gui (fromInteger $ head $ accessHistory newBoard) (accessCurrentMove newBoard) + handleMove gui (accessMaybeMove newBoard) (accessCurrentMove newBoard) + return (State (accessMaybeMove newBoard) (getOtherMove (accessCurrentMove newBoard)) difficulty) + where newBoard = if (wins currentMove board) || (full board) then toTableMove board (findHistory board) currentMove + else ans board currentMove difficulty + + +-- we set the difficulty into the State Monad +setDifficulty newDifficulty st@(State board currentMove difficulty) = do + return (State board currentMove newDifficulty) + +-- check whether a board is won or full +handleMove gui board currentMove + | wins currentMove board = do + setStatus gui ("Player " ++ thisMove currentMove ++ " wins!") + disableBoard gui + | full board = do + setStatus gui "It's a draw." + disableBoard gui + | otherwise = do + setStatus gui ("Player " ++ thisMove (getOtherMove currentMove) ++ ": make your move") + where thisMove (Just X) = "Cross" + thisMove (Just O) = "Nought" + +main = do + initGUI + + -- Extract widgets from the glade xml file + Just xml <- xmlNew "noughty.glade" + + window <- xmlGetWidget xml castToWindow "window" + window `onDestroy` mainQuit + + newGame <- xmlGetWidget xml castToMenuItem "newGame" + quit <- xmlGetWidget xml castToMenuItem "quit" + + easy <- xmlGetWidget xml castToMenuItem "easy" + medium <- xmlGetWidget xml castToMenuItem "medium" + hard <- xmlGetWidget xml castToMenuItem "hard" + + squares <- flip mapM [1..9] $ \n -> do + square <- xmlGetWidget xml castToButton ("button" ++ show n) + -- we set this in the glde file but it doesn't seem to work there. + set square [ widgetCanFocus := False ] + return square + + images <- flip mapM [1..9] $ \n -> do + xmlGetWidget xml castToImage ("image" ++ show n) + + statusbar <- xmlGetWidget xml castToStatusbar "statusbar" + ctx <- statusbarGetContextId statusbar "state" + statusbarPush statusbar ctx "Player Cross: make your move." + + -- Construct the GUI actions that abstracts from the actual widgets + gui <- guiActions squares images statusbar ctx + + -- Initialize the state + state <- newIORef State { board = empty, turn = (Just X), difficulty = 1 } + let modifyState f = readIORef state >>= f >>= writeIORef state + + -- Add action handlers + onActivateLeaf quit mainQuit + onActivateLeaf newGame $ modifyState $ reset gui + + onActivateLeaf easy $ modifyState $ setDifficulty 2 + onActivateLeaf medium $ modifyState $ setDifficulty 4 + onActivateLeaf hard $ modifyState $ setDifficulty 6 + + zipWithM_ (\square i -> + onPressed square $ do + modifyState $ occupy gui i + modifyState $ getAgentAns gui) + squares [0..8] + + widgetShowAll window + mainGUI + +guiActions buttons images statusbar ctx = do + noughtPic <- pixbufNewFromFile "Nought.png" + crossPic <- pixbufNewFromFile "Cross.png" + return GUI { + disableBoard = mapM_ (flip widgetSetSensitivity False) buttons, + resetBoard = do + mapM_ (\i -> imageClear i >> widgetQueueDraw i) images + mapM_ (flip widgetSetSensitivity True) buttons, + setSquare = \ i player -> + case player of + Just X -> set (images !! i) [ imagePixbuf := crossPic ] + Just O -> set (images !! i) [ imagePixbuf := noughtPic ], + setStatus = \msg -> do + statusbarPop statusbar ctx + statusbarPush statusbar ctx msg + return () + } diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,1 @@ +This program installs the program tic-tac-toe, which uses gtk to render the graphics. It uses a minimax algorithm with alpha-beta pruning on the inside to determine best moves and play against you. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +>import Distribution.Simple +>main = defaultMain diff --git a/noughty.glade b/noughty.glade new file mode 100644 --- /dev/null +++ b/noughty.glade @@ -0,0 +1,341 @@ + + + + + + Noughty + False + + + True + + + True + + + True + _Game + True + + + + + True + _New Game + True + + + + + + True + + + + + True + _Quit + True + + + + + + + + + True + _Difficulty + True + + + + + True + _Easy + True + + + + + True + + + + + True + _Medium + True + + + + + True + + + + + True + _Hard + True + + + + + + + + + False + False + + + + + True + 10 + 5 + 5 + + + True + + + 5 + 1 + 2 + GTK_FILL + GTK_FILL + + + + + True + + + 1 + 2 + 5 + GTK_FILL + GTK_FILL + + + + + True + + + 3 + 4 + 5 + GTK_FILL + GTK_FILL + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 2 + 3 + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 4 + 5 + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 2 + 3 + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 2 + 3 + 2 + 3 + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 4 + 5 + 2 + 3 + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 4 + 5 + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 2 + 3 + 4 + 5 + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + 0 + + + True + + + + + 4 + 5 + 4 + 5 + + + + + True + + + 5 + 3 + 4 + GTK_FILL + GTK_FILL + + + + + 1 + + + + + True + False + + + False + False + 2 + + + + + + diff --git a/tic-tac-toe.cabal b/tic-tac-toe.cabal new file mode 100644 --- /dev/null +++ b/tic-tac-toe.cabal @@ -0,0 +1,17 @@ +Name: tic-tac-toe +Version: 0.1 +Description: An attempt to implement the minimax algorithm using tic-tac-toe +License: BSD3 +License-file: LICENSE +Author: Hristo Asenov +Maintainer: asenov79@students.rowan.edu +Homepage: http://ecks.homeunix.net +Synopsis: Useful if reading "Why FP matters" by John Hughes +Category: Game +build-type: Simple +Data-files: Cross.png, Nought.png, noughty.glade +Extra-source-files: MyTree.hs, GetAgentMove.hs, GetValue.hs, DataTypes.hs, README +Build-Depends: base, gtk, glade, haskell98 + +Executable: tic-tac-toe +Main-is: NoughtyGlade.hs