{-----------------------------------------------------------------------------
    reactive-banana-threepenny
    
    Example: TicTacToe.
    Original Author: Gideon Sireling
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"

import Control.Monad
import Data.Array
import Data.List hiding (union)
import Data.Maybe

import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core hiding (Event, filterJust)

import Reactive.Banana
import Reactive.Banana.Threepenny

import Paths

{-----------------------------------------------------------------------------
    User Interface
------------------------------------------------------------------------------}
main :: IO ()
main = do
    startGUI Config
        { tpPort       = 10000
        , tpCustomHTML = Nothing
        , tpStatic     = ""
        } setup

-- | Load images corresponding to tokens.
loadToken2URL :: Window -> IO (Token -> String)
loadToken2URL window = do
    let loadPng name = loadFile window "image/png" =<< getDataFile (name ++ ".png")
    [none, x, o] <- mapM loadPng ["empty","cross","circle"]
    return $ \token -> case token of { None -> none; X -> x; O -> o; }

-- | Set up user interface.
setup :: Window -> IO ()
setup window = do
    return window # set title "Tic Tac Toe"

    token2url <- loadToken2URL window
    
    status <- UI.div # set text "Player: X"
    let repeat n = sequence . replicate n
    fields <- repeat 3 $ repeat 3 $
        UI.img # set UI.src (token2url None) # set style [("border","1px solid black")]
    
    getBody window #+ [grid $ map (map element) fields, element status] 


    let networkDescription :: forall t. Frameworks t => Moment t ()
        networkDescription = do
            events <- concat <$> mapM (mapM (event UI.click)) fields
            
            let
                moves :: Event t (Game -> Game)
                moves = foldl1 union $ zipWith (\e s -> move s <$ e) events
                        [(x,y) | y <- [1..3], x <- [1..3]]
                
                state :: Behavior t Game
                state = accumB newGame moves

                currentPlayer :: Behavior t Token
                currentPlayer = player <$> state
                
                tokens :: [Behavior t Token]
                tokens = map (\e -> stepper None (currentPlayer <@ e)) events
        
            zipWithM_
                (\field token -> return field # sink UI.src (token2url <$> token))
                (concat fields)
                tokens
        
            return status # sink text (("Player: " ++) . show <$> currentPlayer)
            
            -- end game event handler
            eState <- changes state
            reactimate $ end window <$> filterJust (isGameEnd . board <$> eState)
    
    network <- compile networkDescription    
    actuate network


end :: Window -> Token -> IO ()
end window result = do
    alert window $
        case result of
            X    -> "X won!"
            O    -> "O won!"
            None -> "Draw!"
    clear window

alert w s = runFunction w (ffi "alert(%1)" s)

{-----------------------------------------------------------------------------
    Game Logic
------------------------------------------------------------------------------}
data Token = None | X | O
    deriving Eq

-- |The coordinates of a square.
type Square = (Int,Int)

-- |A noughts and crosses board.
type Board = Array Square Token

-- |Returns an empty 'Board'.
newBoard :: Board
newBoard = listArray ((1,1),(3,3)) (repeat None)

-- |Puts a 'Token' in a 'Square'.
setSquare :: Board -> Square -> Token -> Board
setSquare board square token =
    if (board ! square) /= None
    then error $ "square " ++ show square ++ " is not empty"
    else board // [(square, token)]

-- |Determine if the 'Board' is in an end state.
--  Returns 'Just' 'Token' if the game has been won,
-- 'Just' 'None' for a draw, otherwise 'Nothing'.
isGameEnd :: Board -> Maybe Token
isGameEnd board
    | Just X `elem` maybeWins = Just X
    | Just O `elem` maybeWins = Just O
    | None `notElem` elems board = Just None
    | otherwise = Nothing

    where rows :: [[Square]]
          rows = let i = [1..3]
                 in [[(x,y) | y <- i] | x <- i] ++ -- rows
                    [[(y,x) | y <- i] | x <- i] ++ -- coloumns
                    [[(x,x) | x <- i], [(x,4-x) | x <- i]] -- diagonals

          rows2tokens :: [[Token]]
          rows2tokens = map (map (board !)) rows

          isWin :: [Token] -> Maybe Token
          isWin tokens
              | all (==X) tokens = Just X
              | all (==O) tokens = Just O
              | otherwise = Nothing

          maybeWins :: [Maybe Token]
          maybeWins = map isWin rows2tokens

-- |The state of a game, i.e. the player who's turn it is, and the current board.
data Game = Game { player :: Token, board :: Board }

newGame :: Game
newGame = Game X newBoard

-- |Puts the player's token on the specified square.
-- Returns 'Just' 'Token' if the game has been won,
-- 'Just' 'None' for a draw, otherwise 'Nothing'.
move :: Square -> Game -> Game
move square (Game player board) = Game player' board'
    where
    board'  = setSquare board square player
    player' = case player of {X -> O; O -> X}

{-----------------------------------------------------------------------------
    Show instances
------------------------------------------------------------------------------}
outersperse :: a -> [a] -> [a]
outersperse x ys = x : intersperse x ys ++ [x]

instance Show Token where
    show X = "X"
    show O = "O"
    show None = " "
    showList tokens = showString $ outersperse '|' $ concatMap show tokens

-- Board cannot be declared an instance of Show,
-- as this would overlap with the existing instance for Array.
showBoard :: Board -> String
showBoard board =
    let border = " +-+-+-+"
        i = [1..3]
        showRow x = show x ++ show [board ! (y,x) | y <- i]
    in intercalate "\n" $ "  1 2 3" : outersperse border (map showRow i)

instance Show Game where
    show (Game player board) = showBoard board ++ "\n\nTurn: " ++ show player