hsqml-demo-morris 0.3.0.0 → 0.3.1.0
raw patch · 4 files changed
+84/−117 lines, 4 filesdep −taggeddep ~hsqmldep ~text
Dependencies removed: tagged
Dependency ranges changed: hsqml, text
Files
- hsqml-demo-morris.cabal +3/−4
- qml/morris.js +7/−36
- qml/morris.qml +16/−6
- src/Morris/Main.hs +58/−71
hsqml-demo-morris.cabal view
@@ -1,5 +1,5 @@ Name: hsqml-demo-morris-Version: 0.3.0.0+Version: 0.3.1.0 Cabal-version: >= 1.10 Build-type: Simple License: BSD3@@ -27,10 +27,9 @@ containers >= 0.4 && < 0.6, deepseq >= 1.2 && < 1.4, directory >= 1.1 && < 1.3,- text >= 0.11 && < 1.2,- tagged >= 0.4 && < 0.8,+ text >= 0.11 && < 1.3, OddWord == 1.0.*,- hsqml == 0.3.*+ hsqml >= 0.3.1 && < 0.4 GHC-options: -threaded Source-repository head
qml/morris.js view
@@ -1,18 +1,11 @@ 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;+ targetView.model = game.targets; } function clearTargets()@@ -22,29 +15,9 @@ 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) {+ pieceView.model = game.pieces;+ var actions = game.actions.length;+ if (actions == 0 || actions == 2) { anim.restart(); } else {@@ -55,14 +28,12 @@ function setupGame() { game = createGame();- prevGame = game; updateTargets(); updatePieces(); } function selectTarget(i) {- prevGame = game; game = game.selectTarget(i); clearTargets(); updatePieces();@@ -87,11 +58,11 @@ function aiReadyCallback(move) {- if (move.count == 0) {+ if (move.length == 0) { return; }- for (var j=move.count-1; j>=0; j--) {- aiMove.push(move.elem(j));+ for (var j=move.length-1; j>=0; j--) {+ aiMove.push(move[j]); } animFinished(); }
qml/morris.qml view
@@ -4,9 +4,19 @@ Image { id: board; source: "board.svg";- fillMode: Image.PreserveAspectFit;- anchors.fill: parent;+ width: 320; height: 320; + property real pw : parent!=null?parent.width:width;+ property real ph : parent!=null?parent.height:height;++ transform: [+ Scale {+ id: scale; xScale: yScale;+ yScale: Math.min(board.pw/board.width,board.ph/board.height);},+ Translate {+ x: (board.pw-board.width*scale.xScale)/2;+ y: (board.ph-board.height*scale.yScale)/2;}]+ property real t; NumberAnimation on t {@@ -30,10 +40,10 @@ id: pieceView model: []; Image {- source: modelData.red ? "red.svg" : "black.svg";- opacity: (modelData.endVis*board.t)+(modelData.startVis*(1-board.t));- x: (Morris.posIdToX(modelData.endIdx)*board.t)+(Morris.posIdToX(modelData.startIdx)*(1-board.t))-width/2;- y: (Morris.posIdToY(modelData.endIdx)*board.t)+(Morris.posIdToY(modelData.startIdx)*(1-board.t))-height/2;+ source: modelData.player == "red" ? "red.svg" : "black.svg";+ opacity: ((modelData.currPos!=null?1:0)*board.t)+((modelData.prevPos!=null?1:0)*(1-board.t));+ x: (Morris.posIdToX(modelData.currPos!=null?modelData.currPos:modelData.prevPos)*board.t)+(Morris.posIdToX(modelData.prevPos!=null?modelData.prevPos:modelData.currPos)*(1-board.t))-width/2;+ y: (Morris.posIdToY(modelData.currPos!=null?modelData.currPos:modelData.prevPos)*board.t)+(Morris.posIdToY(modelData.prevPos!=null?modelData.prevPos:modelData.currPos)*(1-board.t))-height/2; } }
src/Morris/Main.hs view
@@ -54,14 +54,6 @@ 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]@@ -76,57 +68,74 @@ 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 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 PosListObj where- type MarshalMode PosListObj c d = ModeObjFrom PosListObj c- marshaller = fromMarshaller fromObjRef+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}+ gameBias :: Map Board Float,+ gamePrev :: Maybe GameObj} deriving Typeable -getPlayer :: GameObj -> IO Text-getPlayer gs =- return $ case getBoardNextPlayer $ gameBoard gs of- Red -> T.pack "red"- Black -> T.pack "black"+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 (ObjRef PosListObj)+getTargets :: GameObj -> IO [Position] getTargets gs = let actions = gameActions gs posOff = length actions- in newObjectDC $ PosListObj $ nub $ map (!! posOff) $+ in return $ nub $ map (!! posOff) $ filter (isPrefixOf actions) $ map moveToPositions $ legalMoves $ gameBoard gs -getActions :: GameObj -> IO (ObjRef PosListObj)-getActions gs =- newObjectDC $ PosListObj $ gameActions 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- posObj <- newObjectDC $ PosListObj ps- fireSignal (Proxy :: Proxy AIReady) gsRef posObj+ fireSignal (Proxy :: Proxy AIReady) gsRef ps selectTarget :: GameObj -> Int -> IO (ObjRef GameObj) selectTarget gs i =@@ -149,62 +158,40 @@ gameIdBoard = iboard', gameActions = [], gameBias = {-Map.map (*0.9) $-} Map.alter (\x ->- Just $ fromMaybe 0 x - 0.5) board' $ gameBias gs}+ Just $ fromMaybe 0 x - 0.5) board' $ gameBias gs,+ gamePrev = Just 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+ gameActions = actions',+ gamePrev = Just gs} data AIReady deriving Typeable instance SignalKeyClass AIReady where- type SignalParams AIReady = ObjRef PosListObj -> IO ()+ 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,- defPropertyRO "indexCount" getIndexCount,- defMethod "idxPlayer" getPlayerAtIndex,- defMethod "idxPosition" getPositionAtIndex]+ defMethod "selectTarget" selectTarget] instance Marshal GameObj where type MarshalMode GameObj c d = ModeObjFrom GameObj c marshaller = fromMarshaller fromObjRef -createGame :: ObjRef MainObj -> IO (ObjRef GameObj)+createGame :: ObjRef () -> IO (ObjRef GameObj) createGame _ =- newObjectDC $ GameObj newBoard newIdBoard [] Map.empty--data MainObj = MainObj deriving Typeable--instance DefaultClass MainObj where- classMembers = [- defMethod "createGame" createGame]+ newObjectDC $ GameObj newBoard newIdBoard [] Map.empty Nothing main :: IO () main = do- ctx <- newObjectDC $ MainObj+ clazz <- newClass [defMethod "createGame" createGame]+ ctx <- newObject clazz () qml <- getDataFileName "morris.qml" runEngineLoop defaultEngineConfig { initialDocument = fileDocument qml,