DefendTheKing 0.2 → 0.2.1
raw patch · 7 files changed
+558/−2 lines, 7 files
Files
- DefendTheKing.cabal +2/−2
- src/Chess.hs +184/−0
- src/Font.hs +31/−0
- src/GameLogic.hs +44/−0
- src/NetEngine.hs +226/−0
- src/NetMatching.hs +63/−0
- src/Parse.hs +8/−0
DefendTheKing.cabal view
@@ -1,5 +1,5 @@ Name: DefendTheKing-Version: 0.2+Version: 0.2.1 Cabal-Version: >= 1.2 Synopsis: A simple RTS game Category: game, FRP@@ -26,7 +26,7 @@ Executable: defend HS-Source-Dirs: src Main-IS: defend.hs- Other-Modules: Geometry, Networking, ParseStun, Intro, Draw+ Other-Modules: Geometry, Networking, ParseStun, Intro, Draw, Parse, NetMatching, NetEngine, Chess, GameLogic, Font Build-Depends: base >=2 && < 5, peakachu >= 0.2, GLUT, containers, random, time, utility-ht, haskell98, network, HTTP, mtl, bytestring, binary,
+ src/Chess.hs view
@@ -0,0 +1,184 @@+module Chess (+ PieceType(..), BoardPos, PieceSide(..), Piece(..), Board(..),+ chessStart, pieceAt, possibleMoves+ ) where++import Control.Monad (guard)+import Data.Foldable (Foldable, all, any, toList)+import Prelude hiding (all, any, null)++data PieceType =+ Pawn | Knight | Bishop | Rook | Queen | King+ deriving (Eq, Read, Show)++type BoardPos = (Integer, Integer)++data PieceSide = Black | White+ deriving (Eq, Read, Show)++data Piece = Piece {+ pieceSide :: PieceSide,+ pieceType :: PieceType,+ piecePos :: BoardPos,+ pieceMoved :: Bool+}++data Board = Board {+ boardPieces :: [Piece],+ boardLastMove :: Maybe (Piece, BoardPos)+}++chessStart :: Board+chessStart =+ Board {+ boardPieces =+ concat (zipWith headRowItems [0..7] headRowTypes) +++ [Piece side Pawn (x, y) False |+ x <- [0..7], (side, y) <- [(White, 1), (Black, 6)]],+ boardLastMove = Nothing+ }+ where+ headRowTypes = [Rook, Knight, Bishop, Queen, King, Bishop, Knight, Rook]+ headRowItems x t = do+ (col, row) <- [(White, 0), (Black, 7)]+ return $ Piece col t (x, row) False++addPos :: BoardPos -> BoardPos -> BoardPos+addPos (xa, ya) (xb, yb) = (xa+xb, ya+yb)++rays :: PieceType -> [[BoardPos]]+rays Knight = do+ a <- [1, -1]+ b <- [2, -2]+ [[(a, b)], [(b, a)]]+rays Bishop = do+ dx <- [1, -1]+ dy <- [1, -1]+ return $ iterate (addPos (dx, dy)) (dx, dy)+rays Rook = do+ (dx, dy) <- [(-1, 0), (1, 0), (0, -1), (0, 1)]+ return $ iterate (addPos (dx, dy)) (dx, dy)+rays Queen = rays Bishop ++ rays Rook+rays King = map (take 1) $ rays Queen+rays Pawn = []++pieceAt :: Board -> BoardPos -> Maybe Piece+pieceAt board pos =+ case filter ((== pos) . piecePos) (boardPieces board) of+ [] -> Nothing+ (x : _) -> Just x++takeUntilIncluding :: (a -> Bool) -> [a] -> [a]+takeUntilIncluding _ [] = []+takeUntilIncluding func (x : xs)+ | func x = [x]+ | otherwise = x : takeUntilIncluding func xs++null :: Foldable t => t a -> Bool+null = all (const False)++possibleMoves :: Board -> Piece -> [(BoardPos, Board)]+possibleMoves board piece =+ simpleMoves ++ otherMoves (pieceType piece)+ where+ simpleMoves = do+ relRay <- rays (pieceType piece)+ dst <-+ takeUntilIncluding (not . null . pieceAt board) .+ takeWhile notBlocked $+ map (addPos src) relRay+ return $ simpleMove dst+ src@(srcX, _) = piecePos piece+ move updPiece clearPos dst =+ (dst, newBoard)+ where+ newBoard =+ Board {+ boardPieces =+ newPieceState :+ filter (not . (`elem` [src, clearPos]) . piecePos)+ (boardPieces board),+ boardLastMove = Just (newPieceState, src)+ }+ newPieceState =+ updPiece { piecePos = dst, pieceMoved = True }+ simpleMove dst = move piece dst dst+ inBoard (x, y) = 0 <= x && x < 8 && 0 <= y && y < 8+ isOtherSide = (/= pieceSide piece) . pieceSide+ notBlocked pos =+ inBoard pos &&+ all isOtherSide (pieceAt board pos)+ promotionRow = pawnStartRow + 6 * forward+ pawnMove dst@(_, dy)+ | dy /= promotionRow = simpleMove dst+ | otherwise = move (piece { pieceType = Queen }) dst dst+ otherMoves Pawn =+ (enPassant (boardLastMove board) ++) $+ map pawnMove .+ filter inBoard $+ moveForward +++ filter (any isOtherSide . pieceAt board)+ [(sx-1, sy+forward), (sx+1, sy+forward)] +++ do+ guard $ sy == pawnStartRow+ guard . not $ null moveForward+ guard . null $ pieceAt board sprintDst+ return sprintDst+ where+ moveForward = filter (null . pieceAt board) [(sx, sy+forward)]+ sprintDst = (sx, sy+forward*2)+ enPassant Nothing = []+ enPassant (Just (lpiece, (mx, my)))+ | py /= sy = []+ | abs (mx-sx) /= 1 = []+ | abs (py-my) /= 2 = []+ | pieceType lpiece /= Pawn = []+ | pieceSide lpiece == pieceSide piece = []+ | not (null (pieceAt board dst)) = []+ | otherwise = [move piece prevPos dst]+ where+ dst = (mx, sy+forward)+ prevPos@(_, py) = piecePos lpiece+ otherMoves King = do+ guard . not $ pieceMoved piece+ (rookX, direction) <- [(0, -1), (7, 1)]+ let+ dangerZone =+ map fst $+ concatMap (possibleMoves board) dangers+ dangers = filter isDanger $ boardPieces board+ isDanger p =+ pieceSide p /= pieceSide piece &&+ (pieceMoved p || pieceType p /= King)+ rookDstX = srcX + direction+ kingDstX = srcX + 2*direction+ putInRow x = (x, sy)+ clearPath = map putInRow [srcX + direction, srcX + direction*2 .. rookX - direction]+ safePath = map putInRow [srcX, srcX + direction]+ rookPos = (rookX, sy)+ kingDst = (kingDstX, sy)+ newKingState =+ piece { piecePos = kingDst, pieceMoved = True }+ rook <- toList $ pieceAt board rookPos+ guard $ Rook == pieceType rook+ guard . not . pieceMoved $ rook+ guard . all (null . pieceAt board) $ clearPath+ guard . all (`notElem` dangerZone) $ safePath+ let+ newRookState =+ rook { piecePos = (rookDstX, sy), pieceMoved = True }+ newBoard =+ Board {+ boardPieces =+ [newKingState, newRookState] +++ filter (not . (`elem` [src, rookPos]) . piecePos)+ (boardPieces board),+ boardLastMove = Just (newKingState, src)+ }+ return (kingDst, newBoard)+ otherMoves _ = []+ (forward, pawnStartRow)+ | pieceSide piece == White = (1, 1)+ | otherwise = (-1, 6)+ (sx, sy) = src+
+ src/Font.hs view
@@ -0,0 +1,31 @@+module Font (+ DefendFont, DrawPos, Pix(..),+ loadFont+ ) where++import Geometry (triangulatePolygon)++import Data.Map (Map)+import Graphics.UI.GLUT (GLfloat)++type DrawPos = (GLfloat, GLfloat)++data Pix = Pix {+ pixOutline :: [[DrawPos]],+ -- | pixBody can (and is) be calculated from pixOutline+ -- it is in Pix for memoing this calculation.+ pixBody :: [[DrawPos]]+}++type DefendFont = Map String Pix++loadFont :: String -> DefendFont+loadFont =+ fmap loadChar . read+ where+ loadChar polygons =+ Pix {+ pixOutline = polygons,+ pixBody = triangulatePolygon =<< polygons+ }+
+ src/GameLogic.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++module GameLogic+ ( Move(..), PartialData(..), visibleSquares+ ) where++import Chess++import Control.Monad (guard)+import Data.List (group, partition, sort)++data Move = Move+ { moveSrc :: BoardPos+ , moveIter :: Integer+ , moveDst :: BoardPos+ }+ deriving (Read, Show)++class PartialData a b where+ getPartial :: b -> a++instance PartialData a a where+ getPartial = id++instance PartialData a b => PartialData a (c -> b) where+ getPartial x = getPartial (x undefined)++sortNub :: Ord a => [a] -> [a]+sortNub = map head . group . sort++visibleSquares :: PieceSide -> Board -> [BoardPos]+visibleSquares side board =+ sortNub $ (goodPieces >>= sees) ++ (evilPieces >>= threats)+ where+ (goodPieces, evilPieces) =+ partition ((== side) . pieceSide) (boardPieces board)+ theKings = filter ((== King) . pieceType) goodPieces+ [theKing] = theKings+ sees p = piecePos p : map fst (possibleMoves board p)+ threats p = do+ guard . not . null $ theKings+ guard $ piecePos theKing `elem` sees p+ return $ piecePos p+
+ src/NetEngine.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE TemplateHaskell #-}++module NetEngine+ ( NetEngineOutput(..), NetEngineInput(..)+ , netEngine+ , gNEOMove, gNEOPacket, gNEOSetIterTimer+ , gNEOPeerConnected, gNEOGameIteration+ ) where++import Control.Applicative+import Control.Category+import Control.FilterCategory+import Codec.Compression.Zlib (decompress, compress)+import Control.Monad ((>=>))+import Data.ADT.Getters+import Data.ByteString.Lazy.Char8 (ByteString, pack, unpack)+import Data.Function (on)+import Data.List (isPrefixOf, partition)+import Data.Map (Map, delete, fromList, insert, lookup, toList)+import Data.Monoid (Monoid(..))+import FRP.Peakachu.Program+import Network.Socket (SockAddr)+import Prelude hiding ((.), id, lookup)++data NetEngineState moveType idType = NetEngineState+ { neLocalQueue :: [(Integer, moveType)]+ , neQueue :: Map (Integer, idType) moveType+ , nePeers :: [idType]+ , nePeerAddrs :: [SockAddr]+ , neWaitingForPeers :: Bool+ , neGameIteration :: Integer+ , neOutputMove :: moveType+ , neLatencyIters :: Integer+ , neMyPeerId :: idType+ }++data NetEngineOutput moveType idType+ = NEOMove moveType+ | NEOPeerConnected idType+ | NEOPacket String SockAddr+ | NEOSetIterTimer+ | NEOGameIteration Integer+ deriving Show+$(mkADTGetters ''NetEngineOutput)++data NetEngineInput moveType+ = NEIMove Integer moveType+ | NEIPacket String SockAddr+ | NEIMatching [SockAddr]+ | NEIIterTimer+ | NEITransmitTimer+$(mkADTGetters ''NetEngineInput)++data NetEngineMid moveType idType+ = AInput (NetEngineInput moveType)+ | AState (NetEngineState moveType idType)+$(mkADTGetters ''NetEngineMid)++data HelloType = LetsPlay | WereOn+ deriving (Read, Show, Eq)++data NetEngPacket m i+ = Moves (Map (Integer, i) m)+ | Hello i HelloType+ deriving (Read, Show)++magic :: String+magic = "dtkffod!"++atP :: FilterCategory cat => (a -> Maybe b) -> cat a b+atP = mapMaybeC++outPacket+ :: (Show a, Show i)+ => NetEngPacket a i -> SockAddr -> NetEngineOutput a i+outPacket = NEOPacket . (magic ++) . withPack compress . show++withPrev :: MergeProgram a (a, a)+withPrev = (,) <$> delayP (1::Int) <*> id++atChgOf :: Eq b+ => (a -> b) -> MergeProgram a a+atChgOf onfunc =+ arrC snd . filterC (uncurry (on (/=) onfunc)) . withPrev++netEngine+ :: ( Monoid moveType, Ord peerIdType+ , Read moveType, Read peerIdType+ , Show moveType, Show peerIdType+ )+ => peerIdType+ -> MergeProgram+ (NetEngineInput moveType)+ (NetEngineOutput moveType peerIdType)+netEngine myPeerId =+ mconcat+ [ NEOSetIterTimer <$ singleValueP+ , mconcat+ [ mconcat+ [ NEOMove . neOutputMove <$> id+ , NEOSetIterTimer <$ id+ , NEOGameIteration . neGameIteration <$> id+ ] . atChgOf neGameIteration . atP gAState+ , mconcat+ [ outPacket (Hello myPeerId WereOn)+ <$> flattenC+ . arrC nePeerAddrs+ , arrC NEOPeerConnected+ . filterC (/= myPeerId)+ . flattenC+ . arrC nePeers+ ]+ . atChgOf nePeerAddrs+ . atP gAState+ , flattenC + . ( sendMoves+ <$> (lstP gAState <* atP (gAInput >=> gNEITransmitTimer))+ )+ ]+ . mconcat+ [ AState <$> scanlP netEngineStep (startState myPeerId)+ , arrC AInput+ ]+ , outPacket (Hello myPeerId LetsPlay) <$> flattenC . atP gNEIMatching+ -- for warnings+ , unwarn gNEIIterTimer+ , unwarn gNEIMove+ , unwarn gNEIPacket+ ]+ where+ unwarn x = undefined <$> filterC (const False) . atP x+ sendMoves state =+ outPacket (Moves (neQueue state)) <$> nePeerAddrs state++startState+ :: (Monoid moveType, Ord peerIdType)+ => peerIdType -> NetEngineState moveType peerIdType+startState myPeerId =+ NetEngineState+ { neLocalQueue = []+ , neQueue =+ fromList+ [ ((i, myPeerId), mempty)+ | i <- [0 .. latencyIters-1]+ ]+ , nePeers = [myPeerId]+ , nePeerAddrs = mempty+ , neWaitingForPeers = False+ , neGameIteration = 0+ , neOutputMove = mempty+ , neLatencyIters = latencyIters+ , neMyPeerId = myPeerId+ }+ where+ latencyIters = 5++netEngineStep+ :: (Monoid a, Ord i, Read a, Read i)+ => NetEngineState a i -> NetEngineInput a -> NetEngineState a i+netEngineStep state (NEIMove iter move) =+ state { neLocalQueue = (iter, move) : neLocalQueue state }+netEngineStep state NEIIterTimer = netEngineNextIter state+netEngineStep state (NEIPacket contents sender)+ | isPrefixOf magic contents =+ processPacket state sender+ . read . withPack decompress+ . drop (length magic) $ contents+ | otherwise = state+netEngineStep state _ = state++withPack :: (ByteString -> ByteString) -> String -> String+withPack = (unpack .) . (. pack)++processPacket+ :: (Monoid a, Ord i)+ => NetEngineState a i -> SockAddr -> NetEngPacket a i+ -> NetEngineState a i+processPacket state sender (Hello peerId _)+ | length (nePeers state) > 1 = state+ | otherwise =+ (startState myPeerId)+ { nePeers = [myPeerId, peerId]+ , nePeerAddrs = [sender]+ }+ where+ myPeerId = neMyPeerId state+processPacket state _ (Moves moves)+ | neWaitingForPeers state = netEngineNextIter updState+ | otherwise = updState+ where+ updState =+ state+ { neQueue =+ mappend (neQueue state) . fromList+ . filter ((>= neGameIteration state) . fst . fst)+ . toList $ moves+ }++netEngineNextIter ::+ (Monoid a, Ord i) => NetEngineState a i -> NetEngineState a i+netEngineNextIter ne =+ case peerMoves of+ Nothing -> ne { neWaitingForPeers = True }+ Just move ->+ ne+ { neLocalQueue = futureMoves+ , neQueue =+ insert moveKey (mconcat (snd <$> nextMoves)) $+ foldr delete (neQueue ne) delKeys+ , neGameIteration = iter + 1+ , neOutputMove = move+ , neWaitingForPeers = False+ }+ where+ (nextMoves, futureMoves) =+ partition ((<= nextMoveIter) . fst)+ . neLocalQueue $ ne+ nextMoveIter = iter + neLatencyIters ne+ moveKey = (nextMoveIter, neMyPeerId ne)+ iter = neGameIteration ne+ moveKeys = (,) iter <$> nePeers ne+ delKeys = (,) (iter - neLatencyIters ne) <$> nePeers ne+ peerMoves =+ mconcat <$>+ sequence ((`lookup` neQueue ne) <$> moveKeys)+
+ src/NetMatching.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}++module NetMatching where++import Networking+import Parse++import Control.Category+import Control.FilterCategory+import Control.Monad (guard)+import Data.ADT.Getters+import Data.List (intercalate)+import Data.Map (delete, insert, lookup)+import Data.Monoid (Monoid(..))+import FRP.Peakachu.Program+import Network.Socket (SockAddr)+import Prelude hiding ((.), id, lookup)++data MatchingIn a+ = DoMatching [SockAddr] a+ | MITimerEvent a+ | MIHttp (Maybe String) a++data MatchingOut a+ = MatchingResult [SockAddr] a+ | MOSetRetryTimer a+ | MOHttp String a+ deriving Show+$(mkADTGetters ''MatchingOut)++netMatching :: (Ord a, ProgCat prog) => prog (MatchingIn a) (MatchingOut a)+netMatching =+ mapMaybeC snd . scanlP step (mempty, Nothing)+ where+ step (state, _) (DoMatching addrs tag) =+ (newState, req newState tag)+ where+ newState = insert tag addrs state+ step (state, _) (MIHttp response tag) =+ case parseDifferentAddresses state tag response of+ Nothing ->+ ( state+ , Just $ MOSetRetryTimer tag+ )+ Just res ->+ ( delete tag state+ , Just $ MatchingResult res tag+ )+ step (state, _) (MITimerEvent tag) = (state, req state tag)+ req state tag =+ fmap+ ( (`MOHttp` tag)+ . ("http://defendtheking.nfshost.com/match.cgi?" ++)+ )+ . formatAddrs state $ tag+ formatAddrs state =+ fmap (intercalate "," . map show) . (`lookup` state)+ parseDifferentAddresses state tag response = do+ text <- response+ myAddrText <- formatAddrs state tag+ guard $ myAddrText /= text+ mapM parseSockAddr . split ',' $ text+
+ src/Parse.hs view
@@ -0,0 +1,8 @@+module Parse (split) where++split :: Eq a => a -> [a] -> [[a]]+split char =+ map (takeWhile (/= char)) .+ takeWhile (not . null) .+ iterate (drop 1 . dropWhile (/= char))+