{-# LANGUAGE TemplateHaskell #-}
import Paths_DefendTheKing (getDataFileName)
import Chess
import Draw
import Font
import GameLogic (Move(..), PartialData(..))
import Intro
import NetEngine
import NetMatching
import Networking
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 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)
import Prelude hiding ((.), id)
data MyTimers
= TimerMatching
| TimerGameIter
| TimerTransmit
deriving Show
$(mkADTGetters ''MyTimers)
data MoveLimitType
= SinglePieceLimit BoardPos
| GlobalMoveLimit
deriving (Eq, Ord, Show)
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 =
foldl' maybeMin Nothing
where
maybeMin Nothing x = Just x
maybeMin (Just x) y
| 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 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
f (k, s, _, _) = do
guard $ k == key
return s
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
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
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
]
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)