diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Robin KAY + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Robin KAY nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsqml-morris.cabal b/hsqml-morris.cabal new file mode 100644 --- /dev/null +++ b/hsqml-morris.cabal @@ -0,0 +1,36 @@ +Name: hsqml-morris +Version: 0.1.0 +Cabal-version: >= 1.10 +Build-type: Simple +License: BSD3 +License-file: LICENSE +Copyright: (c) 2012 Robin KAY +Author: Robin KAY +Maintainer: komadori@gekkou.co.uk +Stability: experimental +Homepage: http://www.gekkou.co.uk/ +Category: Graphics, Game +Synopsis: HsQML-based implementation of Nine Men's Morris +Data-dir: qml +Data-files: *.qml *.js *.svg +Description: + HsQML-based implementation of Nine Men's Morris + +Executable hsqml-morris + Default-language: Haskell2010 + Hs-source-dirs: src + Main-is: Morris/Main.hs + Other-modules: + Morris.Main + Morris.Board + Build-depends: + base == 4.*, + containers == 0.4.*, + directory == 1.1.*, + network == 2.3.*, + OddWord == 1.0.*, + hsqml == 0.1.* + +Source-repository head + type: darcs + location: https://patch-tag.com/r/komadori/hsqml-morris diff --git a/qml/black.svg b/qml/black.svg new file mode 100644 --- /dev/null +++ b/qml/black.svg @@ -0,0 +1,6 @@ + + + + + diff --git a/qml/board.svg b/qml/board.svg new file mode 100644 --- /dev/null +++ b/qml/board.svg @@ -0,0 +1,11 @@ + + + + diff --git a/qml/morris.js b/qml/morris.js new file mode 100644 --- /dev/null +++ b/qml/morris.js @@ -0,0 +1,122 @@ +var game = null; +var prevGame = null; +var redAI = 0; +var blackAI = 2; +var aiMove = []; + +function updateTargets() +{ + var next = game.targets; + var count = next.count; + var targets = []; + for (var i=0; i 0) { + if (0 == aiMove.length) { + var move = game.getAIMove(d); + for (var j=move.count-1; j>=0; j--) { + aiMove.push(move.elem(j)); + } + } + if (0 != aiMove.length) { + selectTarget(aiMove.pop()); + } + } + else { + updateTargets(); + } +} + +function isPlayerAI(p) +{ + switch (p) { + case 'red': return redAI; + case 'black': return blackAI; + } +} + +function posIdToX(i) +{ + switch (i) { + case 0: case 9: case 21: return 40; + case 3: case 10: case 18: return 80; + case 6: case 11: case 15: return 120; + case 1: case 4: case 7: case 16: case 19: case 22: return 160; + case 8: case 12: case 17: return 200; + case 5: case 13: case 20: return 240; + case 2: case 14: case 23: return 280; + } +} + +function posIdToY(i) +{ + switch (i) { + case 0: case 1: case 2: return 40; + case 3: case 4: case 5: return 80; + case 6: case 7: case 8: return 120; + case 9: case 10: case 11: case 12: case 13: case 14: return 160; + case 15: case 16: case 17: return 200; + case 18: case 19: case 20: return 240; + case 21: case 22: case 23: return 280; + } +} diff --git a/qml/morris.qml b/qml/morris.qml new file mode 100644 --- /dev/null +++ b/qml/morris.qml @@ -0,0 +1,52 @@ +import Qt 4.7 +import "morris.js" as Morris + +Image { + id: board; + source: "board.svg"; + fillMode: Image.PreserveAspectFit; + anchors.fill: parent; + + property real t; + + SequentialAnimation on t { + id: anim; + NumberAnimation { + from: 0; + to: 1; + duration: 300; + } + ScriptAction { + script: Morris.animFinished(); + } + } + + Repeater { + id: pieceView + model: []; + Image { + source: modelData.red ? "red.svg" : "black.svg"; + opacity: (modelData.endVis*t)+(modelData.startVis*(1-t)); + x: (Morris.posIdToX(modelData.endIdx)*t)+(Morris.posIdToX(modelData.startIdx)*(1-t))-width/2; + y: (Morris.posIdToY(modelData.endIdx)*t)+(Morris.posIdToY(modelData.startIdx)*(1-t))-height/2; + } + } + + Repeater { + id: targetView + model: []; + Image { + source: "target.svg"; + x: Morris.posIdToX(modelData)-width/2; + y: Morris.posIdToY(modelData)-height/2; + MouseArea { + anchors.fill: parent; + onClicked: Morris.selectTarget(modelData); + } + } + } + + Component.onCompleted: { + Morris.setupGame(); + } +} diff --git a/qml/red.svg b/qml/red.svg new file mode 100644 --- /dev/null +++ b/qml/red.svg @@ -0,0 +1,6 @@ + + + + + diff --git a/qml/target.svg b/qml/target.svg new file mode 100644 --- /dev/null +++ b/qml/target.svg @@ -0,0 +1,6 @@ + + + + + diff --git a/src/Morris/Board.hs b/src/Morris/Board.hs new file mode 100644 --- /dev/null +++ b/src/Morris/Board.hs @@ -0,0 +1,221 @@ +module Morris.Board where + +import Data.Word +import Data.Word.Odd +import Data.Bits +import Data.Maybe +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Debug.Trace +import Numeric + +newtype Board = Board Word64 deriving (Eq, Ord, Show) + +newtype Position = Position Int deriving (Eq, Ord, Show) + +data FirstAction + = Place Position + | Move Position Position + deriving (Show) + +newtype SecondAction + = Take Position + deriving (Show) + +data Action + = FirstAction FirstAction + | SecondAction SecondAction + deriving (Show) + +data Move = FullMove { + fstAction :: FirstAction, + sndAction :: Maybe SecondAction} + deriving (Show) + +data Player = Red | Black deriving (Eq, Show) + +opponent :: Player -> Player +opponent Red = Black +opponent Black = Red + +setBoardPosition :: Maybe Player -> Position -> Board -> Board +setBoardPosition posVal (Position posN) (Board rawBoard) = + let encode Nothing = 0 + encode (Just Red) = 1 + encode (Just Black) = 2 + idx = 2 * posN + value = encode posVal `shiftL` idx + mask = complement $ shiftL 3 idx + in Board $ (.|.) value $ (.&.) mask rawBoard + +getBoardPosition :: Position -> Board -> Maybe Player +getBoardPosition (Position posN) (Board rawBoard) = + let decode 0 = Nothing + decode 1 = Just Red + decode 2 = Just Black + idx = 2 * posN + in decode $ (.&.) 3 $ shiftR rawBoard idx + +handCountBitIdx :: Player -> Int +handCountBitIdx Red = 48 +handCountBitIdx Black = 52 + +setBoardHandCount :: Word4 -> Player -> Board -> Board +setBoardHandCount count player (Board rawBoard) = + let idx = handCountBitIdx player + value = fromIntegral count `shiftL` idx + mask = complement $ shiftL 0xF idx + in Board $ (.|.) value $ (.&.) mask rawBoard + +getBoardHandCount :: Player -> Board -> Word4 +getBoardHandCount player (Board rawBoard) = + let idx = handCountBitIdx player + in fromIntegral $ (.&.) 0xF $ shiftR rawBoard idx + +setBoardNextPlayer :: Player -> Board -> Board +setBoardNextPlayer player (Board rawBoard) = + let adjBit Red = flip clearBit 63 + adjBit Black = flip setBit 63 + in Board $ adjBit player rawBoard + +getBoardNextPlayer :: Board -> Player +getBoardNextPlayer (Board rawBoard) = + let toPlayer False = Red + toPlayer True = Black + in toPlayer $ testBit rawBoard 63 + +newBoard :: Board +newBoard = + setBoardHandCount 9 Red $ setBoardHandCount 9 Black $ Board 0 + +allPositions :: [Position] +allPositions = + map Position [0..23] + +millPositions :: [[Position]] +millPositions = + map (map Position) $ + map (\n -> [n..2+n]) [0,3..23] ++ [ + [0,9,21],[3,10,18],[6,11,15], + [1,4,7],[16,19,22], + [8,12,17],[5,13,20],[2,14,23]] + +adjacencyMap :: Map Position [Position] +adjacencyMap = + let ps = concatMap (\x@(k,v) -> [x,(v,k)]) $ + concatMap (\m -> zip m (tail m)) millPositions + in foldr (\(k,v) m -> Map.insertWith' (++) k [v] m) Map.empty ps + +getPlayerPieces :: Player -> Board -> [Position] +getPlayerPieces player board = + filter (\p -> Just player == getBoardPosition p board) allPositions + +getPlayerMills :: Player -> Board -> [[Position]] +getPlayerMills player board = + filter (all (\p -> Just player == getBoardPosition p board)) millPositions + +playFirstAction :: Player -> FirstAction -> Board -> Board +playFirstAction player (Place p) board = + setBoardPosition (Just player) p $ + setBoardHandCount (getBoardHandCount player board - 1) player board +playFirstAction player (Move p p') board = + setBoardPosition (Just player) p' $ + setBoardPosition Nothing p board + +playSecondAction :: SecondAction -> Board -> Board +playSecondAction (Take pos) = + setBoardPosition Nothing pos + +playNext :: Board -> Board +playNext board = + setBoardNextPlayer (opponent $ getBoardNextPlayer board) board + +playMove :: Move -> Board -> Board +playMove move board = + let player = getBoardNextPlayer board + pm (FullMove act1 Nothing) = + playNext . playFirstAction player act1 + pm (FullMove act1 (Just act2)) = + playNext . playSecondAction act2 . playFirstAction player act1 + in pm move board + +partialToFullMoves :: Player -> Board -> FirstAction -> [Move] +partialToFullMoves player board act1 = + let board' = playFirstAction player act1 board + mills = getPlayerMills player board + mills' = getPlayerMills player board' + newMills = not $ null $ mills' \\ mills + oPlayer = opponent player + oPieces = getPlayerPieces oPlayer board + oVulnerable = oPieces \\ (concat $ getPlayerMills oPlayer board) + oTakeable = if null oVulnerable then oPieces else oVulnerable + moves = map (FullMove act1 . Just . Take) oTakeable + in if newMills && (not $ null oTakeable) + then moves else [FullMove act1 Nothing] + +placeMoves :: Board -> [FirstAction] +placeMoves board = map Place $ filter (\p -> + isNothing $ getBoardPosition p board) allPositions + +adjMoves :: Player -> Board -> [FirstAction] +adjMoves player board = concatMap (\p -> map (\p' -> Move p p') $ + filter (isNothing . flip getBoardPosition board) $ + fromJust $ Map.lookup p adjacencyMap) $ + getPlayerPieces player board + +legalMoves :: Board -> [Move] +legalMoves board = + let player = getBoardNextPlayer board + inHand = getBoardHandCount player board > 0 + moves = if inHand + then placeMoves board + else adjMoves player board + in concatMap (partialToFullMoves player board) moves + +winValue :: Float +winValue = 1000.0 + +evalBoard :: Player -> Board -> (Maybe Player, Float) +evalBoard player board = + let pa = fromIntegral (getBoardHandCount player board) + + fromIntegral (length $ getPlayerPieces player board) + fa = fromIntegral $ length $ adjMoves player board + ma = fromIntegral $ length $ getPlayerMills player board + oPlayer = opponent player + pb = fromIntegral (getBoardHandCount oPlayer board) + + fromIntegral (length $ getPlayerPieces oPlayer board) + fb = fromIntegral $ length $ adjMoves oPlayer board + mb = fromIntegral $ length $ getPlayerMills oPlayer board + in case () of + _ | 0 == fb || pb < 3 -> (Just Red, winValue) + | 0 == fa || pa < 3 -> (Just Black, -winValue) + | otherwise -> (Nothing, 1.0*(pa-pb)+0.2*(fa-fb)+0.8*(ma-mb)) + +evalTree :: Board -> Int -> Float -> Float -> Float +evalTree board depth alpha beta = + let player = getBoardNextPlayer board + (win, value) = evalBoard player board + terminal = isJust win || depth == 0 + moves = legalMoves board + next (m:ms) alpha' = + let board' = playMove m board + value' = -0.95 * evalTree board' (depth-1) (-beta) (-alpha') + in if value' >= beta then value' else + if value' >= alpha' + then next ms value' else next ms alpha' + next [] alpha' = alpha' + in if terminal then value else next moves alpha + +aiMove :: Int -> Map Board Float -> Board -> Maybe Move +aiMove depth bias board = + let moves = legalMoves board + moveVals = zip moves $ map (\m -> + let board' = playMove m board + in -evalTree board' (2*depth-1) (-1/0) (1/0) + + (fromMaybe 0 $ Map.lookup board' bias)) moves + move = fst $ foldr (\(m,v) b@(bm,bv) -> + if isNothing bm + then (Just m,v) + else (if v>bv then (Just m,v) else b)) (Nothing,-1/0) moveVals + in move diff --git a/src/Morris/Main.hs b/src/Morris/Main.hs new file mode 100644 --- /dev/null +++ b/src/Morris/Main.hs @@ -0,0 +1,199 @@ +{-# 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 +