module TTTLogic where

import Data.List -- sortBy

-- Tic Tac Toe

type Color = Bool
white = True
black = False

type Pos = (Int, Int)
xsize = 3
ysize = 3
xcoords = [0..xsize-1]
ycoords = [0..ysize-1]
positions = [ (x,y) | x <- xcoords, y <- ycoords ]

-- a row, column, or diagonal
type Seq = [Pos]
rows  = [ [ (x,y) | x <- xcoords ] | y <- ycoords ]
cols  = [ [ (x,y) | y <- ycoords ] | x <- xcoords ]

diags :: [Seq]
diags = [ [ (x,x) | x <- xcoords ] , [ (x,xsize-1-x) | x <- xcoords] ]

seqs :: [Seq]
seqs = rows ++ cols ++ diags

type Board a = Pos -> a
emptyBoard (x,y) = Nothing

instance Show a => Show (Board a) where
  show f = show $ map (map f) rows

type Lost = Bool  -- has the current player lost?

data State = State { turn  :: Color
                   , lost  :: Lost
                   , board :: Board (Maybe Color)
                   , lastMove :: Pos
                   } deriving Show

-- winner and evaluation function

ownsSeq :: (Eq a) => a -> Board (Maybe a) -> Seq -> Bool
ownsSeq b board = all (\ p -> board p == Just b)

{-
won :: State -> Bool
won st = any (ownsSeq st) seqs

lost :: State -> Bool
lost (b, board) = won (not b, board)
-}

-- evaluation of a board is relative to the player who's turn it is
static :: State -> Int
static st = if lost st then -1 else 0

-- moves

-- puts a piece of the current player at |pos| and calculates
-- if this is a winning move (so the next player has lost)
put :: Pos -> State -> Maybe State
put (x,y) (State b _ board _) = case board (x,y) of
   Nothing -> Just (State (not b) l board' (x,y))
     where board' (x',y') = 
                    if (x,y) == (x',y') then Just b else board (x',y')
           seqs = [ (x,y') | y' <- ycoords] :
                  [ (x',y) | x' <- xcoords] : (filter (elem (x,y)) diags)
           l    = any (ownsSeq b board') seqs 
   Just _ -> Nothing
   
moves :: State -> [State]
moves st = if lost st then [] 
            else foldl (\ moves pos -> maybe moves (:moves) (put pos st)) 
                   [] 
                   positions

-- alpha - beta search

data NTree a = Branch a [NTree a] deriving (Show,Read,Eq)

repTree :: (a -> [a]) -> a -> NTree a
repTree f a = Branch a (map (repTree f) (f a))

mapTree :: (a -> b) -> NTree a -> NTree b
mapTree f (Branch x xs) = Branch (f x) (map (mapTree f) xs)


maximise :: (Num a, Ord a) => NTree a -> a
maximise (Branch x []) = x
maximise (Branch x xs) = - minimum (map maximise xs)

{- BUGGY
maximise :: (Num a, Ord a) => NTree a -> a
maximise (Branch   1  _)  = 1  -- cut-off if already won
maximise (Branch (-1) _)  = -1 -- cut-off if already lost
maximise (Branch x []) = x
maximise (Branch x xs) = maximum (map minimise xs)

minimise :: (Num a, Ord a) => NTree a -> a
minimise (Branch   1  _)  = 1  -- cut-off if already won
minimise (Branch (-1) _)  = -1 -- cut-off if already lost
minimise (Branch x []) = x
minimise (Branch x xs) = minimum (map maximise xs)
-}

prune :: Int -> NTree a -> NTree a
prune 0     (Branch x xs) = Branch x []
prune (n+1) (Branch x xs) = Branch x (map (prune n) xs)

evaluate depth = maximise . mapTree static . prune depth . repTree moves

answers depth = sortBy (\ (i,_) (j,_) -> compare i j) .
  map (\ state' -> (evaluate depth state', state')) . moves


initSt = State True False emptyBoard (-1,-1)

test depth = evaluate depth initSt