Main.hs

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

import Morris.Board

import Graphics.QML
import Data.Maybe
import Data.List
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_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

getIdBoardCount :: IdBoard -> Int
getIdBoardCount (IdBoard m) =
    if IntMap.null m then 0 else (1+) $ fst $ IntMap.findMax m

getIdBoardPiece :: Int -> IdBoard -> Maybe (Player,Position)
getIdBoardPiece i (IdBoard m) =
    IntMap.lookup i m

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

data PosListObj = PosListObj [Position] deriving Typeable

posListElem :: PosListObj -> Int -> IO Int
posListElem (PosListObj posList) idx =
    return $ (\(Position i) -> i) $ posList !! idx

posListCount :: PosListObj -> IO Int
posListCount (PosListObj posList) =
    return $ length posList

instance Object PosListObj where
    classDef = defClass [
        defMethod "elem" posListElem,
        defPropertyRO "count" posListCount]

instance MarshalThis PosListObj where
    type ThisObj PosListObj = PosListObj
    mThis = objectThisMarshaller

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

getPlayer :: GameObj -> IO String
getPlayer gs =
    return $ case getBoardNextPlayer $ gameBoard gs of
        Red   -> "red"
        Black -> "black"
 
getTargets :: GameObj -> IO (ObjRef PosListObj)
getTargets gs =
    let actions = gameActions gs
        posOff  = length actions
    in newObject $ PosListObj $ nub $ map (!! posOff) $
        filter (isPrefixOf actions) $ map moveToPositions $
        legalMoves $ gameBoard gs

getActions :: GameObj -> IO (ObjRef PosListObj)
getActions gs =
    newObject $ PosListObj $ gameActions gs

getAIMove :: GameObj -> Int -> IO (ObjRef PosListObj)
getAIMove gs d =
    newObject $ PosListObj $
    maybe [] moveToPositions $ aiMove d (gameBias gs) $ gameBoard gs

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 newObject $ 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}
        Nothing -> gs {
            gameIdBoard = iboard',
            gameActions = actions'}

getIndexCount :: GameObj -> IO Int
getIndexCount gs =
    return $ getIdBoardCount $ gameIdBoard gs

getPlayerAtIndex :: GameObj -> Int -> IO String
getPlayerAtIndex gs i =
    return $ case getIdBoardPiece i $ gameIdBoard gs of
        Nothing -> "none"
        Just (Red,_) -> "red"
        Just (Black,_) -> "black"

getPositionAtIndex :: GameObj -> Int -> IO Int
getPositionAtIndex gs i =
    return $ case getIdBoardPiece i $ gameIdBoard gs of
        Nothing -> -1
        Just (_,Position pos) -> pos

instance Object GameObj where
    classDef = defClass [
        defPropertyRO "player" getPlayer,
        defPropertyRO "targets" getTargets,
        defPropertyRO "actions" getActions,
        defMethod "getAIMove" getAIMove,
        defMethod "selectTarget" selectTarget,
        defPropertyRO "indexCount" getIndexCount,
        defMethod "idxPlayer" getPlayerAtIndex,
        defMethod "idxPosition" getPositionAtIndex]

instance MarshalThis GameObj where
    type ThisObj GameObj = GameObj
    mThis = objectThisMarshaller

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

data MainObj = MainObj deriving Typeable

instance Object MainObj where
    classDef = defClass [
        defMethod "createGame" createGame]

main :: IO ()
main = do
    ctx <- newObject $ MainObj
    qml <- getDataFileName "morris.qml"
    createEngine defaultEngineConfig {
        initialURL = filePathToURI qml,
        initialWindowState = ShowWindowWithTitle "HsQML Morris",
        contextObject = Just ctx}
    runEngines