packages feed

hsqml-morris (empty) → 0.1.0

raw patch · 11 files changed

+691/−0 lines, 11 filesdep +OddWorddep +basedep +containerssetup-changed

Dependencies added: OddWord, base, containers, directory, hsqml, network

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsqml-morris.cabal view
@@ -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
+ qml/black.svg view
@@ -0,0 +1,6 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+     viewBox="-15 -15 30 30">+<circle cx="0" cy="0" r="15" fill="black" />+</svg>+
+ qml/board.svg view
@@ -0,0 +1,11 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+     viewBox="0 0 320 320">+<path d="+M  40  40 l 240 0 l 0 240 l -240 0 z+M  80  80 l 160 0 l 0 160 l -160 0 z+M 120 120 l  80 0 l 0  80 l -80  0 z+M  40 160 l 80 0 M 160  40 l 0 80+M 200 160 l 80 0 M 160 200 l 0 80"+stroke="black" fill="none" /> +</svg>
+ qml/morris.js view
@@ -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<count; i++) {+        targets.push(next.elem(i));+    }+    targetView.model = targets;+}++function clearTargets()+{+    targetView.model = [];+}++function updatePieces()+{+    var count = game.indexCount;+    var pieces = [];+    var hasAnim = false;+    for (var i=0; i<count; i++) {+        var currIdx = game.idxPosition(i);+        var prevIdx = prevGame.idxPosition(i);++        if (-1 != prevIdx || -1 != currIdx) {+            var startIdx = (-1 != prevIdx) ? prevIdx : currIdx;+            var endIdx = (-1 != currIdx) ? currIdx : prevIdx;+            var startVis = (-1 != prevIdx) ? 1 : 0;+            var endVis = (-1 != currIdx) ? 1 : 0;+            hasAnim |= (startIdx != endIdx) || (startVis != endVis);+            pieces.push({+                startIdx: startIdx,+                endIdx: endIdx,+                startVis: startVis,+                endVis: endVis,+                red: 'red' == game.idxPlayer(i)});+        }+    }+    pieceView.model = pieces;+    if (hasAnim) {+        anim.restart();+    }+    else {+        animFinished();+    }+}++function setupGame()+{+    game = createGame();+    prevGame = game;+    updateTargets();+    updatePieces();+}++function selectTarget(i)+{+    prevGame = game;+    game = game.selectTarget(i);+    clearTargets();+    updatePieces();+}++function animFinished()+{+    var d = isPlayerAI(game.player);+    if (d > 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;+    }+}
+ qml/morris.qml view
@@ -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();+    }+}
+ qml/red.svg view
@@ -0,0 +1,6 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+     viewBox="-15 -15 30 30">+<circle cx="0" cy="0" r="15" fill="red" />+</svg>+
+ qml/target.svg view
@@ -0,0 +1,6 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+     viewBox="-10 -10 20 20">+<path d="M 0 -10 L 10 0 L 0 10 L -10 0 Z" fill="yellow" opacity="0.5" />+</svg>+
+ src/Morris/Board.hs view
@@ -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
+ src/Morris/Main.hs view
@@ -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+