diff --git a/DefendTheKing.cabal b/DefendTheKing.cabal --- a/DefendTheKing.cabal +++ b/DefendTheKing.cabal @@ -1,16 +1,16 @@ Name: DefendTheKing -Version: 0.1 +Version: 0.2 Cabal-Version: >= 1.2 -Synopsis: A graphical demo. Will be a game +Synopsis: A simple RTS game Category: game, FRP Description: Defend the King from the Forces of Different: - A graphical demo. + (work in progress) - Intended to become a simple fast-paced multiplayer RTS game - in the likes of Bughouse-Chess and Starcraft. + A simple fast-paced multiplayer RTS game + inspired by Bughouse-Chess and Starcraft. Author: Yair Chuchem Maintainer: Yair Chuchem (yairchu@gmail.com) @@ -20,14 +20,23 @@ License-File: LICENSE Stability: experimental Build-Type: Simple -Extra-Source-Files: - src/defend.hs - src/Chess.hs - src/ChessFont.hs +Data-Files: data/defend.font + Executable defend Executable: defend HS-Source-Dirs: src Main-IS: defend.hs - Build-Depends: base >=2 && < 5, peakachu, GLUT + Other-Modules: Geometry, Networking, ParseStun, Intro, Draw + Build-Depends: base >=2 && < 5, peakachu >= 0.2, GLUT, containers, + random, time, utility-ht, haskell98, + network, HTTP, mtl, bytestring, binary, + MaybeT, zlib + GHC-Options: -O2 -Wall +Executable defendFontEdit + Executable: defendFontEdit + HS-Source-Dirs: src + Main-IS: defendFontEdit.hs + Other-Modules: Geometry + Build-Depends: base >=2 && < 5, peakachu >= 0.2, GLUT, containers GHC-Options: -O2 -Wall diff --git a/data/defend.font b/data/defend.font new file mode 100644 --- /dev/null +++ b/data/defend.font @@ -0,0 +1,1 @@ +fromList [("",[[]]),("0",[[],[(-0.5,0.25),(-0.25,0.5),(0.25,0.5),(0.5,0.25),(0.5,-0.25),(0.25,-0.5),(-0.25,-0.5),(-0.5,-0.25)]]),("1",[[],[(-0.25,-0.75),(0.0,1.0),(0.25,0.75),(0.0,-1.0)]]),("2",[[],[(-0.75,0.5),(0.25,1.0),(0.5,0.75),(-0.25,-0.75),(0.5,0.0),(0.75,-0.25),(-0.25,-1.0),(-0.5,-0.75),(0.25,0.75)]]),("3",[[],[(-0.75,0.5),(0.25,1.0),(0.5,0.75),(-0.25,0.0),(0.5,0.25),(0.75,0.0),(-0.25,-1.0),(-0.5,-0.75),(0.5,0.0),(-0.25,-0.25),(-0.5,0.0),(0.25,0.75)]]),("4",[[],[(0.5,-0.5),(-0.75,-0.25),(-0.5,1.0),(-0.25,0.75),(-0.5,0.0),(0.25,-0.25),(0.75,1.0),(1.0,-0.75),(0.75,-1.0),(0.75,0.25)]]),("5",[[],[(0.75,1.0),(1.0,0.75),(-0.25,0.5),(0.0,0.0),(0.75,0.25),(1.0,-0.75),(0.0,-1.0),(-0.25,-0.75),(0.75,-0.5),(0.5,-0.25),(-0.25,-0.25),(-0.75,0.75)]]),("6",[[],[(0.75,1.0),(1.0,0.75),(-0.25,0.5),(0.0,0.0),(0.75,0.25),(1.0,-0.75),(-0.5,-1.0),(-0.75,-0.25),(-0.5,0.0),(-0.25,-0.75),(0.75,-0.5),(0.5,-0.25),(-0.25,-0.25),(-0.75,0.75)]]),("7",[[],[(-1.0,0.75),(1.0,1.0),(0.75,-1.0),(0.5,0.5)]]),("8",[[],[(-0.75,0.0),(-1.0,0.75),(0.75,1.0),(1.0,0.0),(-0.25,-0.25),(0.0,-0.75),(0.75,-0.75),(0.75,-0.5),(0.0,-0.5),(0.0,-0.25),(1.0,-0.25),(1.0,-1.0),(-0.25,-1.0),(-0.5,0.0),(0.75,0.25),(0.5,0.75),(-0.5,0.5),(-0.5,0.25)]]),("9",[[],[(-1.0,-0.75),(0.75,-0.5),(0.5,0.75),(-0.75,0.5),(-0.5,-0.25),(0.25,0.0),(-0.25,0.0),(-0.5,0.25),(0.25,0.5),(0.5,-0.25),(-0.75,-0.5),(-1.0,0.75),(0.75,1.0),(1.0,-0.75),(-0.75,-1.0)]]),("a",[[],[(-1.0,-1.0),(0.0,1.0),(1.0,-1.0),(0.0,-0.5)]]),("b",[[],[(-1.0,1.0),(1.0,0.5),(0.0,0.0),(1.0,-0.5),(-1.0,-1.0)]]),("bishop",[[],[(-1.0,-1.0),(0.0,1.0),(1.0,-1.0),(0.0,-0.5)]]),("c",[[],[(-1.0,0.0),(1.0,1.0),(0.0,0.0),(1.0,-1.0)]]),("d",[[],[(-1.0,1.0),(1.0,0.0),(-1.0,-1.0),(-0.5,0.0)]]),("e",[[],[(-1.0,0.0),(1.0,1.0),(0.25,0.25),(1.0,0.0),(0.25,-0.25),(1.0,-1.0)]]),("f",[[],[(-1.0,0.75),(1.0,1.0),(-0.25,0.25),(1.0,0.0),(0.0,-0.25),(-0.5,-1.0)]]),("g",[[],[(-0.25,-1.0),(-0.75,-0.5),(-1.0,0.25),(-0.75,0.75),(0.25,1.0),(1.0,0.75),(0.75,0.5),(0.25,0.75),(-0.5,0.5),(-0.75,0.25),(-0.5,-0.25),(-0.25,-0.75),(0.5,-0.5),(0.0,-0.25),(-0.25,0.0),(0.5,-0.25),(1.0,-0.5)]]),("h",[[],[(-1.0,1.0),(-0.75,1.0),(-0.5,0.25),(0.5,0.0),(0.75,1.0),(1.0,1.0),(1.0,-1.0),(0.75,-1.0),(0.5,-0.25),(-0.5,0.0),(-0.75,-1.0),(-1.0,-1.0)]]),("i",[[],[(-0.25,1.0),(0.5,1.0),(0.25,0.75),(0.0,-0.75),(0.25,-1.0),(-0.5,-1.0),(-0.25,-0.75),(0.0,0.75)]]),("j",[[],[(1.0,1.0),(0.75,0.75),(0.5,-0.5),(0.25,-0.75),(-0.25,-1.0),(-0.75,-0.75),(-1.0,-0.25),(-0.75,0.0),(-0.5,-0.5),(-0.25,-0.75),(0.25,-0.25),(0.5,0.75),(0.25,1.0)]]),("k",[[],[(-1.0,1.0),(-0.5,0.25),(1.0,1.0),(0.75,0.5),(-0.25,0.0),(0.75,-0.75),(0.25,-1.0),(-0.5,-0.25),(-0.75,-0.75),(-1.0,-1.0)]]),("king",[[],[(-0.75,-0.25),(0.0,-0.5),(0.75,-0.25),(0.75,-0.75),(-0.75,-0.75)],[(0.25,0.5),(0.5,0.75),(0.75,0.5),(0.5,0.25)],[(-0.75,0.5),(-0.5,0.75),(-0.25,0.5),(-0.5,0.25)]]),("knight",[[],[(-1.0,-1.0),(0.0,0.0),(-1.0,0.0),(1.0,1.0),(0.5,-1.0)]]),("l",[[],[(-0.75,1.0),(-0.5,-0.5),(1.0,-0.75),(-1.0,-1.0)]]),("m",[[],[(-1.0,-1.0),(-0.5,1.0),(0.0,-0.25),(0.5,1.0),(1.0,-1.0),(0.75,-0.75),(0.5,0.0),(0.0,-1.0),(-0.5,0.0),(-0.75,-0.75)]]),("n",[[],[(-1.0,-1.0),(-0.75,1.0),(0.5,-0.25),(0.75,0.75),(1.0,1.0),(0.75,-1.0),(-0.5,0.0),(-0.75,-0.75)]]),("o",[[],[(-1.0,0.5),(0.5,1.0),(1.0,-0.5),(-0.5,-1.0)]]),("p",[[],[(-1.0,1.0),(0.25,0.75),(0.75,0.5),(1.0,0.25),(0.75,-0.25),(-0.25,-0.5),(0.0,-1.0),(-0.75,-1.0)]]),("pawn",[[],[(-0.25,-0.5),(-0.5,-0.25),(-0.5,0.25),(-0.25,0.5),(0.25,0.5),(0.5,0.25),(0.5,-0.25),(0.25,-0.5)]]),("q",[[],[(0.0,-1.0),(0.25,-0.5),(-0.75,-0.25),(-1.0,0.25),(-0.75,0.5),(-0.25,0.75),(1.0,1.0),(0.75,-1.0)]]),("queen",[[],[(-1.0,-1.0),(-0.5,0.0),(-1.0,1.0),(-0.25,0.5),(0.0,1.0),(0.25,0.5),(1.0,1.0),(0.5,0.0),(1.0,-1.0),(0.0,-0.5)]]),("r",[[],[(-1.0,-1.0),(-0.75,1.0),(0.5,0.75),(0.75,0.5),(1.0,0.0),(0.25,-0.25),(0.75,-1.0),(0.25,-1.0),(-0.25,-0.25),(-0.5,-1.0)]]),("rook",[[],[(-1.0,1.0),(1.0,1.0),(0.5,0.5),(0.5,-0.5),(1.0,-1.0),(-1.0,-1.0),(-0.5,-0.5),(-0.5,0.5)]]),("s",[[],[(-0.75,0.75),(0.75,1.0),(1.0,0.75),(-0.25,0.5),(-0.5,0.25),(1.0,-0.25),(0.75,-0.75),(-0.75,-1.0),(-1.0,-0.75),(0.5,-0.5),(-1.0,0.0)]]),("t",[[],[(-1.0,0.75),(1.0,1.0),(0.75,0.75),(0.0,0.5),(0.25,-1.0),(0.0,-1.0),(-0.25,0.5),(-0.75,0.5)]]),("u",[[],[(-0.75,1.0),(-0.5,-0.5),(0.0,-0.75),(0.5,-0.5),(0.75,1.0),(1.0,0.75),(0.75,-0.75),(0.0,-1.0),(-0.75,-0.75),(-1.0,0.75)]]),("v",[[],[(-0.75,1.0),(0.0,-0.5),(0.75,1.0),(1.0,0.75),(0.0,-1.0),(-1.0,0.75)]]),("w",[[],[(-1.0,0.75),(-0.75,1.0),(-0.5,-0.5),(0.0,1.0),(0.5,-0.5),(0.75,1.0),(1.0,0.75),(0.5,-1.0),(0.0,0.0),(-0.5,-1.0)]]),("x",[[],[(-1.0,0.75),(-0.75,1.0),(0.0,0.25),(0.75,1.0),(1.0,0.75),(0.25,0.0),(1.0,-0.75),(0.75,-1.0),(0.0,-0.25),(-0.75,-1.0),(-1.0,-0.75),(-0.25,0.0)]]),("y",[[],[(-0.25,-0.25),(-1.0,0.75),(-0.75,1.0),(0.0,0.25),(0.75,1.0),(1.0,0.75),(0.25,-0.25),(0.25,-1.0),(-0.25,-1.0)]]),("z",[[(-0.5,-1.5)],[(-1.0,0.75),(0.75,1.0),(1.0,0.75),(0.75,0.25),(-0.25,-0.25),(0.75,-0.5),(1.0,-0.75),(-0.75,-1.0),(-1.0,-0.75),(-0.75,-0.25),(0.25,0.25),(-0.75,0.5)]])] diff --git a/src/Chess.hs b/src/Chess.hs deleted file mode 100644 --- a/src/Chess.hs +++ /dev/null @@ -1,183 +0,0 @@ -module Chess ( - PieceType(..), BoardPos, PieceSide(..), Piece(..), Board(..), - chessStart, pieceAt, possibleMoves - ) where - -import Control.Monad (guard, forM) -import Data.Foldable (Foldable, all, any, toList) -import Prelude hiding (all, any, null) - -data PieceType = - Pawn | Knight | Bishop | Rook | Queen | King - deriving Eq - -type BoardPos = (Integer, Integer) - -data PieceSide = Black | White - deriving Eq - -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, King, Queen, 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 = 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@(dx, 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, m@(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) - newPieceState = piece { piecePos = dst } - prevPos@(px, py) = piecePos lpiece - otherMoves King = do - guard . not $ pieceMoved piece - let - dangerZone = - map fst $ - concatMap (possibleMoves board) dangers - dangers = filter isDanger $ boardPieces board - isDanger p = - pieceSide p /= pieceSide piece && - (pieceMoved p || pieceType p /= King) - (rookX, kingDstX, rookDstX, clearPath, safePath) <- - [(0, 1, 2, [1, 2], [3]), (7, 5, 4, [4..6], [3, 4])] - let rookPos = (rookX, sy) - rook <- toList $ pieceAt board rookPos - forM clearPath $ \x -> - guard . null $ pieceAt board (x, sy) - forM safePath $ \x -> - guard . not $ (x, sy) `elem` dangerZone - guard $ Rook == pieceType rook - guard . not $ pieceMoved rook - let - kingDst = (kingDstX, sy) - newKingState = - piece { piecePos = kingDst, pieceMoved = True } - 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 - diff --git a/src/ChessFont.hs b/src/ChessFont.hs deleted file mode 100644 --- a/src/ChessFont.hs +++ /dev/null @@ -1,66 +0,0 @@ -module ChessFont (DrawPos, PiecePix(..), piecePix) where - -import Chess (PieceType(..)) - -import Graphics.UI.GLUT (GLfloat) - -type DrawPos = (GLfloat, GLfloat) - -data PiecePix = PiecePix { - pixBody :: [[DrawPos]], - pixOutline :: [[DrawPos]] -} - -piecePix :: PieceType -> PiecePix -piecePix Pawn = - PiecePix r r - where - r = [[(-s, -s), (-s, s), (s, s), (s, -s)]] - s = 0.6 -piecePix Rook = PiecePix { - pixBody = [thing, othing, [(-s, -s), (-s, s), (s, s), (s, -s)]], - pixOutline = [thing ++ othing] - } - where - s = 0.5 - thing = [(-s, s), (-1, 1), (1, 1), (s, s)] - othing = map r thing - r (x, y) = (-x, -y) -piecePix Knight = PiecePix { - pixBody = [[a, b, e] ,[b, c, d]], - pixOutline = [outline] - } - where - outline = [(-1, 0), (1, 1), (0.5, -1), (-1, -1), (0, 0)] - [a, b, c, d, e] = outline -piecePix Bishop = PiecePix { - pixBody = [[a, b, d], [b, c, d]], - pixOutline = [outline] - } - where - outline = [(-1, -1), (0, 1), (1, -1), (0, -0.5)] - [a, b, c, d] = outline -piecePix King = PiecePix { - pixBody = [leye, reye, [a, b, e], [c, d, e]], - pixOutline = [reverse leye, reye, mouthline] - } - where - reye = [(0.25, 0.5), (0.5, 0.75), (0.75, 0.5), (0.5, 0.25)] - leye = map m reye - m (x, y) = (-x, y) - mouthline = - [(-0.75, -0.75), (-0.75, -0.25) - ,(0, -0.5) - ,(0.75, -0.25), (0.75, -0.75)] - [a, b, c, d, e] = mouthline -piecePix Queen = PiecePix { - pixBody = [[a, b, j], [d, e, f], [c, h, i], [c, g, h]], - pixOutline = [outline] - } - where - outline = - [(-1, 1), (-0.25, 0.5), (0, 1), (0.25, 0.5), (1, 1) - ,(0.5, 0), (1, -1), (0, -0.5), (-1, -1), (-0.5, 0)] - [a, b, c, d, e, f, g, h, i, j] = outline - - diff --git a/src/Draw.hs b/src/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Draw.hs @@ -0,0 +1,145 @@ +module Draw + ( draw, glStyle, board2screen + ) where + +import Chess +import Font +import GameLogic (Move(..), visibleSquares) +import Geometry + +import Control.Applicative +import Control.Monad (forM, forM_, guard, unless, when) +import Data.Char (toLower) +import Data.Map ((!)) +import FRP.Peakachu.Backend.GLUT (Image(..)) +import Graphics.UI.GLUT + +piecePix :: DefendFont -> PieceType -> Pix +piecePix font x = font ! map toLower (show x) + +board2screen :: BoardPos -> DrawPos +board2screen (bx, by) = + (r bx, r by) + where + r ba = (fromIntegral ba - 3.5) / 4 + +glStyle :: Image +glStyle = Image $ do + cursor $= None + lineSmooth $= Enabled + polygonSmooth $= Enabled + hint LineSmooth $= Nicest + hint PolygonSmooth $= Nicest + blend $= Enabled + +draw + :: DefendFont -> Board -> Move + -> DrawPos -> Maybe PieceSide -> Integer -> Image +draw font board drag (cx, cy) me gameIter = + Image $ do + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + lighting $= Enabled + light (Light 0) $= Enabled + position (Light 0) $= Vertex4 0 0 (-1) 0 + cullFace $= Just Front + drawBoard + mapM_ drawPiece . filter ((`elem` vis) . piecePos) $ boardPieces board + when srcFirst . drawCursor . moveSrc $ drag + drawCursor . moveDst $ drag + unless srcFirst . drawCursor . moveSrc $ drag + where + srcFirst = cursorDist (moveSrc drag) < cursorDist (moveDst drag) + cursorDist = cursorDist' . board2screen + cursorDist' (x, y) = (cx-x)^(2::Int) + (cy-y)^(2::Int) + headingUp = normal $ Normal3 0 0 (-1 :: GLfloat) + drawPiece piece = do + let + pix = piecePix font (pieceType piece) + (px, py) = piecePos piece + (sx, sy) = board2screen (px, py) + white :: Color4 GLfloat + white = Color4 1 1 1 1 + black = Color4 0 0 0 1 + (bodyCol, outlineCol) + | pieceSide piece == White = (white, black) + | otherwise = (black, white) + vert m (vx, vy) = + vertex $ Vertex4 + (sx + m*vx) + (sy + m*vy) 0 1 + headingUp + materialDiffuse Front $= bodyCol + renderPrimitive Triangles . + forM (pixBody pix) . + mapM $ vert (pieceSize * 0.125) + materialDiffuse Front $= outlineCol + renderPrimitive Quads . + forM (pixOutline pix) $ \outline -> + forM (polygonEdges + (zip outline (expandPolygon (-0.06) outline))) $ + \((a, b), (c, d)) -> + forM [c, d, b, a] . vert $ pieceSize * 0.125 + pieceSize = 0.9 + vis = + maybe allBoard (`visibleSquares` board) me + allBoard = [(x, y) | x <- [0..7], y <- [0..7]] + drawBoard = + forM_ vis $ \(bx, by) -> do + let + col = 0.3 + 0.1 * fromIntegral ((bx + by) `mod` 2) + r ba va = 0.125*((fromIntegral ba*2+va)-7) + materialDiffuse Front $= Color4 col col col 1 + headingUp + renderPrimitive Quads . + forM square $ \(vx, vy) -> + vertex $ Vertex4 (r bx vx) (r by vy) 0 1 + drawCursor boardPos = do + cullFace $= Just Back + drawCursor' boardPos + cullFace $= Just Front + drawCursor' boardPos + drawCursor' boardPos = + renderPrimitive Triangles . + forM_ curPix $ \part -> + forM_ (polygonEdges part) $ + \((ax, ay), (bx, by)) -> do + let + (rx, ry) = board2screen boardPos + points = + [[0.9*cx, 0.9*cy, 0.9] + ,[rx + 0.125*ax, ry + 0.125*ay, 1] + ,[rx + 0.125*bx, ry + 0.125*by, 1] + ] + norml = faceNormal points + [nx, ny, nz] + | last norml < 0 = norml + | otherwise = map negate norml + normal $ Normal3 nx ny nz + materialDiffuse Front $= + case pieceUnderCursor of + Nothing -> Color4 1 1 0 0.5 + _ -> cursorColor 1 + forM_ (take 1 points) $ \[px, py, pz] -> + vertex $ Vertex4 px py 0 pz + materialDiffuse Front $= + case pieceUnderCursor of + Nothing -> Color4 1 1 0 0 + _ -> cursorColor 0.5 + forM_ (tail points) $ \[px, py, pz] -> + vertex $ Vertex4 px py 0 pz + cursorColor + | gameIter >= moveIter drag = Color4 0 1 0 + | otherwise = Color4 1 0 0 + pieceUnderCursor = do + r <- pieceAt board . moveSrc $ drag + guard . not . (== Just False) . (<$> me) . (==) . pieceSide $ r + return r + curPix = + case pieceUnderCursor of + Nothing -> [square] + Just p -> map (map t) . pixOutline . piecePix font $ pieceType p + where + t (x, y) = (pieceSize*x, pieceSize*y) + square = [((-1), (-1)), ((-1), 1), (1, 1), (1, (-1))] + + diff --git a/src/Geometry.hs b/src/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Geometry.hs @@ -0,0 +1,127 @@ +module Geometry ( + expandPolygon, faceNormal, normalizeVector, + polygonEdges, triangulatePolygon + ) where + +import Data.Maybe (mapMaybe) + +faceNormal :: (Floating a, Ord a) => [[a]] -> [a] +faceNormal points = + normalizeVector [a1*b2-a2*b1, a2*b0-a0*b2, a0*b1-a1*b0] + where + offset = head points + base = map (zipWith (-) offset) (tail points) + [[a0, a1, a2], [b0, b1, b2]] = base + +normalizeVector :: Floating a => [a] -> [a] +normalizeVector vec + | all (== 0) vec = vec + | otherwise = map (/ norm) vec + where + norm = sqrt . sum $ map (^ (2 :: Int)) vec + +polygonEdges :: [a] -> [(a, a)] +polygonEdges xs = zip xs (tailRot xs) + +tailRot :: [a] -> [a] +tailRot [] = [] +tailRot (x : xs) = xs ++ [x] + +type Line a = ((a, a), (a, a)) + +slope :: Fractional a => Line a -> Maybe a +slope ((x0, y0), (x1, y1)) + | x0 == x1 = Nothing + | otherwise = Just $ (y1-y0) / (x1-x0) + +lineIntersection :: (Eq a, Fractional a) => Line a -> Line a -> Maybe (a, a) +lineIntersection a@((xa0, _), _) b@((xb0, yb0), _) = + case (slope a, slope b) of + (Nothing, Just db) -> Just (xa0, yb0 + (xa0-xb0) * db) + (Nothing, Nothing) -> Nothing + (_, Nothing) -> lineIntersection b a + (Just da, Just db) + | da == db -> Nothing + | otherwise -> + let + x = (yAt0 a da - yAt0 b db) / (db - da) + yAt0 ((x0, y0), _) d = y0 - x0 * d + in + Just (x, yAt0 a da + x * da) + +expandPolygon :: Floating a => a -> [(a, a)] -> [(a, a)] +expandPolygon ammount outline + | null t = [] + | otherwise = last t : init t + where + t = mapMaybe (uncurry lineIntersection) (polygonEdges segments) + segments = map expandSegment (polygonEdges outline) + expandSegment ((ax, ay), (bx, by)) = + ((ax + ammount * nx, ay + ammount * ny) + ,(bx + ammount * nx, by + ammount * ny)) + where + [nx, ny] = normalizeVector [ay - by, bx - ax] + +twicePolygonArea :: Num a => [(a, a)] -> a +twicePolygonArea = + sum . map f . polygonEdges + where + f ((x0, y0), (x1, y1)) = x1*y0-x0*y1 + +isFrontPolygon :: (Ord a, Num a) => [(a, a)] -> Bool +isFrontPolygon = (>= 0) . twicePolygonArea + +pointInPolygon :: (Ord a, Fractional a) => (a, a) -> [(a, a)] -> Bool +pointInPolygon (px, py) polygon = + length (filter crosses (polygonEdges polygon)) `mod` 2 == 1 + where + horizLine = ((0, py), (1, py)) + crosses e@((_, ey0), (_, ey1)) = + case lineIntersection horizLine e of + Nothing -> False + Just (ix, iy) -> + ix > px && + iy >= min ey0 ey1 && + iy < max ey0 ey1 + +segmentsIntersect :: (Ord a, Fractional a) => Line a -> Line a -> Bool +segmentsIntersect a b = + case lineIntersection a b of + Nothing -> False + Just (cx, cy) -> + let + inLine ((x0, y0), (x1, y1)) = t cx x0 x1 || t cy y0 y1 + t ca a0 a1 = + min a0 a1 < ca - epsilon && + ca + epsilon < max a0 a1 + epsilon = 0.00001 -- for floating-point inaccuracies + in + inLine a && inLine b + +listRotations :: [a] -> [[a]] +listRotations list = + take (length list) $ iterate tailRot list + +triangulatePolygon :: (Ord a, Fractional a) => [(a, a)] -> [[(a, a)]] +triangulatePolygon points + | length points < 3 + || not (isFrontPolygon points) + = [] + | otherwise = + case ears of + [] -> [] + (ear : _) -> + let + (abc@[a, _, c], rest) = splitAt 3 ear + in + filter ((> 0) . twicePolygonArea) [abc] + ++ triangulatePolygon ([a, c] ++ rest) + where + ears = filter isEar $ listRotations points + isEar rot = + isFrontPolygon abc + && not (any (`pointInPolygon` abc) rest) + && not (any (segmentsIntersect (a, c)) (polygonEdges points)) + where + (abc@[a, _, c], rest) = splitAt 3 rot + diff --git a/src/Intro.hs b/src/Intro.hs new file mode 100644 --- /dev/null +++ b/src/Intro.hs @@ -0,0 +1,66 @@ +module Intro (intro) where + +import Font +import Geometry + +import Control.Applicative +import Control.Category +import Control.FilterCategory +import Control.Monad (forM_) +import Data.Map ((!)) +import Data.Time.Clock +import FRP.Peakachu.Backend.GLUT +import FRP.Peakachu.Program +import Graphics.UI.GLUT hiding (Program) + +import Prelude hiding ((.), id) + +relativeTime :: Program UTCTime NominalDiffTime +relativeTime = + uncurry diffUTCTime <$> genericFlattenC . scanlP step Nothing + where + step Nothing x = Just (x, x) + step (Just (_, start)) x = Just (x, start) + +renderText :: DefendFont -> String -> [[DrawPos]] +renderText font text = + concat . zipWith doLine lns $ zip rowCenters rowHeights + where + lns = lines text + rowHeights = map ((2 /) . fromIntegral . length) lns + top = sum rowHeights / 2 + rowTops = scanl (-) top rowHeights + rowCenters = zipWith (flip (-) . (/ 2)) rowHeights rowTops + doLine line (mid, size) = + concat $ zipWith doLetter [(0 :: Int) ..] line + where + doLetter _ ' ' = [] + doLetter off letter = + map (map (trans size (size * fromIntegral (2 * off + 1 - length line) / 2, mid))) . pixBody $ font ! [letter] + trans s (dx, dy) (sx, sy) = (dx+s*sx/2, dy+s*sy/2) + +intro :: DefendFont -> Program UTCTime Image +intro font = + frame <$> relativeTime + where + frame t = + Image $ do + lighting $= Disabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + color $ Color4 0 0 0 (max 0 (4-f*0.3)) + renderPrimitive Quads . + forM_ [(-1, -1), (-1, 1), (1, 1), (1, -1)] $ \(x, y) -> + vertex $ Vertex4 x y (0 :: GLfloat) 1 + blendFunc $= (SrcAlpha, One) + color $ Color4 1 0.5 0.25 (1 - abs (0.5+f*0.1-1)) + renderPrimitive Triangles . + forM_ (expandPolygon e =<< renderText font "defend\nthe king\nfrom forces\nof different") $ \(x, y) -> + vertex $ Vertex4 x y 0 z + where + f :: GLfloat + f = 5 * realToFrac t + z' = 2-f/5 + z = 1+(3*z'^(3::Int)+z')/4 + e' = f/90-0.1 + e = (e'*e'*e'*100*3+e')/3.5 + diff --git a/src/Networking.hs b/src/Networking.hs new file mode 100644 --- /dev/null +++ b/src/Networking.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Networking + ( ProgToUdp(..), UdpToProg(..) + , udpB, httpGetB, parseSockAddr + , gUdpSocketAddresses, gRecvFrom + ) where + +import Parse (split) +import ParseStun ( + StunMessage(..), + parseStun, getRealMappedAddress) + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar (newMVar, readMVar) +import Control.Concurrent.MVar.YC (modifyMVarPure, writeMVar) +import Control.Monad (forever, join, liftM2, unless, when, replicateM) +import Data.ADT.Getters +import Data.Char (chr) +import Data.Function (fix) +import Data.List (nub) +import Data.Map ((!), insert) +import Data.Monoid (Monoid(..)) +import FRP.Peakachu.Backend (Backend(..), Sink(..)) +import Network.BSD (getHostByName, getHostName, hostAddress) +import Network.HTTP (getRequest, rspBody, simpleHTTP) +import Network.Socket ( + Family(..), HostAddress, PortNumber(..), + SockAddr(..), Socket, SocketType(..), + bindSocket, iNADDR_ANY, + recvFrom, sendTo, socket + ) +import Random (randomRIO) +import System.IO.Error (isAlreadyInUseError, try) +import Text.Read.HT (maybeRead) + +data ProgToUdp a + = CreateUdpListenSocket String a + | SendTo String SockAddr a + +data UdpToProg a + = UdpSocketAddresses [SockAddr] a + | RecvFrom String SockAddr a + deriving Show +$(mkADTGetters ''UdpToProg) + +udpB :: Ord a => Backend (ProgToUdp a) (UdpToProg a) +udpB = + Backend $ \handler -> do + socketsVar <- newMVar mempty + let + consume (CreateUdpListenSocket stunServer tag) = do + forkIO $ do + (sock, addrs) <- + getHostAddrByName stunServer >>= + createListenUdpSocket . SockAddrInet stunPort + modifyMVarPure socketsVar (insert tag sock) + handler $ UdpSocketAddresses addrs tag + forever $ do + (msg, _, sender) <- recvFrom sock 1024 + handler $ RecvFrom msg sender tag + return () + consume (SendTo msg addr tag) = do + sockets <- readMVar socketsVar + sendTo (sockets ! tag) msg addr + return () + return mempty + { sinkConsume = consume + } + +httpGetB :: Backend (String, a) (Maybe String, a) +httpGetB = + Backend $ \handler -> + return mempty + { sinkConsume = consume handler + } + where + consume handler (url, tag) = do + forkIO $ do + eresp <- simpleHTTP . getRequest $ url + case eresp of + Left _ -> handler (Nothing, tag) + Right resp -> handler (Just (rspBody resp), tag) + return () + +getHostAddrByName :: String -> IO HostAddress +getHostAddrByName = + fmap hostAddress . getHostByName + +getHostAddress :: IO HostAddress +getHostAddress = + getHostName >>= getHostAddrByName + +stunPort :: PortNumber +stunPort = fromInteger 3478 + +createListenUdpSocket :: SockAddr -> IO (Socket, [SockAddr]) +createListenUdpSocket stunServer = do + sock <- socket AF_INET Datagram 0 + iAddr <- liftM2 SockAddrInet (bindUdpAnyPort sock) getHostAddress + eAddr <- udpGetInternetAddr stunServer sock + return (sock, nub [iAddr, eAddr]) + +bindUdpAnyPort :: Socket -> IO PortNumber +bindUdpAnyPort sock = do + portNum <- fmap (PortNum . fromIntegral) $ randomRIO (0x8000 :: Int, 0xFFFF) + r <- maybeIO isAlreadyInUseError . + bindSocket sock $ + SockAddrInet portNum iNADDR_ANY + case r of + Nothing -> bindUdpAnyPort sock + _ -> return portNum + +-- | Find out internet address outside of NAT +-- using a stun server +udpGetInternetAddr :: SockAddr -> Socket -> IO SockAddr +udpGetInternetAddr stunServer sock = do + gotResponseVar <- newMVar False + forkIO . fix $ \resume -> do + gotResponse <- readMVar gotResponseVar + unless gotResponse $ do + requestRaw <- + fmap ("\0\1\0\0" ++) . + replicateM 16 . fmap chr $ randomRIO (0, 255) + sendTo sock requestRaw stunServer + threadDelay 500000 -- 0.5 second + resume + (responseRaw, _, _) <- recvFrom sock 1024 + writeMVar gotResponseVar True + let + Just response = parseStun responseRaw + Just address = getRealMappedAddress response + when (stunMsgType response /= 0x101) $ + fail "wrong response type" + return address + +maybeIO :: (IOError -> Bool) -> IO a -> IO (Maybe a) +maybeIO isExpected = + join . fmap f . try + where + f (Right x) = return $ Just x + f (Left err) + | isExpected err = return Nothing + | otherwise = ioError err + +parseSockAddr :: String -> Maybe SockAddr +parseSockAddr text = do + prt <- maybeRead portText :: Maybe Int + ipBytes <- mapM maybeRead ipBytesText + let hst = foldl ((+) . (* 0x100)) 0 (reverse ipBytes) + return $ SockAddrInet (fromIntegral prt) hst + where + (ipText, portText') = break (== ':') text + portText = drop 1 portText' + ipBytesText = split '.' ipText + diff --git a/src/ParseStun.hs b/src/ParseStun.hs new file mode 100644 --- /dev/null +++ b/src/ParseStun.hs @@ -0,0 +1,133 @@ +-- | STUN (Simple Traversal for UDP through NAT) +-- is a protocol that allows to discover the external addresses +-- of UDP sockets one initiates. +-- +-- It requires a public STUN server (see list of those at "http://www.voip-info.org/wiki/view/STUN") + +module ParseStun ( + StunAttribute(..), StunMessage(..), + parseStun, getRealMappedAddress + ) where + +import Control.Monad (guard, forever, msum, mzero, when) +import Control.Monad.Maybe (runMaybeT) +import Control.Monad.Writer (execWriterT, tell) +import Control.Monad.Trans (lift) +import Data.Binary.Get ( + Get, bytesRead, getLazyByteString, + getWord8, getWord16be, getWord16le, getWord32be, getWord32le, + remaining, runGet, skip) +import Data.Bits (xor) +import Data.ByteString.Lazy (ByteString, pack, unpack) +import Data.ByteString.Internal (c2w, w2c) -- must I really resort to use an "Internal" module? +import Data.Word (Word16, Word32) +import Network.Socket (PortNumber(..), SockAddr(..)) + +-- There must be something built in for these: +string2ByteString :: String -> ByteString +string2ByteString = pack . map c2w +byteString2String :: ByteString -> String +byteString2String = map w2c . unpack + +getString :: Integral i => i -> Get String +getString = + fmap byteString2String . + getLazyByteString . + fromIntegral + +data StunAttribute + = StunMappedAddress SockAddr + | StunResponseAddress SockAddr + | StunSourceAddress SockAddr + | StunChangedAddress SockAddr + -- XOR_MAPPED_ADDRESS is a work-around for the behaviour + -- of Linksys routers which performs man-in-the-middle + -- "attacks" to modify the MAPPED_ADDRESS. + -- Not sure why Linksys does this. + | StunXorMappedAddress SockAddr + | StunServer String + | StunAttribute Word16 String + deriving Show + +data StunMessage = StunMessage { + stunMsgType :: Word16, + stunMagicCookie :: Word32, + stunTransactId :: String, + stunAttributes :: [StunAttribute] +} deriving Show + +parseStun :: String -> Maybe StunMessage +parseStun src = + (`runGet` string2ByteString src) . runMaybeT $ do + msgType <- lift getWord16be + msgSize <- lift getWord16be + magic <- lift getWord32be + transactId <- lift $ getString (12::Int) + stopPos <- fmap (+ fromIntegral msgSize) $ lift bytesRead + attributes <- + execWriterT . + -- MaybeT to break from loop + -- the inner MaybeT is for parsing failure + runMaybeT . + forever $ do + let + liftGet = lift . lift . lift + failure = lift $ lift mzero + failIf = (`when` failure) + guard . (< stopPos) =<< liftGet bytesRead + attrType <- liftGet getWord16be + attrSize <- liftGet getWord16be + let + readAddress = do + failIf $ 8 /= attrSize + liftGet $ skip 1 + adFamily <- liftGet getWord8 + failIf $ 1 /= adFamily + adPort <- liftGet getWord16le + adHost <- liftGet getWord32le + return $ SockAddrInet (PortNum adPort) adHost + readString = liftGet $ getString attrSize + tell . return =<< case attrType of + 1 -> fmap StunMappedAddress readAddress + 2 -> fmap StunResponseAddress readAddress + 4 -> fmap StunSourceAddress readAddress + 5 -> fmap StunChangedAddress readAddress + 0x8020 -> fmap StunXorMappedAddress readAddress + 0x8022 -> fmap StunServer readString + _ -> fmap (StunAttribute attrType) readString + failIf . (> stopPos) =<< liftGet bytesRead + (`when` mzero) . (/= 0) =<< lift remaining + return $ StunMessage msgType magic transactId attributes + +littleEndianDigits :: Integral i => i -> i -> [i] +littleEndianDigits base = + map (`mod` base) . iterate (`div` base) + +fromBigEndianDigits :: Integral i => i -> [i] -> i +fromBigEndianDigits base = + foldl step 0 + where + step res x = res * base + x + +flipEndian :: Integral i => Int -> i -> i +flipEndian numBytes = + fromBigEndianDigits 256 . + take numBytes . + littleEndianDigits 256 + +getRealMappedAddress :: StunMessage -> Maybe SockAddr +getRealMappedAddress msg = + -- msum of [Maybe a] takes the first Just + msum $ map fXor attrs ++ map fMap attrs + where + attrs = stunAttributes msg + magic = stunMagicCookie msg + fXor (StunXorMappedAddress (SockAddrInet (PortNum xPort) xHost)) = + Just $ SockAddrInet (PortNum port) host + where + port = xPort `xor` flipEndian 2 (fromIntegral (magic `div` 0x10000)) + host = xHost `xor` flipEndian 4 magic + fXor _ = Nothing + fMap (StunMappedAddress x) = Just x + fMap _ = Nothing + diff --git a/src/defend.hs b/src/defend.hs --- a/src/defend.hs +++ b/src/defend.hs @@ -1,200 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Paths_DefendTheKing (getDataFileName) import Chess -import ChessFont +import Draw +import Font +import GameLogic (Move(..), PartialData(..)) +import Intro +import NetEngine +import NetMatching +import Networking -import Control.Monad (forM, join, when, unless) -import Data.Foldable (foldl', forM_) -import Data.List (genericTake) +import Control.Applicative +import Control.Category +import Control.FilterCategory +import Control.Monad ((>=>), guard, join) +import Data.ADT.Getters +import Data.Function (fix) +import Data.List (foldl') +import Data.Map (Map, findWithDefault, insert) +import Data.Maybe (fromMaybe, isNothing) import Data.Monoid +import Data.Time.Clock import FRP.Peakachu +import FRP.Peakachu.Program import FRP.Peakachu.Backend.GLUT -import Graphics.UI.GLUT - -faceNormal :: (Floating a, Ord a) => [[a]] -> [a] -faceNormal points = - normalizeVec [a1*b2-a2*b1, a2*b0-a0*b2, a0*b1-a1*b0] - where - offset = head points - base = map (zipWith (-) offset) (tail points) - [[a0, a1, a2], [b0, b1, b2]] = base - -normalizeVec :: Floating a => [a] -> [a] -normalizeVec vec - | all (== 0) vec = vec - | otherwise = map (/ norm) vec - where - norm = sqrt . sum $ map (^ (2 :: Int)) vec - -screen2board :: DrawPos -> BoardPos -screen2board (cx, cy) = - (r cx, r cy) - where - r ca = round (4 * ca + 3.5) - -board2screen :: BoardPos -> DrawPos -board2screen (bx, by) = - (r bx, r by) - where - r ba = (fromIntegral ba - 3.5) / 4 - -tailRot :: [a] -> [a] -tailRot [] = [] -tailRot (x : xs) = xs ++ [x] - -outlineSegments :: [a] -> [(a, a)] -outlineSegments xs = zip xs (tailRot xs) - -expandOutline :: GLfloat -> [DrawPos] -> [DrawPos] -expandOutline ammount outline = - last t : init t - where - t = map intersection $ outlineSegments segments - intersection - (a@((xa0, _), (xa1, _)) - ,b@((xb0, yb0), (xb1, yb1))) - | xa0 == xa1 = - (xa0, yb0 + (xa0-xb0) * (yb1-yb0) / (xb1-xb0)) - | xb0 == xb1 = intersection (b, a) - | otherwise = - (x, yAt0 a + x * d a) - where - x = (yAt0 a - yAt0 b) / (d b - d a) - d ((x0, y0), (x1, y1)) = (y1-y0)/(x1-x0) - yAt0 s@((x0, y0), _) = y0 - x0 * d s - segments = map expandSegment $ outlineSegments outline - expandSegment ((ax, ay), (bx, by)) = - ((ax + ammount * nx, ay + ammount * ny) - ,(bx + ammount * nx, by + ammount * ny)) - where - [nx, ny] = normalizeVec [ay - by, bx - ax] +import FRP.Peakachu.Backend.GLUT.Getters +import FRP.Peakachu.Backend.StdIO +import FRP.Peakachu.Backend.Time +import Graphics.UI.GLUT hiding (Program, Exit) +import Network.Socket (SockAddr) +import System.Random (randomRIO) -type Selection = (BoardPos, Maybe BoardPos) +import Prelude hiding ((.), id) -draw :: (Board, (Selection, DrawPos)) -> Image -draw (board, ((dragSrc, dragDst), (cx, cy))) = - Image $ do - cursor $= None - lineSmooth $= Enabled - polygonSmooth $= Enabled - hint LineSmooth $= Nicest - hint PolygonSmooth $= Nicest - blend $= Enabled - blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - lighting $= Enabled - light (Light 0) $= Enabled - position (Light 0) $= Vertex4 0 0 (-1) 0 - cullFace $= Nothing - drawBoard - forM_ (boardPieces board) drawPiece - when (srcFirst dragDst) $ drawCursor dragSrc - forM_ dragDst drawCursor - unless (srcFirst dragDst) $ drawCursor dragSrc - where - srcFirst Nothing = True - srcFirst (Just dst) = cursorDist dragSrc < cursorDist dst - cursorDist = cursorDist' . board2screen - cursorDist' (x, y) = (cx-x)^(2::Int) + (cy-y)^(2::Int) - headingUp = normal $ Normal3 0 0 (-1 :: GLfloat) - drawPiece piece = do - let - pix = piecePix (pieceType piece) - (px, py) = piecePos piece - (sx, sy) = board2screen (px, py) - white :: Color4 GLfloat - white = Color4 1 1 1 1 - black = Color4 0 0 0 1 - (bodyCol, outlineCol) - | pieceSide piece == White = (white, black) - | otherwise = (black, white) - vert m (vx, vy) = - vertex $ Vertex4 - (sx + m*vx) - (sy + m*vy) 0 1 - headingUp - materialDiffuse Front $= bodyCol - forM (pixBody pix) $ \poly -> do - let - polyType - | 3 == length poly = Triangles - | otherwise = Quads - renderPrimitive polyType . forM poly . vert $ pieceSize * 0.125 - materialDiffuse Front $= outlineCol - renderPrimitive Quads . - forM (pixOutline pix) $ \outline -> - forM (outlineSegments - (zip outline (expandOutline (-0.06) outline))) $ - \((a, b), (d, c)) -> - forM [a, b, c, d] . vert $ pieceSize * 0.125 - pieceSize = 0.9 - drawBoard = - forM_ [0..7] $ \bx -> - forM_ [0..7] $ \by -> do - let - col = 0.3 + 0.1 * fromIntegral ((bx + by) `mod` (2::Int)) - r ba va = 0.125*((fromIntegral ba*2+va)-7) - materialDiffuse Front $= Color4 col col col 1 - headingUp - renderPrimitive Quads . - forM square $ \(vx, vy) -> - vertex $ Vertex4 (r bx vx) (r by vy) 0 1 - drawCursor boardPos = do - cullFace $= Just Back - drawCursor' boardPos - cullFace $= Just Front - drawCursor' boardPos - drawCursor' boardPos = - renderPrimitive Triangles . - forM_ curPix $ \part -> - forM_ (outlineSegments part) $ - \((ax, ay), (bx, by)) -> do - let - (rx, ry) = board2screen boardPos - points = - [[0.9*cx, 0.9*cy, 0.9] - ,[rx + 0.125*ax, ry + 0.125*ay, 1] - ,[rx + 0.125*bx, ry + 0.125*by, 1] - ] - norml = faceNormal points - [nx, ny, nz] - | last norml < 0 = norml - | otherwise = map negate norml - normal $ Normal3 nx ny nz - materialDiffuse Front $= - case pieceUnderCursor of - Nothing -> Color4 1 1 0 0.5 - _ -> Color4 0 1 0 1 - forM_ (take 1 points) $ \[px, py, pz] -> - vertex $ Vertex4 px py 0 pz - materialDiffuse Front $= - case pieceUnderCursor of - Nothing -> Color4 1 1 0 0 - _ -> Color4 0 1 0 0.5 - forM_ (tail points) $ \[px, py, pz] -> - vertex $ Vertex4 px py 0 pz - pieceUnderCursor = pieceAt board dragSrc - curPix = - case pieceUnderCursor of - Nothing -> [square] - Just p -> map (map t) . pixOutline . piecePix $ pieceType p - where - t (x, y) = (pieceSize*x, pieceSize*y) - square = [((-1), (-1)), ((-1), 1), (1, 1), (1, (-1))] +data MyTimers + = TimerMatching + | TimerGameIter + | TimerTransmit + deriving Show +$(mkADTGetters ''MyTimers) -keyState :: UI -> Key -> Event KeyState -keyState ui key = - mappend (ereturn Up) . - fmap m $ - efilter f (glutKeyboardMouseEvent ui) - where - m (_, state, _, _) = state - f (k, _, _, _) = k == key +data MoveLimitType + = SinglePieceLimit BoardPos + | GlobalMoveLimit + deriving (Eq, Ord, Show) -delayEvent :: Integral i => i -> Event a -> Event a -delayEvent count = - fmap last . - edrop count . - escanl step [] - where - step xs x = x : genericTake count xs +data MyNode + = IGlut UTCTime (GlutToProgram MyTimers) + | IUdp (UdpToProg ()) + | IHttp (Maybe String) + | OGlut (ProgramToGlut MyTimers) + | OUdp (ProgToUdp ()) + | OHttp String + | OPrint String + | Exit + | ABoard Board + | ASelection Move + | AQueueMove Move + | AMoves [Move] + | AResetBoard + | ASide (Maybe PieceSide) + | AMatching [SockAddr] + | AMoveLimits (Map MoveLimitType Integer) + | AGameIteration Integer + | ALoopback MyNode +$(mkADTGetters ''MyNode) maybeMinimumOn :: Ord b => (a -> b) -> [a] -> Maybe a maybeMinimumOn f = @@ -205,61 +75,216 @@ | f y < f x = Just y | otherwise = Just x +distance :: DrawPos -> DrawPos -> GLfloat +distance (xA, yA) (xB, yB) = + join (*) (xA-xB) + join (*) (yA-yB) + chooseMove :: Board -> BoardPos -> DrawPos -> Maybe (BoardPos, Board) -chooseMove board src (dx, dy) = - join . - fmap (maybeMinimumOn (dist . fst) . possibleMoves board) $ +chooseMove board src drawPos = + join $ + maybeMinimumOn (distance drawPos . board2screen . fst) . possibleMoves board <$> pieceAt board src + +keyState :: Key -> MergeProgram (GlutToProgram a) KeyState +keyState key = + (lstPs . Just) Up (gKeyboardMouseEvent >=> f) where - dist pos = - (px-dx)^(2::Int) + (py-dy)^(2::Int) - where - (px, py) = board2screen pos + f (k, s, _, _) = do + guard $ k == key + return s -game :: UI -> Event Image -game ui = - fmap draw . - ezip' board $ - ezip' selection (mouseMotionEvent ui) +addP :: (Category cat, Monoid (cat a a)) => cat a a -> cat a a +addP = mappend id + +atP :: FilterCategory cat => (a -> Maybe b) -> cat a b +atP = mapMaybeC + +genericCycle :: Monoid a => a -> a +genericCycle = fix . mappend + +gGlut :: MyNode -> Maybe (GlutToProgram MyTimers) +gGlut = (fmap . fmap) snd gIGlut + +matching :: MergeProgram MyNode MyNode +matching = + mconcat + [ OHttp . fst <$> atP gMOHttp + , OGlut (SetTimer 1000 TimerMatching) <$ atP gMOSetRetryTimer + , OPrint . ("Matching:" ++) . (++ "\n") . show <$> atP gMatchingResult + , AMatching . fst <$> atP gMatchingResult + ] + . netMatching + . mconcat + [ arrC (`MIHttp` ()) . atP gIHttp + , MITimerEvent () <$ atP (gGlut >=> gTimerEvent >=> gTimerMatching) + , uncurry DoMatching <$> atP (gIUdp >=> gUdpSocketAddresses) + ] + +neteng :: Integer -> MergeProgram MyNode MyNode +neteng myPeerId = + mconcat + [ OGlut (SetTimer 25 TimerTransmit) <$ + mconcat + [ atP (gGlut >=> gTimerEvent >=> gTimerTransmit) + , singleValueP + ] + , mconcat + [ AMoves <$> atP gNEOMove + , OGlut (SetTimer 50 TimerGameIter) <$ atP gNEOSetIterTimer + , OUdp . ($ ()) . uncurry SendTo <$> atP gNEOPacket + , ASide . Just . pickSide <$> atP gNEOPeerConnected + , AResetBoard <$ atP gNEOPeerConnected + , AGameIteration <$> atP gNEOGameIteration + ] + . netEngine myPeerId + . mconcat + [ NEIMatching <$> atP gAMatching + , prepMoveToNe <$> atP gAQueueMove + , NEIIterTimer <$ atP (gGlut >=> gTimerEvent >=> gTimerGameIter) + , NEITransmitTimer <$ atP (gGlut >=> gTimerEvent >=> gTimerTransmit) + , (\(a, b, _) -> NEIPacket a b) <$> atP (gIUdp >=> gRecvFrom) + ] + ] where - board = escanl doMove chessStart moves - procDst brd src = join . fmap (chooseMove brd src) - doMove brd (src, dst) = - case procDst brd src dst of - Nothing -> brd - Just r -> snd r - selection = - fmap proc . - ezip' board $ - fmap snd selectionRaw - where - proc (brd, (src, dst)) = - (src, fmap fst (procDst brd src dst)) - selectionRaw = - edrop (1::Int) . - escanl drag (Up, undefined) $ - ezip' (keyState ui (MouseButton LeftButton)) (mouseMotionEvent ui) - drag (Down, (x, _)) (Down, c) = - (Down, (x, Just c)) - drag _ (s, c) = - (s, (spos, dst)) + prepMoveToNe move = NEIMove (moveIter move) [move] + pickSide peerId + | myPeerId < peerId = Black + | otherwise = White + +game :: Integer -> DefendFont -> Program MyNode MyNode +game myPeerId font = + runMergeProg $ + takeWhileP (isNothing . gExit) + . mconcat + [ id + , OGlut . DrawImage . mappend glStyle + <$> (mappend + <$> (draw font + <$ atP gGlut + <*> lstP gABoard + <*> lstP gASelection + <*> mouseMotion + <*> lstP gASide + <*> lstP gAGameIteration + ) + <*> MergeProg (intro font) . arrC fst . atP gIGlut + ) + , OUdp (CreateUdpListenSocket stunServer ()) <$ singleValueP + , Exit <$ atP (gGlut >=> gKeyboardMouseEvent >=> quitButton) + ] + -- loopback because board affects moves and vice versa + . loopbackP ( + lb + . addP (neteng myPeerId) + . addP calculateLimits + . addP calculateMoves + . addP calculateSelection + . addP calculateBoard + ) + . mconcat + [ id + , ASide Nothing <$ singleValueP + -- contact http server + , matching + ] + where + globalMoveLimit = 20 + pieceMoveLimit = 50 + resetOnResetBoard prog = + MergeProg . runAppendProg . genericCycle $ + AppendProg prog . takeWhileP (isNothing . (gALoopback >=> gAResetBoard)) + calculateBoard = + resetOnResetBoard $ + ABoard <$> scanlP (foldl doMove) chessStart + . atP (gALoopback >=> gAMoves) + lb = + mconcat + [ Left . ALoopback <$> filterC (isNothing . gALoopback) + , Right <$> id + ] + quitButton (Char 'q', _, _, _) = Just () + quitButton _ = Nothing + mouseMotion = (lstPs . Just) (0, 0) (gGlut >=> gMouseMotionEvent) + calculateMoves = + AQueueMove + <$ (atP gUp <* atP gDown . delayP (1 :: Int)) + . keyState (MouseButton LeftButton) . lstP gGlut + <*> delayP (1 :: Int) . lstP gASelection + rid = genericFlattenC + calculateSelection = + (rid .) $ aSelection + <$> lstP gABoard + <*> arrC snd . scanlP drag (Up, Move (0, 0) 0) . + ((,) + <$> keyState (MouseButton LeftButton) . lstP gGlut + <*> (calcMoveIter + <$> rid . (selectionSrc + <$> lstP gABoard + <*> lstP (gALoopback >=> gASide) + <*> mouseMotion + ) + <*> lstP (gALoopback >=> gAMoveLimits) + ) + ) + <*> mouseMotion + calculateLimits = + resetOnResetBoard $ + AMoveLimits <$> scanlP updateLimits mempty + . runMergeProg + ( (,) + <$> atP gAQueueMove + <*> lstP (gALoopback >=> gAGameIteration) + ) + updateLimits prev (move, iter) = + insert GlobalMoveLimit (iter + globalMoveLimit) + . insert (SinglePieceLimit (moveDst move)) (iter + pieceMoveLimit) + $ prev + aSelection board move pos = + ASelection . move . fst <$> + chooseMove board (moveSrc (getPartial move)) pos + calcMoveIter move limits = + move + . max (f GlobalMoveLimit) + . f . SinglePieceLimit + . moveSrc . getPartial $ move where - spos = screen2board c - dst - | s == Up = Nothing - | otherwise = Just c - moves = - fmap (snd . fst) $ - efilter moveFilter $ - ezip' (delayEvent (1::Int) selectionRaw) selectionRaw - moveFilter ((Down, _), (Up, _)) = True - moveFilter _ = False + f k = findWithDefault 0 k limits + doMove board move = + fromMaybe board + $ pieceAt board (moveSrc move) + >>= lookup (moveDst move) . possibleMoves board + selectionSrc board side pos = + fmap Move + . maybeMinimumOn (distance pos . board2screen) + . fmap piecePos + . filter ((&&) + <$> (/= Just False) . (<$> side) . (==) . pieceSide + <*> canMove board) + . boardPieces $ board + canMove board = not . null . possibleMoves board + drag (Down, pos) (Down, _) = (Down, pos) + drag _ x = x +-- more options at http://www.voip-info.org/wiki/view/STUN +stunServer :: String +stunServer = "stun.ekiga.net" + main :: IO () main = do initialWindowSize $= Size 600 600 initialDisplayCapabilities $= - [With DisplayRGB - ,Where DisplaySamples IsAtLeast 2 + [ With DisplayRGB + , Where DisplaySamples IsAtLeast 2 ] - run game + font <- loadFont <$> (readFile =<< getDataFileName "data/defend.font") + peerId <- randomRIO (0, 2^(128::Int)) + let + backend = + mconcat + [ uncurry IGlut <$> getTimeB . glut . atP gOGlut + , IHttp . fst <$> httpGetB . arrC (flip (,) ()) . atP gOHttp + , IUdp <$> udpB . atP gOUdp + , atP (const Nothing) . stdoutB . atP gOPrint + ] + runProgram backend (game peerId font) + diff --git a/src/defendFontEdit.hs b/src/defendFontEdit.hs new file mode 100644 --- /dev/null +++ b/src/defendFontEdit.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Geometry + +import Control.Applicative +import Control.Category +import Control.FilterCategory +import Control.Monad +import Data.ADT.Getters +import Data.Map (Map, findWithDefault, insert) +import Data.Monoid +import FRP.Peakachu +import FRP.Peakachu.Program +import FRP.Peakachu.Backend.File +import FRP.Peakachu.Backend.GLUT +import FRP.Peakachu.Backend.GLUT.Getters +import Graphics.UI.GLUT hiding (Name, Program, get) + +import Prelude hiding ((.), id) + +gridRadius :: Int +gridRadius = 4 + +type DrawPos = (GLfloat, GLfloat) + +findWithDef :: (Monoid a, Ord k) => k -> Map k a -> a +findWithDef = findWithDefault mempty + +adjustWithDef :: (Monoid a, Ord k) => (a -> a) -> k -> Map k a -> Map k a +adjustWithDef func key src = + insert key (func (findWithDef key src)) src + +toGrid :: DrawPos -> DrawPos +toGrid (x, y) = + (t x, t y) + where + t = + (/ fromIntegral gridRadius) . + fromIntegral . + (round :: GLfloat -> Int) . + (* fromIntegral gridRadius) + +snoc :: a -> [a] -> [a] +snoc x = (++ [x]) + +addPoint :: Eq a => [[a]] -> a -> [[a]] +addPoint [] x = [[x]] +addPoint ([] : ps) x = [x] : ps +addPoint (ys : ps) x + | x `elem` ys = [] : ys : ps + | otherwise = snoc x ys : ps + +data MyIn = Glut (GlutToProgram ()) | FileI (FileToProgram ()) + +data MyOut + = GlutO (ProgramToGlut ()) + | FileO (ProgramToFile ()) + +data MidLayer + = AText String + | APos DrawPos + | AClick MouseButton + | AFont (Map String [[DrawPos]]) + | ADoLoad | ADoSave + +$(mkADTGetters ''MyIn) +$(mkADTGetters ''MyOut) +$(mkADTGetters ''MidLayer) + +draw :: Map String [[DrawPos]] -> String -> DrawPos -> Image +draw font text cpos@(cx, cy) = + Image $ do + color $ Color4 0.1 0.3 0.1 (1 :: GLfloat) + renderPrimitive Triangles . + forM (addPoint polygons cpos) $ \poly -> + forM (( + filter ((== 3) . length) . + map (expandPolygon (-0.01)) . + triangulatePolygon + ) poly) . + mapM $ \(x, y) -> + vertex $ Vertex2 x y + forM gridLines $ \x -> + forM gridLines $ \y -> + drawPoint x y 0.03 (Color4 0.5 0.5 0.5 1) + forM (concat polygons) $ \(x, y) -> + drawPoint x y 0.07 (Color4 0.3 1 0.2 1) + drawPoint cx cy 0.05 (Color4 1 0.2 0.2 1) + currentRasterPosition $= Vertex4 (-1) (-1) 0 (1 :: GLfloat) + renderString Helvetica18 text + return () + where + polygons = findWithDef text font + drawPoint :: GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat -> IO () + drawPoint x y s col = + renderPrimitive Quads $ do + color col + vertex $ Vertex2 (x-s) y + vertex $ Vertex2 x (y-s) + vertex $ Vertex2 (x+s) y + vertex $ Vertex2 x (y+s) + gridLines = map ((/ fromIntegral gridRadius) . fromIntegral) [-gridRadius..gridRadius] + +gameProc :: Program MyIn MyOut +gameProc = + runMergeProg $ + mconcat + [ GlutO . DrawImage <$> (draw <$> lstP gAFont <*> lstP gAText <*> lstP gAPos) + , FileO <$> mconcat + [ doLoad <$ mapMaybeC gADoLoad <*> lstP gAText + , doSave <$ mapMaybeC gADoSave <*> lstP gAText <*> lstP gAFont + ] + ] + . mconcat + [ id + , AFont <$> + scanlP fontStep mempty . + ( (,,) + <$> mconcat + [ Left <$> mapMaybeC gAClick + , Right <$> mapMaybeC gAFont + ] + <*> lstP gAText <*> lstP gAPos + ) + ] + . mconcat + [ mconcat + [ AText <$> scanlP textStep [] . mapMaybeC typedText + , ADoLoad <$ mapMaybeC (clicka (Char 'l') (Modifiers Up Up Down)) + , ADoSave <$ mapMaybeC (clicka (Char 's') (Modifiers Up Up Down)) + , AClick <$> mapMaybeC clicksFunc + ] . mapMaybeC (gGlut >=> gKeyboardMouseEvent) + , APos <$> toGrid <$> lstP (gGlut >=> gMouseMotionEvent) + , AFont <$> read . fst <$> lstP (gFileI >=> gFileData) + ] + where + typedText (c, s, m, _) = do + guard $ m == Modifiers Up Up Up + gDown s + gChar c + doLoad x = ReadFile (x ++ ".font") () + doSave fn fnt = WriteFile (fn ++ ".font") (show fnt) () + textStep "" '\DEL' = "" + textStep xs '\DEL' = init xs + textStep "" '\b' = "" + textStep xs '\b' = init xs + textStep xs x = snoc x xs + clicka key mods (k, s, m, _) = do + guard $ k == key && m == mods + gDown s + clicksFunc (key, state, _, _) = do + gDown state + gMouseButton key + fontStep prev (Left LeftButton, text, pos) = + adjustWithDef (`addPoint` pos) text prev + fontStep prev (Left _, text, pos) = + adjustWithDef + (([] :) . filter (not . null) . + filter (notElem pos)) + text prev + fontStep _ (Right x, _, _) = x + +main :: IO () +main = do + initialWindowSize $= Size 600 600 + initialDisplayCapabilities $= + [With DisplayRGB + ,Where DisplaySamples IsAtLeast 2 + ] + let + backend = + mconcat + [ Glut <$> glut . mapMaybeC gGlutO + , FileI <$> fileB . mapMaybeC gFileO + ] + runProgram backend gameProc +