{-# 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
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 DefaultClass PosListObj where
classMembers = [
defMethod "elem" posListElem,
defPropertyRO "count" posListCount]
instance Marshal PosListObj where
type MarshalMode PosListObj c d = ModeObjFrom PosListObj c
marshaller = fromMarshaller fromObjRef
data GameObj = GameObj {
gameBoard :: Board,
gameIdBoard :: IdBoard,
gameActions :: [Position],
gameBias :: Map Board Float}
deriving Typeable
getPlayer :: GameObj -> IO Text
getPlayer gs =
return $ case getBoardNextPlayer $ gameBoard gs of
Red -> T.pack "red"
Black -> T.pack "black"
getTargets :: GameObj -> IO (ObjRef PosListObj)
getTargets gs =
let actions = gameActions gs
posOff = length actions
in newObjectDC $ PosListObj $ nub $ map (!! posOff) $
filter (isPrefixOf actions) $ map moveToPositions $
legalMoves $ gameBoard gs
getActions :: GameObj -> IO (ObjRef PosListObj)
getActions gs =
newObjectDC $ PosListObj $ gameActions gs
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
posObj <- newObjectDC $ PosListObj ps
fireSignal (Proxy :: Proxy AIReady) gsRef posObj
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}
Nothing -> gs {
gameIdBoard = iboard',
gameActions = actions'}
getIndexCount :: GameObj -> IO Int
getIndexCount gs =
return $ getIdBoardCount $ gameIdBoard gs
getPlayerAtIndex :: GameObj -> Int -> IO Text
getPlayerAtIndex gs i =
return $ case getIdBoardPiece i $ gameIdBoard gs of
Nothing -> T.pack "none"
Just (Red,_) -> T.pack "red"
Just (Black,_) -> T.pack "black"
getPositionAtIndex :: GameObj -> Int -> IO Int
getPositionAtIndex gs i =
return $ case getIdBoardPiece i $ gameIdBoard gs of
Nothing -> -1
Just (_,Position pos) -> pos
data AIReady deriving Typeable
instance SignalKeyClass AIReady where
type SignalParams AIReady = ObjRef PosListObj -> IO ()
instance DefaultClass GameObj where
classMembers = [
defPropertyRO "player" getPlayer,
defPropertyRO "targets" getTargets,
defPropertyRO "actions" getActions,
defMethod "startAI" startAI,
defSignal "aiReady" (Proxy :: Proxy AIReady),
defMethod "selectTarget" selectTarget,
defPropertyRO "indexCount" getIndexCount,
defMethod "idxPlayer" getPlayerAtIndex,
defMethod "idxPosition" getPositionAtIndex]
instance Marshal GameObj where
type MarshalMode GameObj c d = ModeObjFrom GameObj c
marshaller = fromMarshaller fromObjRef
createGame :: ObjRef MainObj -> IO (ObjRef GameObj)
createGame _ =
newObjectDC $ GameObj newBoard newIdBoard [] Map.empty
data MainObj = MainObj deriving Typeable
instance DefaultClass MainObj where
classMembers = [
defMethod "createGame" createGame]
main :: IO ()
main = do
ctx <- newObjectDC $ MainObj
qml <- getDataFileName "morris.qml"
runEngineLoop defaultEngineConfig {
initialDocument = fileDocument qml,
contextObject = Just $ anyObjRef ctx}