DefendTheKing 0.1 → 0.2
raw patch · 11 files changed
+1083/−493 lines, 11 filesdep +HTTPdep +MaybeTdep +binarydep ~peakachunew-component:exe:defendFontEdit
Dependencies added: HTTP, MaybeT, binary, bytestring, containers, haskell98, mtl, network, random, time, utility-ht, zlib
Dependency ranges changed: peakachu
Files
- DefendTheKing.cabal +19/−10
- data/defend.font +1/−0
- src/Chess.hs +0/−183
- src/ChessFont.hs +0/−66
- src/Draw.hs +145/−0
- src/Geometry.hs +127/−0
- src/Intro.hs +66/−0
- src/Networking.hs +156/−0
- src/ParseStun.hs +133/−0
- src/defend.hs +259/−234
- src/defendFontEdit.hs +177/−0
DefendTheKing.cabal view
@@ -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
+ data/defend.font view
@@ -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)]])]
− src/Chess.hs
@@ -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-
− src/ChessFont.hs
@@ -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--
+ src/Draw.hs view
@@ -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))]++
+ src/Geometry.hs view
@@ -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+
+ src/Intro.hs view
@@ -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+
+ src/Networking.hs view
@@ -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+
+ src/ParseStun.hs view
@@ -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+
src/defend.hs view
@@ -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)+
+ src/defendFontEdit.hs view
@@ -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+