{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
module Main where

import Morris.Board

import Graphics.QML
import Control.Concurrent
import Control.DeepSeq
import Control.Exception
import Data.List
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map

import Paths_hsqml_demo_morris

newtype IdBoard = IdBoard (IntMap (Player, Position))

newIdBoard :: IdBoard
newIdBoard =
    IdBoard IntMap.empty

boardToId :: Board -> IdBoard
boardToId board =
    IdBoard $ fst $ foldr (\pl mn ->
        foldr (\ps (m,n) ->
            (IntMap.insert n (pl,ps) m,n+1)) mn $
        getPlayerPieces pl board) (IntMap.empty,0) [Red,Black]

findPieceId :: Position -> IdBoard -> Int
findPieceId pos (IdBoard m) =
    IntMap.foldrWithKey (\k' (_,pos') k -> if pos == pos' then k' else k) 0 m

playFirstActionId :: Player -> FirstAction -> IdBoard -> IdBoard
playFirstActionId player (Place p) (IdBoard m) =
    let i = if IntMap.null m then 0 else 1 + (fst $ IntMap.findMax m)
    in IdBoard $ IntMap.insert i (player,p) m
playFirstActionId player (Move p p') ib@(IdBoard m) =
    let i = findPieceId p ib
    in IdBoard $ IntMap.insert i (player,p') m

playSecondActionId :: SecondAction -> IdBoard -> IdBoard
playSecondActionId (Take pos) ib@(IdBoard m) =
    let i = findPieceId pos ib
    in IdBoard $ IntMap.delete i m

playActionId :: Player -> Action -> IdBoard -> IdBoard
playActionId player (FirstAction act) = playFirstActionId player act
playActionId _ (SecondAction act) = playSecondActionId act

moveToActions :: Move -> [Action]
moveToActions (FullMove act1 Nothing) =
    [FirstAction act1]
moveToActions (FullMove act1 (Just act2)) =
    [FirstAction act1,SecondAction act2]

actionToPositions :: Action -> [Position]
actionToPositions (FirstAction (Place p1))   = [p1]
actionToPositions (FirstAction (Move p1 p2)) = [p1,p2]
actionToPositions (SecondAction (Take p1))   = [p1]

moveToPositions :: Move -> [Position]
moveToPositions = concatMap actionToPositions . moveToActions

instance Marshal Player where
    type MarshalMode Player c d = ModeBidi c
    marshaller = bidiMarshaller from to
        where from txt = case T.unpack txt of
                  "red" -> Red
                  _     -> Black
              to plyr = T.pack $ case plyr of
                  Red   -> "red"
                  Black -> "black"

instance Marshal Position where
    type MarshalMode Position c d = ModeBidi c
    marshaller = bidiMarshaller Position (\(Position i) -> i)

data GameObj = GameObj {
    gameBoard :: Board,
    gameIdBoard :: IdBoard,
    gameActions :: [Position],
    gameBias :: Map Board Float,
    gamePrev :: Maybe GameObj}
    deriving Typeable

data PieceObj = PieceObj {
    piecePlayer :: Player,
    piecePrevPos :: Maybe Position,
    pieceCurrPos :: Maybe Position}
    deriving (Typeable, Show)

instance DefaultClass PieceObj where
    classMembers = [
        defPropertyConst "player" $ return . piecePlayer,
        defPropertyConst "currPos" $ return . pieceCurrPos,
        defPropertyConst "prevPos" $ return . piecePrevPos]

instance Marshal PieceObj where
    type MarshalMode PieceObj c d = ModeObjFrom PieceObj c
    marshaller = fromMarshaller fromObjRef

getPlayer :: GameObj -> IO Player
getPlayer = return . getBoardNextPlayer . gameBoard

getPieces :: GameObj -> IO [ObjRef PieceObj]
getPieces gs =
    let (IdBoard ib) = gameIdBoard $ fromMaybe gs $ gamePrev gs
        (IdBoard ib') = gameIdBoard gs
        merge _ (plyr,p) (_,p') = Just $ PieceObj plyr (Just p) (Just p')
        oldMap = fmap $ \(plyr,p) -> PieceObj plyr (Just p) Nothing
        newMap = fmap $ \(plyr,p') -> PieceObj plyr Nothing (Just p')
        ps = IntMap.elems $ IntMap.mergeWithKey merge oldMap newMap ib ib'
    in mapM newObjectDC ps
 
getTargets :: GameObj -> IO [Position]
getTargets gs =
    let actions = gameActions gs
        posOff  = length actions
    in return $ nub $ map (!! posOff) $
        filter (isPrefixOf actions) $ map moveToPositions $
        legalMoves $ gameBoard gs

getActions :: GameObj -> IO [Position]
getActions = return . gameActions

startAI :: ObjRef GameObj -> Int -> IO ()
startAI gsRef d = fmap (const ()) $ forkIO $ do
    let gs = fromObjRef gsRef
        ps = maybe [] moveToPositions $ aiMove d (gameBias gs) $ gameBoard gs
    evaluate $ force ps
    fireSignal (Proxy :: Proxy AIReady) gsRef ps

selectTarget :: GameObj -> Int -> IO (ObjRef GameObj)
selectTarget gs i =
    let actions' = gameActions gs ++ [Position i]
        board = gameBoard gs
        iboard = gameIdBoard gs
        player = getBoardNextPlayer board
        moves = legalMoves board
        maybeMove = fmap fst $ find ((actions' ==) . snd) $
            zip moves $ map moveToPositions moves
        board' = maybe board (\m -> playMove m board) maybeMove
        actionLists = concatMap (tail . inits . moveToActions) moves
        actionTargets = map (\as ->
            (last as, concatMap actionToPositions as)) actionLists
        maybeAction = fmap fst $ find ((actions' ==) . snd) actionTargets
        iboard' = maybe iboard (\a -> playActionId player a iboard) maybeAction
    in newObjectDC $ case maybeMove of
        Just move -> gs {
            gameBoard = board',
            gameIdBoard = iboard',
            gameActions = [],
            gameBias = {-Map.map (*0.9) $-} Map.alter (\x ->
                Just $ fromMaybe 0 x - 0.5) board' $ gameBias gs,
            gamePrev = Just gs}
        Nothing -> gs {
            gameIdBoard = iboard',
            gameActions = actions',
            gamePrev = Just gs}

data AIReady deriving Typeable

instance SignalKeyClass AIReady where
    type SignalParams AIReady = [Position] -> IO ()

instance DefaultClass GameObj where
    classMembers = [
        defPropertyRO "player" getPlayer,
        defPropertyRO "pieces" getPieces,
        defPropertyRO "targets" getTargets,
        defPropertyRO "actions" getActions,
        defMethod "startAI" startAI,
        defSignal "aiReady" (Proxy :: Proxy AIReady),
        defMethod "selectTarget" selectTarget]

instance Marshal GameObj where
    type MarshalMode GameObj c d = ModeObjFrom GameObj c
    marshaller = fromMarshaller fromObjRef

createGame :: ObjRef () -> IO (ObjRef GameObj)
createGame _ =
    newObjectDC $ GameObj newBoard newIdBoard [] Map.empty Nothing

main :: IO ()
main = do
    clazz <- newClass [defMethod "createGame" createGame]
    ctx <- newObject clazz ()
    qml <- getDataFileName "morris.qml"
    runEngineLoop defaultEngineConfig {
        initialDocument = fileDocument qml,
        contextObject = Just $ anyObjRef ctx}