DefendTheKing 0.2.1 → 0.3
raw patch · 11 files changed
+139/−88 lines, 11 filesdep ~HTTPdep ~peakachu
Dependency ranges changed: HTTP, peakachu
Files
- DefendTheKing.cabal +3/−5
- data/defend.font +1/−1
- src/Draw.hs +3/−3
- src/Font.hs +21/−4
- src/GameLogic.hs +1/−0
- src/Intro.hs +0/−18
- src/NetEngine.hs +6/−14
- src/NetMatching.hs +1/−1
- src/Networking.hs +7/−6
- src/defend.hs +88/−27
- src/defendFontEdit.hs +8/−9
DefendTheKing.cabal view
@@ -1,5 +1,5 @@ Name: DefendTheKing-Version: 0.2.1+Version: 0.3 Cabal-Version: >= 1.2 Synopsis: A simple RTS game Category: game, FRP@@ -23,17 +23,15 @@ Data-Files: data/defend.font Executable defend- Executable: defend HS-Source-Dirs: src Main-IS: defend.hs Other-Modules: Geometry, Networking, ParseStun, Intro, Draw, Parse, NetMatching, NetEngine, Chess, GameLogic, Font- Build-Depends: base >=2 && < 5, peakachu >= 0.2, GLUT, containers,+ Build-Depends: base >=2 && < 5, peakachu >= 0.3.0, GLUT, containers, random, time, utility-ht, haskell98,- network, HTTP, mtl, bytestring, binary,+ network, HTTP >= 4000.0.5, mtl, bytestring, binary, MaybeT, zlib GHC-Options: -O2 -Wall Executable defendFontEdit- Executable: defendFontEdit HS-Source-Dirs: src Main-IS: defendFontEdit.hs Other-Modules: Geometry
data/defend.font view
@@ -1,1 +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)]])]+fromList [("",[[]]),(".",[[],[(-0.25,0.0),(0.0,0.25),(0.25,0.0),(0.0,-0.25)]]),("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/Draw.hs view
@@ -70,8 +70,8 @@ headingUp materialDiffuse Front $= bodyCol renderPrimitive Triangles .- forM (pixBody pix) .- mapM $ vert (pieceSize * 0.125)+ forM_ (pixBody pix) .+ mapM_ $ vert (pieceSize * 0.125) materialDiffuse Front $= outlineCol renderPrimitive Quads . forM (pixOutline pix) $ \outline ->@@ -140,6 +140,6 @@ 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))]+ square = [(-1, -1), (-1, 1), (1, 1), (1, -1)]
src/Font.hs view
@@ -1,11 +1,11 @@-module Font (- DefendFont, DrawPos, Pix(..),- loadFont+module Font+ ( DefendFont, DrawPos, Pix(..)+ , loadFont, renderText ) where import Geometry (triangulatePolygon) -import Data.Map (Map)+import Data.Map (Map, (!)) import Graphics.UI.GLUT (GLfloat) type DrawPos = (GLfloat, GLfloat)@@ -28,4 +28,21 @@ pixOutline = polygons, pixBody = triangulatePolygon =<< polygons }++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)
src/GameLogic.hs view
@@ -11,6 +11,7 @@ data Move = Move { moveSrc :: BoardPos+ , movePlayer :: PieceSide , moveIter :: Integer , moveDst :: BoardPos }
src/Intro.hs view
@@ -7,7 +7,6 @@ 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@@ -21,23 +20,6 @@ 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 =
src/NetEngine.hs view
@@ -75,23 +75,15 @@ => NetEngPacket a i -> SockAddr -> NetEngineOutput a i outPacket = NEOPacket . (magic ++) . withPack compress . show -withPrev :: MergeProgram a (a, a)+withPrev :: Program a (a, a) withPrev = (,) <$> delayP (1::Int) <*> id -atChgOf :: Eq b- => (a -> b) -> MergeProgram a a-atChgOf onfunc =- arrC snd . filterC (uncurry (on (/=) onfunc)) . withPrev+atChgOf :: Eq b => (a -> b) -> Program a a+atChgOf onfunc = arrC snd . filterC (uncurry (on (/=) onfunc)) . withPrev netEngine- :: ( Monoid moveType, Ord peerIdType- , Read moveType, Read peerIdType- , Show moveType, Show peerIdType- )- => peerIdType- -> MergeProgram- (NetEngineInput moveType)- (NetEngineOutput moveType peerIdType)+ :: (Monoid moveType, Ord peerIdType, Read moveType, Read peerIdType, Show moveType, Show peerIdType)+ => peerIdType -> Program (NetEngineInput moveType) (NetEngineOutput moveType peerIdType) netEngine myPeerId = mconcat [ NEOSetIterTimer <$ singleValueP@@ -161,7 +153,7 @@ state { neLocalQueue = (iter, move) : neLocalQueue state } netEngineStep state NEIIterTimer = netEngineNextIter state netEngineStep state (NEIPacket contents sender)- | isPrefixOf magic contents =+ | magic `isPrefixOf` contents = processPacket state sender . read . withPack decompress . drop (length magic) $ contents
src/NetMatching.hs view
@@ -28,7 +28,7 @@ deriving Show $(mkADTGetters ''MatchingOut) -netMatching :: (Ord a, ProgCat prog) => prog (MatchingIn a) (MatchingOut a)+netMatching :: Ord a => Program (MatchingIn a) (MatchingOut a) netMatching = mapMaybeC snd . scanlP step (mempty, Nothing) where
src/Networking.hs view
@@ -21,7 +21,8 @@ import Data.List (nub) import Data.Map ((!), insert) import Data.Monoid (Monoid(..))-import FRP.Peakachu.Backend (Backend(..), Sink(..))+import FRP.Peakachu.Backend (Backend(..))+import FRP.Peakachu.Backend.Internal (Sink(..)) import Network.BSD (getHostByName, getHostName, hostAddress) import Network.HTTP (getRequest, rspBody, simpleHTTP) import Network.Socket (@@ -50,7 +51,7 @@ socketsVar <- newMVar mempty let consume (CreateUdpListenSocket stunServer tag) = do- forkIO $ do+ _ <- forkIO $ do (sock, addrs) <- getHostAddrByName stunServer >>= createListenUdpSocket . SockAddrInet stunPort@@ -62,7 +63,7 @@ return () consume (SendTo msg addr tag) = do sockets <- readMVar socketsVar- sendTo (sockets ! tag) msg addr+ _ <- sendTo (sockets ! tag) msg addr return () return mempty { sinkConsume = consume@@ -76,7 +77,7 @@ } where consume handler (url, tag) = do- forkIO $ do+ _ <- forkIO $ do eresp <- simpleHTTP . getRequest $ url case eresp of Left _ -> handler (Nothing, tag)@@ -116,13 +117,13 @@ udpGetInternetAddr :: SockAddr -> Socket -> IO SockAddr udpGetInternetAddr stunServer sock = do gotResponseVar <- newMVar False- forkIO . fix $ \resume -> do+ _ <- 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+ _ <- sendTo sock requestRaw stunServer threadDelay 500000 -- 0.5 second resume (responseRaw, _, _) <- recvFrom sock 1024
src/defend.hs view
@@ -13,7 +13,7 @@ import Control.Applicative import Control.Category import Control.FilterCategory-import Control.Monad ((>=>), guard, join)+import Control.Monad ((>=>), forM_, guard, join) import Data.ADT.Getters import Data.Function (fix) import Data.List (foldl')@@ -21,6 +21,7 @@ import Data.Maybe (fromMaybe, isNothing) import Data.Monoid import Data.Time.Clock+import Data.Traversable (sequenceA) import FRP.Peakachu import FRP.Peakachu.Program import FRP.Peakachu.Backend.GLUT@@ -54,6 +55,7 @@ | OHttp String | OPrint String | Exit+ | AText String | ABoard Board | ASelection Move | AQueueMove Move@@ -64,6 +66,8 @@ | AMoveLimits (Map MoveLimitType Integer) | AGameIteration Integer | ALoopback MyNode+ | ADrawTimes UTCTime+ | AReadyForGame $(mkADTGetters ''MyNode) maybeMinimumOn :: Ord b => (a -> b) -> [a] -> Maybe a@@ -85,7 +89,7 @@ maybeMinimumOn (distance drawPos . board2screen . fst) . possibleMoves board <$> pieceAt board src -keyState :: Key -> MergeProgram (GlutToProgram a) KeyState+keyState :: Key -> Program (GlutToProgram a) KeyState keyState key = (lstPs . Just) Up (gKeyboardMouseEvent >=> f) where@@ -105,7 +109,7 @@ gGlut :: MyNode -> Maybe (GlutToProgram MyTimers) gGlut = (fmap . fmap) snd gIGlut -matching :: MergeProgram MyNode MyNode+matching :: Program MyNode MyNode matching = mconcat [ OHttp . fst <$> atP gMOHttp@@ -120,7 +124,7 @@ , uncurry DoMatching <$> atP (gIUdp >=> gUdpSocketAddresses) ] -neteng :: Integer -> MergeProgram MyNode MyNode+neteng :: Integer -> Program MyNode MyNode neteng myPeerId = mconcat [ OGlut (SetTimer 25 TimerTransmit) <$@@ -151,26 +155,40 @@ | myPeerId < peerId = Black | otherwise = White +drawText :: DefendFont -> String -> Image+drawText font text =+ Image $ do+ lighting $= Disabled+ color $ Color4 0.25 0 0.5 (0.5 :: GLfloat)+ renderPrimitive Triangles+ . (forM_ . join) (renderText font text)+ $ \(x, y) ->+ vertex $ Vertex4 (x/2) (y/2) 0 1++gNothing :: Maybe a -> Maybe ()+gNothing Nothing = Just ()+gNothing _ = Nothing+ 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+ , OGlut . DrawImage . mconcat+ <$ atP gADrawTimes+ <*> sequenceA+ [ pure glStyle+ , draw font+ <$> lstP gABoard <*> lstP gASelection <*> mouseMotion <*> lstP gASide <*> lstP gAGameIteration- )- <*> MergeProg (intro font) . arrC fst . atP gIGlut- )- , OUdp (CreateUdpListenSocket stunServer ()) <$ singleValueP+ , drawText font <$> lstP gAText+ , intro font . atP gADrawTimes+ ] , Exit <$ atP (gGlut >=> gKeyboardMouseEvent >=> quitButton)+ , OPrint "Got Udp Addr\n" <$ atP (gIUdp >=> gUdpSocketAddresses) ] -- loopback because board affects moves and vice versa . loopbackP (@@ -181,18 +199,60 @@ . addP calculateSelection . addP calculateBoard )+ . addP emptyP+ . addP (+ withAppendProgram2+ mappend+ ( atP (const Nothing)+ . takeWhileP (isNothing . gAReadyForGame)+ )+ ( mconcat+ [ matching+ , OUdp (CreateUdpListenSocket stunServer ()) <$ singleValueP+ ]+ )+ ) . mconcat [ id+ , drawTimes , ASide Nothing <$ singleValueP- -- contact http server- , matching+ , mconcat+ [ AText <$> atP id+ , AReadyForGame <$ atP gNothing+ , AText "" <$ atP gNothing+ ]+ . arrC head+ . takeWhileP (not . null)+ . scanlP (flip (const tail)) instructions+ . atP (gGlut >=> gKeyboardMouseEvent >=> space) ] where+ instructions =+ map Just+ [ "welcome.\nget ready to\ndefend\nthe king.\npress space."+ , "drag and drop\nsome pieces.\nhit spacebar\nto resume."+ , "there are no turns.\nwhen the cursor\nis green\n"+ ++ "you can move.\nspace for more."+ , "when you\ndefend\nthe king\nyou will not\n"+ ++ "see the whole\nbattlefield.\nspace to see\nmore instructions."+ , "you will only\nsee the squares\nin reach of\n"+ ++ "your army.\nspace for\nnext message.."+ , "press space again\nto battle\nagainst a real\nking\n"+ ++ "like you.\nexcept evil."+ ] ++ [Nothing] globalMoveLimit = 20 pieceMoveLimit = 50+ drawTimes =+ ADrawTimes <$> atP snd+ . scanlP drawTimeStep (Nothing, Nothing)+ . arrC fst . atP gIGlut+ drawTimeStep (Nothing, _) now = (Just now, Just now)+ drawTimeStep (Just prev, _) now+ | diffUTCTime now prev > 0.03 = (Just now, Just now)+ | otherwise = (Just prev, Nothing) resetOnResetBoard prog =- MergeProg . runAppendProg . genericCycle $- AppendProg prog . takeWhileP (isNothing . (gALoopback >=> gAResetBoard))+ runAppendProg . genericCycle $+ AppendProg prog . (AppendProg . takeWhileP) (isNothing . (gALoopback >=> gAResetBoard)) calculateBoard = resetOnResetBoard $ ABoard <$> scanlP (foldl doMove) chessStart@@ -202,6 +262,8 @@ [ Left . ALoopback <$> filterC (isNothing . gALoopback) , Right <$> id ]+ space (Char ' ', Down, _, _) = Just ()+ space _ = Nothing quitButton (Char 'q', _, _, _) = Just () quitButton _ = Nothing mouseMotion = (lstPs . Just) (0, 0) (gGlut >=> gMouseMotionEvent)@@ -214,7 +276,7 @@ calculateSelection = (rid .) $ aSelection <$> lstP gABoard- <*> arrC snd . scanlP drag (Up, Move (0, 0) 0) .+ <*> arrC snd . scanlP drag (Up, Move (0, 0) White 0) . ((,) <$> keyState (MouseButton LeftButton) . lstP gGlut <*> (calcMoveIter@@ -230,8 +292,7 @@ calculateLimits = resetOnResetBoard $ AMoveLimits <$> scanlP updateLimits mempty- . runMergeProg- ( (,)+ . ( (,) <$> atP gAQueueMove <*> lstP (gALoopback >=> gAGameIteration) )@@ -250,13 +311,13 @@ where f k = findWithDefault 0 k limits doMove board move =- fromMaybe board- $ pieceAt board (moveSrc move)- >>= lookup (moveDst move) . possibleMoves board+ fromMaybe board $ do+ piece <- pieceAt board . moveSrc $ move+ guard $ pieceSide piece == movePlayer move+ lookup (moveDst move) . possibleMoves board $ piece selectionSrc board side pos =- fmap Move- . maybeMinimumOn (distance pos . board2screen)- . fmap piecePos+ fmap (Move <$> piecePos <*> pieceSide)+ . maybeMinimumOn (distance pos . board2screen . piecePos) . filter ((&&) <$> (/= Just False) . (<$> side) . (==) . pieceSide <*> canMove board)
src/defendFontEdit.hs view
@@ -72,18 +72,18 @@ Image $ do color $ Color4 0.1 0.3 0.1 (1 :: GLfloat) renderPrimitive Triangles .- forM (addPoint polygons cpos) $ \poly ->- forM ((+ forM_ (addPoint polygons cpos) $ \poly ->+ forM_ (( filter ((== 3) . length) . map (expandPolygon (-0.01)) . triangulatePolygon ) poly) .- mapM $ \(x, y) ->+ mapM_ $ \(x, y) -> vertex $ Vertex2 x y- forM gridLines $ \x ->- forM gridLines $ \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) ->+ 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)@@ -103,7 +103,6 @@ gameProc :: Program MyIn MyOut gameProc =- runMergeProg $ mconcat [ GlutO . DrawImage <$> (draw <$> lstP gAFont <*> lstP gAText <*> lstP gAPos) , FileO <$> mconcat@@ -130,8 +129,8 @@ , 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)+ , APos <$> toGrid <$> mapMaybeC (gGlut >=> gMouseMotionEvent)+ , AFont <$> read . fst <$> mapMaybeC (gFileI >=> gFileData) ] where typedText (c, s, m, _) = do