Rasenschach 0.1.3.1 → 0.1.3.2
raw patch · 15 files changed
+518/−432 lines, 15 files
Files
- AI.hs +10/−11
- Animate.hs +27/−28
- BallFSM.hs +14/−15
- Data/FSM.hs +1/−1
- GameLoop.hs +1/−3
- Helper.hs +1/−2
- Lineup.hs +1/−3
- Main.hs +94/−45
- ObjectBehaviour.hs +0/−3
- Parser.hs +3/−5
- PlayerFSM.hs +52/−57
- README +34/−133
- Rasenschach.cabal +2/−2
- Render.hs +274/−120
- Rules.hs +4/−4
AI.hs view
@@ -1,5 +1,4 @@-module AI-where+module AI where import FRP.Yampa.Geometry import Data.Maybe@@ -27,20 +26,20 @@ (\_ -> Just FPEmpty) (\_ -> Just FPEmpty) (\_ -> Just FPEmpty)- (\_ -> setBestFreePlayer)+ (const setBestFreePlayer) setNearestAIPlayer- (\_ -> setBallIsFree)+ (const setBallIsFree) (\_ -> Just $ FPTeam attacker)- (\_ -> setThrowingIn)+ (const setThrowingIn) (\_ -> Just $ FPFromTo currSpot setBestPosition)- (\_ -> setKickOff)+ (const setKickOff) (\_ -> (FPPlayerId . vsObjId) `fmap`ballCarrier) setPlayerSpot setSpotValue- (\_ -> setBestShootingVector)- (\_ -> setBestPassingVector)- (\_ -> setPunt)- (\_ -> setIdling)+ (const setBestShootingVector)+ (const setBestPassingVector)+ (const setPunt)+ (const setIdling) (\_ -> Just $ FPTeam teamAtMove) (\[x, y] -> if x == y then Just FPEmpty else Nothing) setGT@@ -103,7 +102,7 @@ setPunt = let to = if attacker == Away then 20 else -20- in listToMaybe $+ in listToMaybe [FPPlayerVector (vsObjId goalie) (vector3 0 to 10) | hasBall goalie && t - fromJust timeOfPossession > 2]
Animate.hs view
@@ -1,19 +1,13 @@ module Animate where -import Graphics.UI.GLUT (GLuint)--import Control.Monad.Loops-import Control.Monad--import Data.Array import Data.IORef import Control.Concurrent.MVar import Data.Convertible import Data.Time.Clock-+import Control.Monad import FRP.Yampa -import qualified Render as Render+import qualified Render import BasicTypes import Object@@ -23,31 +17,33 @@ import GameLoop -animate' parm graphData rh timeState frameCounter newInput = do+animate' :: ReactHandle GameInput b -> Time -> IORef Time -> IORef Int -> MVar [RSEvent] ->+ IO Bool+animate' rh t0 timeState frameCounter newInput = do t <- getCurrentTime let t' = convert t :: Double- t0 <- readIORef timeState+ tLast <- readIORef timeState writeIORef timeState t'- inp <- input' parm graphData (t'-t0) frameCounter newInput True+ inp <- input' (t'-t0) (t'-tLast) frameCounter newInput react rh inp -animateInit param graphData dt timeState frameCounter objs = do- (dt, Just gi0) <- input dt timeState frameCounter True- reactInit (return gi0)- (output' param graphData)+animateInit :: Param -> GraphicsData -> IORef (Bool, Int, Int) -> Time -> IORef Double -> IORef Int ->+ [(ObjId, Object, ObjOutput)] ->+ IO (ReactHandle GameInput (AL ObjId ObjOutput))+animateInit param graphData resultRef dt timeState frameCounter objs = do+ (_, Just gi0) <- input dt timeState frameCounter True+ reactInit (return gi0) + (output' param graphData resultRef) (gameLoop param- (AL $ map (\(id, o, oo) -> (id, oo)) objs)- (AL $ map (\(id, o, oo) -> (id, o)) objs))+ (AL $ map (\(idty, _, oo) -> (idty, oo)) objs)+ (AL $ map (\(idty, o, _) -> (idty, o)) objs)) -input' :: Param ->- GraphicsData -> - Time -> +input' :: Time -> Time -> IORef Int -> MVar [RSEvent] -> - Bool -> IO (DTime, Maybe GameInput)-input' parm graphData dt counter newInput b = do+input' t dt counter newInput = do maybeEvents <- tryTakeMVar newInput putMVar newInput [] count <- readIORef counter@@ -55,23 +51,26 @@ Nothing -> [] Just es -> es writeIORef counter (count + 1)--- putStrLn . show $ events- return (dt, Just (dt * (fromIntegral count), events))-+ return (dt, Just (t, events)) output' :: (Eq a, Num a) => --(Eq a, Num i, Num a, Ix i) => Param -> GraphicsData+ -> IORef (Bool, Int, Int) -> t -> t1 -> AL a ObjOutput -> IO Bool-output' param graphData rh _ oal@(AL oos) = do+output' param graphData resultRef _ _ oal@(AL oos) = do Render.render param (map (ooObsObjState . snd) oos) graphData let ol = (AL.!) oal 1 - when (((fst . oosGameState . ooObsObjState) ol) == GSQuit) $ putStrLn "Quit"- return (((fst . oosGameState . ooObsObjState) ol) == GSQuit)+ let gs = (fst . oosGameState . ooObsObjState) ol+ let (homeGoals, awayGoals) = (oosGameScore . ooObsObjState) ol+ let aborted = (oosGameTime . ooObsObjState) ol > 120.0 + let quit = gs == GSQuit+ when quit $ writeIORef resultRef (aborted, homeGoals, awayGoals)+ return quit -- neuer Kram endet hier
BallFSM.hs view
@@ -70,32 +70,31 @@ else [(playerIdTouching, PlayerMessage (PhysicalPlayerMessage (PPTTakeMe, BSPWhoAndWhen me t))), (game, GameMessage (GTTakePossession, GPTeamPosition teamTouching (-1) [] (Point2 0 0) (-1) False InPlay))] ++- (map (\vs -> (vsObjId vs, PlayerMessage (PhysicalPlayerMessage (PPTLoseMe, BSPRelease 0 RTNothing)))) $ filter hasBall vss)+ map (\vs -> (vsObjId vs, PlayerMessage (PhysicalPlayerMessage (PPTLoseMe, BSPRelease 0 RTNothing)))) (filter hasBall vss) checkForOffsite :: Param -> (BallMsgParam, (BallMsgParam, [VisibleState])) -> [Message] checkForOffsite param (BPWho playerIdTouching t, (BPWho _ _,vss)) = let gameVS = fetchGameVS vss playerVS = fetchVS vss playerIdTouching teamTouching = vsTeam playerVS- posTouching = vsPos $ playerVS+ posTouching = vsPos playerVS in snd $ checkOffsite' param t (fst (vsGameState gameVS)) playerIdTouching teamTouching posTouching- ((snd $ vsGameState gameVS), vss)+ (snd $ vsGameState gameVS, vss) checkOffsite' :: Param -> Time -> GameState -> ObjId -> Team -> Position3 -> (GameStateParam, [VisibleState]) -> (Bool, [Message]) checkOffsite' param t gs playerIdTouching teamTouching _- (GPTeamPosition teamPassing playerIdPassing oposs posPassing _ _ _, vss) =-- if gs /= GSOffsitePending then (False, [])- else if teamTouching /= teamPassing then (False, noOffsiteMsg)- else if playerIdTouching == playerIdPassing then (False, noOffsiteMsg)- else if noOffsite teamTouching (point2Y posPassing) (posYTouchingT0 playerIdTouching) then (False, noOffsiteMsg)- else (True, offsiteMsg)-+ (GPTeamPosition teamPassing playerIdPassing oposs posPassing _ _ _, vss) + | gs /= GSOffsitePending = (False, [])+ | teamTouching /= teamPassing = (False, noOffsiteMsg)+ | playerIdTouching == playerIdPassing = (False, noOffsiteMsg)+ | noOffsite teamTouching (point2Y posPassing)+ (posYTouchingT0 playerIdTouching)+ = (False, noOffsiteMsg)+ | otherwise = (True, offsiteMsg) where me = vsObjId (fetchGameVS vss) noOffsite team posPassing' posTouchingT0 =- False || (team == Home && posTouchingT0 > halfLine) || (team == Away && posTouchingT0 < halfLine) || (team == Home && posTouchingT0 >= posPassing') ||@@ -119,11 +118,11 @@ freeBallSF :: Param -> BallStateParam -> SF (BallPerception, Event [(BallTransition, BallStateParam)]) ((State BallState BallTransition (BallStateParam, BallPerception) [Message], BallStateParam), [Message])-freeBallSF param me = reactMachineMult (fromRight $ fsm param) s1 me+freeBallSF param = reactMachineMult (fromRight $ fsm param) s1 controlledBallSF :: Param -> Bool -> BallMsgParam -> SF ((BallMsgParam, [VisibleState]), Event [(BallTransition, BallMsgParam)]) ((State BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message], BallMsgParam), [Message])-controlledBallSF param goalie me = reactMachineMult (fromRight $ fsm param) (if goalie then (s6 param) else s2 param) me+controlledBallSF param goalie = reactMachineMult (fromRight $ fsm param) (if goalie then (s6 param) else s2 param) outOfPlayBallSF :: Param -> BallMsgParam -> SF ((BallMsgParam, [VisibleState]), Event [(BallTransition, BallMsgParam)]) ((State BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message], BallMsgParam), [Message])-outOfPlayBallSF param me = reactMachineMult (fromRight $ fsm param) s4 me+outOfPlayBallSF param = reactMachineMult (fromRight $ fsm param) s4
Data/FSM.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE Arrows #-} module Data.FSM- (FSM, State, state, content, addTransition,+ (FSM, State, state, content, addTransition, runTrans, fromList, checkStates, Problem, reactMachine, reactMachineMult, reactMachineHist, fsmToDot)
GameLoop.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE Arrows #-}-+ module GameLoop where--import Debug.Trace import FRP.Yampa import FRP.Yampa.Geometry
Helper.hs view
@@ -10,8 +10,6 @@ import Data.Function import GHC.Exts -import GHC.Int- import FRP.Yampa import FRP.Yampa.Geometry @@ -24,6 +22,7 @@ import BasicTypes import AL +ratio :: Param -> Double -> Double -> Double -> Double ratio param winy maxh currh = --8.625 (currh/maxh)*(pPitchLength param/winy)
Lineup.hs view
@@ -1,7 +1,5 @@ module Lineup where--import Debug.Trace-+ import Data.List import Data.Maybe import Data.Ord
Main.hs view
@@ -1,18 +1,18 @@ module Main where- + import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)-+ import System.Directory import System.FilePath ((</>)) import Data.IORef import Control.Concurrent.MVar-import Control.Monad (when)-import Data.Convertible-import Data.Time.Clock+import Control.Monad (when, unless) import Data.List import Data.Ord (comparing) import FRP.Yampa import FRP.Yampa.Geometry+import Data.Time.Clock+import Data.Convertible import qualified Render @@ -23,16 +23,18 @@ import BasicTypes import Message import Global-import Grid-import Parser+import Grid import ParseTeam+import Data.FSM+import Menu+ import Helper import Lineup spainBorder :: RSPixel-spainBorder = RSPixel 252 0 2+spainBorder = RSPixel 252 0 2 spainCircle :: RSPixel-spainCircle = RSPixel 255 255 1+spainCircle = RSPixel 255 255 1 germanyBorder :: RSPixel germanyBorder = RSPixel 0 0 0@@ -47,14 +49,23 @@ main :: IO () main = do (win, graphData) <- Render.initGL- setupBasicFiles+ runGame win graphData +runGame :: Window -> GraphicsData -> IO ()+runGame win graphData = do timeState <- newIORef 0.0 :: IO (IORef Double) frameCounter <- newIORef 0 :: IO (IORef Int) newInput <- newMVar [] shifted <- newIORef False :: IO (IORef Bool) + let (mFsm, mState) = menuFsm + menuMode <- newIORef mState+ lastMenuPos <- newIORef (0, 0) :: IO (IORef (GLfloat, GLfloat))+ gameRunning <- newIORef False+ + resultRef <- newIORef (False, 0, 0) + (playersHome, playersAway, param) <- paramFromOutside bos <- baseObjs param@@ -62,22 +73,22 @@ let alout = appendAL bos pls let (lOO,lObj) = lineupKickoff param alout 0 Home 0 0 - rh <- animateInit param graphData 0 timeState frameCounter $ mergeAL lObj lOO+ rh <- animateInit param graphData resultRef 0 timeState frameCounter $ mergeAL lObj lOO+ rhRef <- newIORef rh + t0 <- getCurrentTime+ t0State <- newIORef (convert t0) :: IO (IORef Double)+ displayCallback $= return () keyboardMouseCallback $= Just- (\k ks mods (Position x y) -> do- when (shift mods == Down) $ do--- putStrLn "-------------Down------------"- writeIORef shifted True - when (shift mods == Up) $ do--- putStrLn "+++++++++++++Up++++++++++++++"- writeIORef shifted False+ (\k ks mods _ -> do+ when (shift mods == Down) $ + writeIORef shifted True + when (shift mods == Up) $ + writeIORef shifted False sh <- readIORef shifted--- putStrLn $ "SHIFT=" ++ show sh let e = transformButton k ks sh--- putStrLn $ "Event=" ++ show e modifyIORef' (gdCurrentTranslate graphData) $ \(x, y, z) -> (x, y, case e of RSMouseWheelUp -> z + 2@@ -93,38 +104,76 @@ winS <- readIORef (gdWinSize graphData) let (u, v) = pointToPitch param maxH currT winS (fromIntegral x, fromIntegral y) return $ - (RSMouseMotion (u + realToFrac adjX) (v + realToFrac adjY)):rs)+ RSMouseMotion (u + realToFrac adjX) (v + realToFrac adjY):rs) idleCallback $= Just ( do- terminate <- animate' param graphData rh timeState frameCounter newInput- when terminate $ do- fc <- readIORef frameCounter- putStrLn $ "Frames: " ++ show fc - destroyWindow win+ mSt <- readIORef menuMode+ currRh <- readIORef rhRef+ running <- readIORef gameRunning++ terminate <- if running then do+ t0' <- readIORef t0State+ animate' currRh t0' timeState frameCounter newInput+ else return False++ when (running && terminate) $+ writeIORef gameRunning False++ unless running $ do + mis <- tryTakeMVar newInput+ + modifyIORef' (gdCurrentTranslate graphData) $ const (0, 0, 71)+ + putMVar newInput [] + (newRunning, trans) <- Render.runMenu lastMenuPos mis (content mSt) + let Just (newSt,_) = case trans of+ Just trans' -> runTrans mFsm mSt trans' ()+ Nothing -> Just (mSt, [])+ + writeIORef menuMode newSt+ when newRunning $ do+ -- Reset game state before starting new game + writeIORef gameRunning True+ r@(aborted, hg, ag) <- readIORef resultRef+ print $ "RESULT=" ++ show r+ writeIORef timeState 0.0+ writeIORef shifted False+ t0New <- getCurrentTime+ writeIORef t0State (convert t0New) + rh' <- animateInit param graphData resultRef+ 0 timeState frameCounter $ mergeAL lObj lOO+ writeIORef rhRef rh'+ + when (content mSt == MSTerminated) $ do+ fc <- readIORef frameCounter+ putStrLn $ "Frames: " ++ show fc + destroyWindow win )+ mainLoop + transformButton :: Key -> KeyState -> Bool -> RSEvent transformButton k ks sh = case k of- Char 'a' -> rsks (RSK_a) rsms- Char 'A' -> rsks (RSK_a) rsms -- muss wohl so bei opengl, dann die Shift-Logik eigentlich unnötig...- Char 's' -> rsks (RSK_s) rsms- Char 'S' -> rsks (RSK_s) rsms- Char 'd' -> rsks (RSK_d) rsms- Char 'D' -> rsks (RSK_d) rsms- Char 'e' -> rsks (RSK_e) rsms- Char 'E' -> rsks (RSK_e) rsms- Char 'w' -> rsks (RSK_w) rsms- Char 'W' -> rsks (RSK_w) rsms- Char 'q' -> rsks (RSK_q) rsms- Char 'Q' -> rsks (RSK_q) rsms- Char 'c' -> rsks (RSK_c) rsms- Char 'y' -> rsks (RSK_y) rsms- Char 'n' -> rsks (RSK_n) rsms- Char ' ' -> rsks (RSK_SPACE) rsms- Char '\ESC' -> rsks (RSK_ESCAPE) rsms- Char 'f' -> rsks (RSK_f) rsms+ Char 'a' -> rsks RSK_a rsms+ Char 'A' -> rsks RSK_a rsms -- muss wohl so bei opengl, dann die Shift-Logik eigentlich unnötig...+ Char 's' -> rsks RSK_s rsms+ Char 'S' -> rsks RSK_s rsms+ Char 'd' -> rsks RSK_d rsms+ Char 'D' -> rsks RSK_d rsms+ Char 'e' -> rsks RSK_e rsms+ Char 'E' -> rsks RSK_e rsms+ Char 'w' -> rsks RSK_w rsms+ Char 'W' -> rsks RSK_w rsms+ Char 'q' -> rsks RSK_q rsms+ Char 'Q' -> rsks RSK_q rsms+ Char 'c' -> rsks RSK_c rsms+ Char 'y' -> rsks RSK_y rsms+ Char 'n' -> rsks RSK_n rsms+ Char ' ' -> rsks RSK_SPACE rsms+ Char '\ESC' -> rsks RSK_ESCAPE rsms+ Char 'f' -> rsks RSK_f rsms MouseButton LeftButton -> if ks==Down then RSMouseButtonDownLeft else RSBoring MouseButton RightButton -> if ks==Down then RSMouseButtonDownRight else RSBoring MouseButton WheelUp -> if ks==Down then RSMouseWheelUp else RSBoring@@ -132,7 +181,7 @@ _ -> RSBoring where rsks = if ks == Up then RSKeyUp else RSKeyDown- rsms = if sh then [RSKeyModShift] else []+ rsms = [RSKeyModShift | sh] baseObjs :: (Monad m, Num k) => t -> m (AL k ObjOutput) baseObjs _ =
ObjectBehaviour.hs view
@@ -1,9 +1,6 @@ {-# LANGUAGE Arrows, FlexibleInstances #-}- module ObjectBehaviour -- (ball, ballInPossession, player, playerAI, game) where--import Debug.Trace import GHC.Exts import Data.List
Parser.hs view
@@ -6,7 +6,6 @@ import Data.Maybe import Control.Monad (when)-import Control.Monad.Loops (unfoldWhileM) import FRP.Yampa import FRP.Yampa.Geometry@@ -16,7 +15,6 @@ import Data.FSM import Global import BasicTypes-import Helper -- ************************************************************************* --@@ -147,8 +145,8 @@ mapKeyEvent :: [RSKey] -> RSEvent -> Maybe (KeyAction, RSKey, Shifted) mapKeyEvent keys rse = case rse of- RSKeyUp key mods -> if elem key keys then Just (Up, key, checkModifiers mods) else Nothing- RSKeyDown key mods -> if elem key keys then Just (Down, key, checkModifiers mods) else Nothing+ RSKeyUp key mods -> if key `elem` keys then Just (Up, key, checkModifiers mods) else Nothing+ RSKeyDown key mods -> if key `elem` keys then Just (Down, key, checkModifiers mods) else Nothing _ -> Nothing -- mapKeyEvent keys (RSKeyUp key mods) = if elem key keys then Just (Up, key, checkModifiers mods) else Nothing -- mapkeyevent keys (RSKeyDown key mods) = if elem key keys then Just (Down, key, checkModifiers mods) else Nothing@@ -183,7 +181,7 @@ RSK_w, RSK_q, RSK_c, RSK_SPACE, RSK_ESCAPE, RSK_f]) input- let keyEvents = if keys == [] then NoEvent else Event (keys, gametime)+ let keyEvents = if null keys then NoEvent else Event (keys, gametime) result <- keyCommandSF' keysCommands -< (gametime, keyEvents) returnA -< result
PlayerFSM.hs view
@@ -1,12 +1,11 @@-module PlayerFSM (basicPlayerSF, tacticalPlayerSF, tacticalNonAiSF)--where-+module PlayerFSM (basicPlayerSF, tacticalPlayerSF, tacticalNonAiSF) where+ import Debug.Trace import FRP.Yampa import FRP.Yampa.Geometry import Data.Maybe import Data.List+import Data.Function import Data.FSM import Message@@ -52,52 +51,50 @@ in (fsm, fromJust $ find ((== initial) . content) ss) unStun :: (BasicStateParam, BasicPerception) -> [Message]-unStun ((BSPUnstun t0), (t1, me, _)) =+unStun (BSPUnstun t0, (t1, me, _)) = [(me, PlayerMessage (PhysicalPlayerMessage (PPTUnStun, BSPWhoAndWhen me t1))) | t1 - t0 > 1] takePossession :: (BasicStateParam, BasicPerception) -> [Message]-takePossession ((BSPWhoAndWhen ball t), (_, me, vss)) =+takePossession (BSPWhoAndWhen ball t, (_, me, vss)) = let role = piPlayerRole . vsPlayerInfo $ fetchVS vss me transition = if role == Goalie then BTGainedGoalie else BTGained in- [(ball, (BallMessage (transition, BPWho me t)))]+ [(ball, BallMessage (transition, BPWho me t))] takePossessionOOP :: (BasicStateParam, BasicPerception) -> [Message]-takePossessionOOP ((BSPWhoAndWhen ball t), (_, me, _)) =- [(ball, (BallMessage (BTGainedOOP, BPWho me t)))]+takePossessionOOP (BSPWhoAndWhen ball t, (_, me, _)) =+ [(ball, BallMessage (BTGainedOOP, BPWho me t))] _howfast :: Position-_howfast = 10+_howfast = 13 loseBall :: (BasicStateParam, BasicPerception) -> [Message]-loseBall ((BSPRelease dt' kickType), (t1, me, vss)) =+loseBall (BSPRelease dt' kickType, (t1, me, vss)) = let dir = vsDir $ fetchVS vss me ball = (vsObjId . fetchBallVS) vss shootV = fromPolar3 dir _howfast 0- v = if kickType == RTLow then (1 + dt') *^ shootV- else if kickType == RTHigh then ((1 + dt') *^ shootV) ^+^ vector3 0 0 10- else vector3 0 0 0- in [(ball, (BallMessage (BTLost, BPInit v me))) | kickType /= RTNothing] +++ v | kickType == RTLow = (1 + dt') *^ shootV+ | kickType == RTHigh = ((1 + dt') *^ shootV) ^+^ vector3 0 0 10+ | otherwise = vector3 0 0 0+ in [(ball, BallMessage (BTLost, BPInit v me)) | kickType /= RTNothing] ++ checkForOffsite me vss v t1 -loseBall ((BSPPass dt' kickType Nothing), (t1, me, vss)) =+loseBall (BSPPass dt' kickType Nothing, (t1, me, vss)) = let designated = fromJust $ find vsDesignated $ teamMates me vss in passTo dt' kickType me designated vss t1 -loseBall ((BSPPass dt' kickType (Just receiverId)), (t1, me, vss)) =+loseBall (BSPPass dt' kickType (Just receiverId), (t1, me, vss)) = let receiverVs = fetchVS vss receiverId in passTo dt' kickType me receiverVs vss t1 -loseBall ((BSPShoot vel), (t1, me, vss)) =- [((vsObjId . fetchBallVS) vss, (BallMessage (BTLost, BPInit vel me)))] +++loseBall (BSPShoot vel, (t1, me, vss)) =+ ((vsObjId . fetchBallVS) vss, BallMessage (BTLost, BPInit vel me)) : checkForOffsite me vss vel t1 passTo :: Position -> ReleaseType -> ObjId -> VisibleState -> [VisibleState] -> Time -> [(ObjId, MessageBody)] passTo dt' kickType passerId receiverVs vss t1 =- let (xd, yd) = trace ("CCCC-Dest " ++ show ((point3X $ vsPos receiverVs, point3Y $ vsPos receiverVs)))- (point3X $ vsPos receiverVs, point3Y $ vsPos receiverVs)- (a , vd) = trace ("CCCC-VelD " ++ show (norm $ vsVel receiverVs))- (vsDir receiverVs, norm $ vsVel receiverVs)+ let (xd, yd) = (point3X $ vsPos receiverVs, point3Y $ vsPos receiverVs)+ (a , vd) = (vsDir receiverVs, norm $ vsVel receiverVs) ball = fetchBallVS vss ballId' = vsObjId ball@@ -106,15 +103,12 @@ (point3X $ vsPos ball, point3Y $ vsPos ball) vb = (1+dt')*_howfast--- (t, b) = fromMaybe (0, 0) $ findBestTime (xd, yd, a, norm vd) (xb, yb, vb)- (_, b) =- trace ("CCCC-Resl " ++ (show $ fromMaybe (0,0) $ findBestTime (xd, yd, a, norm vd) (xb, yb, vb)))- (fromMaybe (0,0) $ findBestTime (xd, yd, a, vd) (xb, yb, vb))+ (_, b) = fromMaybe (0,0) $ findBestTime (xd, yd, a, vd) (xb, yb, vb) - v = (vector3 (vb*cos b) (vb*sin b)- (if kickType == RTHigh then (1+dt')*5 else 0))+ v = vector3 (vb*cos b) (vb*sin b)+ (if kickType == RTHigh then (1+dt')*5 else 0) - in [(ballId', (BallMessage (BTLost, BPInit v passerId))) | kickType /= RTNothing] +++ in [(ballId', BallMessage (BTLost, BPInit v passerId)) | kickType /= RTNothing] ++ checkForOffsite passerId vss v t1 checkForOffsite :: RealFloat a => ObjId -> [VisibleState] -> Vector3 a -> Time -> [(ObjId, MessageBody)]@@ -124,17 +118,17 @@ myTeam = vsTeam myVs myPos = projectP $ vsPos myVs oposs = map (\vs -> (myTeam, vsObjId vs, point3Y (vsPos vs))) $ teamMates me vss- otherOposs = map (\vs -> ((otherTeam myTeam, vsObjId vs, point3Y (vsPos vs)))) $+ otherOposs = map (\vs -> (otherTeam myTeam, vsObjId vs, point3Y (vsPos vs))) $ teamPlayers (otherTeam myTeam) vss- in [(gameId', (GameMessage (GTCheckOffsite, GPTeamPosition myTeam me (oposs++otherOposs) myPos t1 False InPlay)))+ in [(gameId', GameMessage (GTCheckOffsite, GPTeamPosition myTeam me (oposs++otherOposs) myPos t1 False InPlay)) | pointsForward dir myTeam] findBestTime :: (Enum a, Floating a, Ord a) => (a, a, a, a) -> (a, a, a) -> Maybe (a, a) findBestTime d b = let fits = concatMap (fit d b) [0.05,0.051..3.5]- in if fits == [] then Nothing+ in if null fits then Nothing -- else Just . fst $ minimumBy (\a b -> compare (snd a) (snd b)) fits- else Just . fst $ localMinimumBy (\a b' -> compare (snd a) (snd b'))+ else Just . fst $ localMinimumBy (compare `on` snd) (head fits) fits @@ -152,12 +146,13 @@ fit (xd, yd, a, vd) (xb, yb, vb) t = let sinB = (yd' - yb) / (vb*t) cosB = (xd' - xb) / (vb*t)- xd' = xd + vd*t*(cos a)- yd' = yd + vd*t*(sin a)- quadrant = if xd'>=xb && yd'>=yb then Q1- else if xd'<xb && yd'>=yb then Q2- else if xd'<xb && yd'<yb then Q3- else Q4+ xd' = xd + vd*t*cos a+ yd' = yd + vd*t*sin a+ quadrant+ | xd' >= xb && yd' >= yb = Q1+ | xd' < xb && yd' >= yb = Q2+ | xd' < xb && yd' < yb = Q3+ | otherwise = Q4 bSin = asinNorm quadrant (asin sinB) bCos = acosNorm quadrant (acos cosB)@@ -276,7 +271,7 @@ -- All of the following functions are of type :: (TacticalStateParam, TacticalPerception) -> [Message] tendGoal :: Param -> (TacticalStateParam, (Time, ObjId, [VisibleState], t)) -> [(ObjId, MessageBody)]-tendGoal param ((TacticalStateParam _ _ _ _ _ _ _), (t, me, vss, _)) =+tendGoal param (TacticalStateParam {}, (t, me, vss, _)) = let myself = fetchVS vss me team = vsTeam myself ball = fetchBallVS vss@@ -296,8 +291,8 @@ vn = normalize $ vector2 (bx-x0) (by-y0) distB = sqrt $ sqr (bx-x0) + sqr (by-y0) r = factor * distB- xg = r * (vector2X vn) + x0- yg = r * (vector2Y vn) + y0+ xg = r * vector2X vn + x0+ yg = r * vector2Y vn + y0 in Point2 xg yg goaliePosition param Home factor (Point2 bx by) = let bxMirror = pPitchWidth param - bx@@ -307,29 +302,29 @@ turnTowards :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]-turnTowards ((TacticalStateParam _ mvd@(Just vd) _ rec _ kt _), (_, me, _, _)) =+turnTowards (TacticalStateParam _ mvd@(Just vd) _ rec _ kt _, (_, me, _, _)) = let dir = atan2 (vector3Y vd) (vector3X vd) in [(me, tm (TPTWait, TacticalStateParam Nothing mvd False rec (Just dir) kt Nothing))]-turnTowards ((TacticalStateParam _ _ _ mr _ kt _), (_, me, _, _)) =+turnTowards (TacticalStateParam _ _ _ mr _ kt _, (_, me, _, _)) = [(me, tm (TPTWait, TacticalStateParam Nothing Nothing False mr Nothing kt Nothing))] kickTowards :: (TacticalStateParam, (t, t3, t1, t2)) -> [(t3, MessageBody)]-kickTowards ((TacticalStateParam _ (Just vd) _ Nothing _ _ _), (_, me, _, _)) =+kickTowards (TacticalStateParam _ (Just vd) _ Nothing _ _ _, (_, me, _, _)) = [(me, pm (PPTLoseMe, BSPShoot vd))]-kickTowards ((TacticalStateParam _ _ _ (Just receiver) _ (Just kt) _), (_, me, _, _)) =+kickTowards (TacticalStateParam _ _ _ (Just receiver) _ (Just kt) _, (_, me, _, _)) = [(me, pm (PPTLoseMe, BSPPass 1 kt (Just receiver)))] intercept :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]-intercept ((TacticalStateParam posTarget _ _ _ _ _ _), (_, me, vss, _)) =+intercept (TacticalStateParam posTarget _ _ _ _ _ _, (_, me, vss, _)) = let ball = fetchBallVS vss posBall = projectP . vsPos $ ball velBall = project . vsVel $ ball (bs, _) = vsBallState ball myPos = (projectP . vsPos . fetchVS vss) me- adjust = if abs (getAngle velBall - (getAngle (myPos .-. posBall))) > 0.2+ adjust = if abs (getAngle velBall - getAngle (myPos .-. posBall)) > 0.2 then velBall else vector2 0 0 in [if bs == BSFree then@@ -340,20 +335,20 @@ TacticalStateParam posTarget Nothing False Nothing Nothing Nothing Nothing))] dropInterception :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]-dropInterception ((TacticalStateParam posTarget _ _ _ _ _ _), (_, me, vss, _)) =+dropInterception (TacticalStateParam posTarget _ _ _ _ _ _, (_, me, vss, _)) = let interceptors = map vsObjId $ filter ((TSInterceptBall ==) . fst . vsPTState) (teamMates me vss) in [(interceptor, tm (TPTDropInterception, TacticalStateParam posTarget Nothing False Nothing Nothing Nothing Nothing)) | interceptor <- interceptors] checkIfPositionReached :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]-checkIfPositionReached ((TacticalStateParam posTarget _ _ _ _ _ _), (_, me, vss, _)) =+checkIfPositionReached (TacticalStateParam posTarget _ _ _ _ _ _, (_, me, vss, _)) = let posPlayer = projectP . vsPos $ fetchVS vss me in [(me, tm (TPTWait, TacticalStateParam posTarget Nothing False Nothing Nothing Nothing Nothing))- | (distance (fromJust posTarget) posPlayer < 2)]+ | distance (fromJust posTarget) posPlayer < 2] holdPosition :: Param -> (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]-holdPosition param ((TacticalStateParam mobp _ _ _ _ _ _), (_, me, vss, _)) =+holdPosition param (TacticalStateParam mobp _ _ _ _ _ _, (_, me, vss, _)) = let attacker = vsAttacker $ fetchGameVS vss sp@(TacticalStateParam (Just newTargetPos) _ _ _ _ _ _) = basePosition param me vss attacker currPos = vsPos $ fetchVS vss me@@ -364,8 +359,8 @@ -- 5m off in 5m is too far (ratio=1) -- 2 1/2m off in 5m is too far (ratio=0.5) -- 5m off in 50m is close enough (ratio=0.1)- tooFarOff = (distance newTargetPos oldTargetPos) /- (distance newTargetPos (projectP currPos)) > 0.5+ tooFarOff = distance newTargetPos oldTargetPos /+ distance newTargetPos (projectP currPos) > 0.5 in [(me, tm (TPTHoldPosition, sp)) | tooFarOff] holdThrowInPosition :: Param -> (t, (t1, ObjId, [VisibleState], t2)) -> [(ObjId, MessageBody)]@@ -390,8 +385,8 @@ | not iHaveTheBall] -- (bs == BSControlled && bsp == BPWho me)] coverPlayer :: Param -> (TacticalStateParam, (t, t2, [VisibleState], t1)) -> [(t2, MessageBody)]-coverPlayer param ((TacticalStateParam _ _ _ tc@(Just toCover) _ _ _), (_, me, vss, _)) =- let myState = fetchVS vss toCover+coverPlayer param (TacticalStateParam _ _ _ tc@(Just toCover) _ _ _, (_, me, vss, _)) =+ let myState = fetchVS vss toCover posCover = projectP . vsPos $ myState myCoverRatio = piPlayerCoverRatio . vsPlayerInfo $ myState posTarget = posCover .+^ myCoverRatio *^ (awayGoalCenter param .-. posCover)
README view
@@ -1,142 +1,43 @@ ===== R A S E N S C H A C H ====== Single player, mouse controlled soccer game with simple graphics and flexible, -extensible AI. Based on the Yampa arcade and Gerold Meisinger's Yampa/SDL stub.+extensible AI. Based on the Yampa arcade. -Backlog:-=================================================================================-No. T A S K S T A T E-=================================================================================-1 graphics rendering for ball and player done (basics)-----------------------------------------------------------------------------------2 FRP version of Finite State Machine done (basics)-----------------------------------------------------------------------------------3 basic FRP feedback loop done (basics)-----------------------------------------------------------------------------------4 rendering for game object (score and game time) done (basics) -----------------------------------------------------------------------------------5a basic version of player FSM done (basics)-----------------------------------------------------------------------------------5b basic version of game FSM done (basics)-----------------------------------------------------------------------------------6 "kickoff-situation": players move from sideline done (basics)- to pre-kickoff base position-----------------------------------------------------------------------------------7 add sound to player and ball action done (basics)-----------------------------------------------------------------------------------8 basic mouse and keyboard input events (see Yampa done (basics)- arcade parser)-----------------------------------------------------------------------------------9 single player moves around based on input events done (basics)-----------------------------------------------------------------------------------10 add ball control to 9 done (basics)-----------------------------------------------------------------------------------11 add shooting to 10 done (basics)-----------------------------------------------------------------------------------12 add another player to 10 done (basics)-----------------------------------------------------------------------------------13 add "on key down"-FSM to parser done (basics)-----------------------------------------------------------------------------------14 add "take ball from other player" to fsms done (basics)-----------------------------------------------------------------------------------15 define core player (base for AI and user player) done (basics)-----------------------------------------------------------------------------------16 add bounce logic to player collision done (basics)-----------------------------------------------------------------------------------17 define team objects (which will compute AI orders) done (basics)-----------------------------------------------------------------------------------18 add team membership and position to player object done (basics)-----------------------------------------------------------------------------------19 define bouncing logic for goal post later-----------------------------------------------------------------------------------20 add stunning logic (probably on hard collision?) later -----------------------------------------------------------------------------------21 send proper messages on goal, out (side, end) done "simple events"-----------------------------------------------------------------------------------22 set up new game afer goal or out (simplistic) done "simple events"-----------------------------------------------------------------------------------23 enhance offensive ai: shoot on goal when free sprint "playable version"-----------------------------------------------------------------------------------24 enhance defensive ai: attack when near own goal later -----------------------------------------------------------------------------------25 add goalie (own player object?) later -----------------------------------------------------------------------------------26 add proper throw in (ball behind player's head) done "simple events"-----------------------------------------------------------------------------------27 selection of "designated player" by mouse later -----------------------------------------------------------------------------------28 new key action: pass to designated player done "playable version"-----------------------------------------------------------------------------------29 new key action: pass to running player (aim ahead) later -----------------------------------------------------------------------------------30 write TH parser for AI commands later -----------------------------------------------------------------------------------31 proper FSM for game object done "simple events"-----------------------------------------------------------------------------------32 render something nice for designated receiver later -----------------------------------------------------------------------------------33 new key action: switch to nearest player later -----------------------------------------------------------------------------------34 pause and resume game action later-----------------------------------------------------------------------------------35 enhance offensive ai: pass to better positioned later - player -----------------------------------------------------------------------------------36 add multiple round mechanism a la Yampa Arcade: done "simple events"- new round would be entered on kick off -----------------------------------------------------------------------------------37 controlled player can also throw in (very basic) done "playable version"-----------------------------------------------------------------------------------38 AI action: throw in done "simple events"- - compute spot for throw in- - aim for this spot (not throw in immediately)- - throw in and resume play-----------------------------------------------------------------------------------39 Bug: when ball goes out of bounce, and then ai done "simple events"- player touches it, then other team won't take it-----------------------------------------------------------------------------------40 Bug: when player throws in, he immediately retakes done "simple events"- the ball since he is in the way of the ball...-----------------------------------------------------------------------------------41 Hack: on base out, throw in near the base line done "playable version"-----------------------------------------------------------------------------------42 display controlled player blinking done "playable version"-----------------------------------------------------------------------------------43 controlled player can also kick off done "playable version"-----------------------------------------------------------------------------------44 display goal event and score sprint "playable version"-----------------------------------------------------------------------------------45 fix meterToPixel stuff (y axis kind of weird) done "playable version"-----------------------------------------------------------------------------------46 player who kicked off or threw in etc. can not be later- the first to touch the ball again-----------------------------------------------------------------------------------47 controlled player can aim for throw in (follow up later- to 37)-----------------------------------------------------------------------------------48 if controlled player throws in, then stop other later- player moving_to_throwin from grabbing the ball -----------------------------------------------------------------------------------49 Bug: if team consists solely of non AI players, later - this line in ObjectBehaviour / player blows:+Controls: - let np = nearestNonAIPlayer myTeam vss pd- -----------------------------------------------------------------------------------50 Bug: if kick off goes directly to side out, no one later- throws in and the state remains "GSRunning" instead- of GSSideOut -----------------------------------------------------------------------------------51 for test, it would be good to have an editor of sprint "refinement"- some kind for game situations (player position, - heading and speed, dito for ball)----------------------------------------------------------------------------------+Keys:+q/Q Move designated player (marked with !) to goal / to me+w/W Move designated player to left / right+e/E Move designated player forward / backward+a/A Pass low / high (hold key for faster pass)+s/S Kick low / high (hold key for faster kick)+d/D Flip ball to designated player+SPACE toggle ball from one side to other +Mouse:+Move User controlled player follows mouse pointer+Left button Select nearest player+Wheel Zoom in / out -Taglist:++Backlog: =================================================================================-T A G C O N T E N T S+Item Description =================================================================================-RSSP-0.0.1 basics- "simple events" ----------------------------------------------------------------------------------+19 define bouncing logic for goal post+20 add stunning logic (probably on hard collision?)+24 enhance defensive ai: attack when near own goal+46 player who kicked off or threw in etc. can not be the first to touch the ball+47 controlled player can aim for throw in (follow up to 37)+48 if controlled player throws in, then stop other player moving_to_throwin from grabbing the ball+49 Bug: if team consists solely of non AI players, this line in ObjectBehaviour / player blows: let np = nearestNonAIPlayer myTeam vss pd+51 for testing, it would be good to have an editor of some kind for game situations (player position,heading and speed, dito for ball)+52 Grid: If no best spot computable throws exception. Better to return „Maybe Spot“+61 Bug: On throw in, player sometime comes to take the ball but then does not throw in+67 add one-two (doppelpass) functionality+68 add pass-to-shoot functionality+69 enhance goalie: should not retreat to goal when player shoots+70 Bug / strange behaviour on ai passing: sometimes seems to pass to void+79 add sound +84 render start / stop-texts+
Rasenschach.cabal view
@@ -1,5 +1,5 @@ name: Rasenschach-version: 0.1.3.1+version: 0.1.3.2 cabal-version: >=1.2 build-type: Simple license: BSD3@@ -34,5 +34,5 @@ Main States AI Grid Parser Lineup Main Data.FSM Physics Render AL Message Object BasicTypes Main States Render Util Main ghc-prof-options: --enable-executable-profiling- ghc-options: -O2+ ghc-options: -O2 -Wall
Render.hs view
@@ -1,18 +1,21 @@-module Render (render, initGL) where+module Render (render, initGL, runMenu) where import FRP.Yampa.Geometry import GHC.Exts (sortWith)-import Graphics.UI.GLUT+import Graphics.UI.GLUT hiding (MenuEntry) import Graphics.Rendering.OpenGL.Raw import qualified Graphics.UI.GLUT as G(Vector3(..)) import Foreign ( withForeignPtr, plusPtr, alloca, peek ) import qualified Data.ByteString.Internal as BSI import Data.Time.Clock+import Foreign.C.Types import Data.IORef-import Control.Monad+import Data.Maybe (isJust, fromJust)+import Data.List+import Control.Monad +import Control.Applicative ((<$>)) -import Physics import States import Global import Object@@ -20,22 +23,19 @@ import Util import Message import Helper+import Menu+ import Paths_Rasenschach -win2pitch :: Param -> Int -> Int -> Int -> Int -> Position2-win2pitch param winX winY x y = - Point2 (fromIntegral x) (fromIntegral y)- renderObjects :: Param -> [ObsObjState] -> GraphicsData -> IO () renderObjects param oos graphData = do let texHome = gdTextureHome graphData - let texAway = gdTextureAway graphData + texAway = gdTextureAway graphData (oldX, oldY, currTZ) <- readIORef (gdCurrentTranslate graphData)- (winX, winY) <- readIORef $ gdWinSize graphData clear [ ColorBuffer, DepthBuffer ] loadIdentity@@ -62,15 +62,13 @@ case os of OOSBall oosPos' _- oosBounced'- oosPState+ _ -- oosBounced'+ _ -- oosPState -> renderBall- (Point3 (fst (translateToScreen pW pL (realToFrac . point3X $ oosPos')- (realToFrac . point3Y $ oosPos')))- (snd (translateToScreen pW pL (realToFrac . point3X $ oosPos')- (realToFrac . point3Y $ oosPos')))+ (uncurry Point3+ (translateToScreen pW pL (realToFrac . point3X $ oosPos')+ (realToFrac . point3Y $ oosPos')) (realToFrac . point3Z $ oosPos'))- OOSPlayer oosPos' _ _@@ -90,7 +88,7 @@ OOSGame oosGameTime' oosGameScore' oosGameState'- oosAttacker'+ _ -- oosAttacker' _ -> renderGame adjX' adjY' oosGameTime' oosGameScore' oosGameState' @@ -104,6 +102,9 @@ pL = realToFrac $ pPitchLength param +renderGame :: (Num a1, Ord a1, Real a2, Real a3, RealFrac a, Show a1) =>+ a2 -> a3 -> a -> (a1, a1) -> (GameState, GameMsgParam) ->+ IO () renderGame adjX' adjY' t (scoreHome, scoreAway) (gState, gStateParam) = do preservingMatrix $ do @@ -115,7 +116,7 @@ renderString Roman $ show scoreHome ++ " - " ++ show scoreAway ++ " " ++ show min' ++ ":" ++ show sec - when (gState == GSKickOff && scoreHome + scoreAway > 0) $ do+ when (gState == GSKickOff && scoreHome + scoreAway > 0) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat)@@ -123,30 +124,31 @@ let (GPTeamPosition _ _ _ _ _ _ oop) = gStateParam - when (oop == OOPSideOut) $ do+ when (oop == OOPSideOut) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat) renderString Roman "THROW IN!" - when (oop == OOPOffsite) $ do+ when (oop == OOPOffsite) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat) renderString Roman "OFFSITE!" - when (oop == OOPBaseOut) $ do+ when (oop == OOPBaseOut) $ preservingMatrix $ do translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 scale 0.04 0.04 (0.04::GLfloat) renderString Roman "CORNER!" +translateToScreen :: (Fractional t, Fractional t1) => t -> t1 -> t -> t1 -> (t, t1) translateToScreen pW pL u v = (u - pW/2, (pL-v)-pL/2) render :: Param -> [ObsObjState] -> GraphicsData -> IO ()-render param oos gd = renderObjects param oos gd+render = renderObjects renderPlayer :: GLuint -> GLuint-> Team -> Bool -> Bool -> (GLfloat, GLfloat) -> DisplayCallback renderPlayer texHome texAway team selected designated pos = do@@ -156,11 +158,11 @@ color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) when (team==Away) $ color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat)- when (selected && blink) $ do+ when (selected && blink) $ color $ Color3 (116/255::GLfloat) (172/255::GLfloat) (223/255::GLfloat) preservingMatrix $ do - translate $ Vector3 x y (0.5)+ translate $ Vector3 x y 0.5 renderChip tex 12 6 0.10 when designated $ do translate $ Vector3 (-0.3) (2::R) 0@@ -169,9 +171,10 @@ where (x,y) = pos -renderBall pPos = do- preservingMatrix $ do- (color red >>) . (renderShapeAt $ Sphere' 0.60 20 20) $ v+renderBall :: RealFloat t => Point3 t -> IO ()+renderBall pPos = + preservingMatrix $ + (color red >>) . renderShapeAt (Sphere' 0.60 20 20) $ v where red = Color4 1.0 0.7 0.8 1.0 :: Color4 R Point3 x y z = pPos v = vector3 (realToFrac x) (realToFrac y) (realToFrac z)@@ -182,6 +185,7 @@ renderObject Solid s +playingField :: GLfloat -> GLfloat -> IO () playingField a b = do color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) renderPrimitive Lines $ mapM_ (pushV a b) vs @@ -196,103 +200,103 @@ where pushV :: GLfloat -> GLfloat -> (GLfloat, GLfloat, GLfloat) -> IO ()- pushV a b (u,v,w) = - vertex $ Vertex3 (a*u/2) (b*v/2) w+ pushV a' b' (u,v,w) = + vertex $ Vertex3 (a'*u/2) (b'*v/2) w vs :: [(GLfloat, GLfloat, GLfloat)]- vs = [((-1),(-1),0)- ,((-1),(1), 0)+ vs = [(-1,-1,0)+ ,(-1,1, 0) - ,((-1),(1), 0)- ,(( 1),(1), 0)+ ,(-1,1, 0)+ ,( 1,1, 0) - ,(( 1),(1), 0)- ,((1),(-1),0)+ ,( 1,1, 0)+ ,(1,-1,0) - ,((1),(-1),0)- ,((-1),(-1),0)+ ,(1,-1,0)+ ,(-1,-1,0) - ,((-1),(0),0)- ,((1),(0),0)+ ,(-1,0,0)+ ,(1,0,0) -- lower box- ,((-0.6),(-0.60),0)- ,((0.6),(-0.60),0)+ ,(-0.6,-0.60,0)+ ,(0.6,-0.60,0) - ,((-0.6),(-0.60),0)- ,((-0.6),(-1.0),0)+ ,(-0.6,-0.60,0)+ ,(-0.6,-1.00,0) - ,((0.6),(-0.60),0)- ,((0.6),(-1.0),0)+ ,(0.6,-0.60,0)+ ,(0.6,-1.0,0) -- goalie box- ,((-0.3),(-0.85),0)- ,((0.3),(-0.85),0)+ ,(-0.3,-0.85,0)+ ,(0.3,-0.85,0) - ,((-0.3),(-0.85),0)- ,((-0.3),(-1.0),0)+ ,(-0.3,-0.85,0)+ ,(-0.3,-1.0,0) - ,((0.3),(-0.85),0)- ,((0.3),(-1.0),0)+ ,(0.3,-0.85,0)+ ,(0.3,-1.0,0) -- goal- ,((-0.12),(-0.999),0)- ,((-0.12),(-0.999),0.1)+ ,(-0.12,-0.999,0)+ ,(-0.12,-0.999,0.1) - ,((0.12),(-0.999),0)- ,((0.12),(-0.999),0.1)+ ,(0.12,-0.999,0)+ ,(0.12,-0.999,0.1) - ,((-0.12),(-0.999),0.1)- ,((0.12),(-0.999),0.1)+ ,(-0.12,-0.999,0.1)+ ,(0.12,-0.999,0.1) - ,((-0.12),(-0.999),0.1)- ,((-0.12),(-1.05),0)+ ,(-0.12,-0.999,0.1)+ ,(-0.12,-1.05,0) - ,((0.12),(-0.999),0.1)- ,((0.12),(-1.05),0)+ ,(0.12,-0.999,0.1)+ ,(0.12,-1.05,0) - ,((-0.12),(-1.05),0)- ,((0.12),(-1.05),0)+ ,(-0.12,-1.05,0)+ ,(0.12,-1.05,0) -- upper box- ,((-0.6),(0.60),0)- ,((0.6),(0.60),0)+ ,(-0.6,0.60,0)+ ,(0.6,0.60,0) - ,((-0.6),(0.60),0)- ,((-0.6),(1.0),0)+ ,(-0.6,0.60,0)+ ,(-0.6,1.0,0) - ,((0.6),(0.60),0)- ,((0.6),(1.0),0)+ ,(0.6,0.60,0)+ ,(0.6,1.0,0) -- goalie box- ,((-0.3),(0.85),0)- ,((0.3),(0.85),0)+ ,(-0.3,0.85,0)+ ,(0.3,0.85,0) - ,((-0.3),(0.85),0)- ,((-0.3),(1.0),0)+ ,(-0.3,0.85,0)+ ,(-0.3,1.0,0) - ,((0.3),(0.85),0)- ,((0.3),(1.0),0)+ ,(0.3,0.85,0)+ ,(0.3,1.0,0) -- goal- ,((-0.12),(0.999),0)- ,((-0.12),(0.999),0.1)+ ,(-0.12,0.999,0)+ ,(-0.12,0.999,0.1) - ,((0.12),(0.999),0)- ,((0.12),(0.999),0.1)+ ,(0.12,0.999,0)+ ,(0.12,0.999,0.1) - ,((-0.12),(0.999),0.1)- ,((0.12),(0.999),0.1)+ ,(-0.12,0.999,0.1)+ ,(0.12,0.999,0.1) - ,((-0.12),(0.999),0.1)- ,((-0.12),(1.05),0)+ ,(-0.12,0.999,0.1)+ ,(-0.12,1.05,0) - ,((0.12),(0.999),0.1)- ,((0.12),(1.05),0)+ ,(0.12,0.999,0.1)+ ,(0.12,1.05,0) - ,((-0.12),(1.05),0)- ,((0.12),(1.05),0)+ ,(-0.12,1.05,0)+ ,(0.12,1.05,0) ] @@ -321,7 +325,7 @@ texHome <-loadTexture fn1 fn2 <- getDataFileName "england2.bmp" texAway <-loadTexture fn2- return $ (win, GraphicsData ws 141 ct texHome texHome texHome texAway texAway texAway)+ return (win, GraphicsData ws 141 ct texHome texHome texHome texAway texAway texAway) -- Copied from reactive-glut resizeScene :: IORef (Int, Int) -> Size -> IO ()@@ -335,9 +339,9 @@ matrixMode $= Modelview 0 flush where- w2 = half width- h2 = half height- half z = realToFrac z / 2+ w2 = half' width+ h2 = half' height+ half' z = realToFrac z / 2 -- -------------------------------------------------------------------- -- A B H I E R C H I P - C O D E@@ -369,9 +373,9 @@ vertex3f (dir>0) p2' vertex3f :: Bool -> (GLfloat, GLfloat, GLfloat) -> IO ()-vertex3f texture (x, y, z) = do+vertex3f texture' (x, y, z) = do let (x',y') = ((x+1)/2, (y+1)/2)- when texture $ texCoord (TexCoord2 x' y') + when texture' $ texCoord (TexCoord2 x' y') vertex $ Vertex3 x y z lenVec :: Floating a => (a, a, a) -> a@@ -391,25 +395,25 @@ (a1-b1, a2-b2, a3-b3) innerCircle :: Int -> Int -> [(GLfloat, GLfloat)]-innerCircle numSegs skip = upperInnerCircle numSegs skip ++ (lowerInnerCircle numSegs skip)+innerCircle numSegs skip = upperInnerCircle numSegs skip ++ lowerInnerCircle numSegs skip upperOutSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] upperOutSegment numSegs ring seg = [x,y,u, v,u,y] where - seg'=pi/(fromIntegral numSegs)+ seg'=pi/fromIntegral numSegs (a, b) = (fromIntegral seg * seg', fromIntegral (seg+1) * seg')- x = (fromIntegral ring * cos a, fromIntegral ring * sqrt(1-(cos a)*(cos a)))- y = (fromIntegral ring * cos b, fromIntegral ring * sqrt(1-(cos b)*(cos b)))- u = (fromIntegral (ring+1) * cos a, fromIntegral (ring+1) * sqrt(1-(cos a)*(cos a)))- v = (fromIntegral (ring+1) * cos b, fromIntegral (ring+1) * sqrt(1-(cos b)*(cos b)))+ x = (fromIntegral ring * cos a, fromIntegral ring * sqrt(1-cos a*cos a))+ y = (fromIntegral ring * cos b, fromIntegral ring * sqrt(1-cos b*cos b))+ u = (fromIntegral (ring+1) * cos a, fromIntegral (ring+1) * sqrt(1-cos a*cos a))+ v = (fromIntegral (ring+1) * cos b, fromIntegral (ring+1) * sqrt(1-cos b*cos b)) lowerOutSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] lowerOutSegment numSegs ring seg = map (\(x,y) -> (x,-y)) $ upperOutSegment numSegs ring seg outSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)]-outSegment numSegs ring seg = upperOutSegment numSegs ring seg ++ (lowerOutSegment numSegs ring seg)+outSegment numSegs ring seg = upperOutSegment numSegs ring seg ++ lowerOutSegment numSegs ring seg outerRing :: Int -> Int -> [(GLfloat, GLfloat)] outerRing numSegs ring =@@ -419,14 +423,15 @@ toTriples [] = [] toTriples (a:b:c:rest) = (a,b,c):toTriples rest +renderChip :: GLuint -> Int -> Int -> Foreign.C.Types.CFloat -> IO () renderChip tex numSegs numRings factor = let ips = innerCircle numSegs 0 ops = concat [outerRing numSegs i | i<-[1..numRings]]- height dir ps = + height dir = map (\(x,y) -> - let dist = sqrt(x*x+y*y)/(fromIntegral (numRings+1))- height' = sqrt(1.001-dist*dist)*factor*(fromIntegral (numRings+1))*0.2- in (dir,x*factor,y*factor,dir*height')) $ ps+ let dist = sqrt(x*x+y*y)/fromIntegral (numRings+1)+ height' = sqrt(1.001-dist*dist)*factor*fromIntegral (numRings+1)*0.2+ in (dir,x*factor,y*factor,dir*height')) ups = height 1 $ ips ++ ops lps = height (-1) $ ips ++ ops in do@@ -460,18 +465,19 @@ -- Half circle -- -------------------------------------------------------------------- +skipBothEnds :: [a] -> Int -> [a] skipBothEnds xs n = let xs' = drop n xs in reverse $ drop n (reverse xs') upperInnerCircle :: Int -> Int -> [(GLfloat, GLfloat)]-upperInnerCircle numSegs skip =- skipBothEnds ps skip+upperInnerCircle numSegs =+ skipBothEnds ps where - seg'=pi/(fromIntegral numSegs)+ seg'=pi/fromIntegral numSegs as = [(fromIntegral n * seg', fromIntegral (n+1) * seg') | n<-[0..numSegs-1]]- ps = concat [[(cos a, sqrt(1-(cos a)*(cos a)))- ,(cos b, sqrt(1-(cos b)*(cos b)))] + ps = concat [[(cos a, sqrt(1-cos a*cos a))+ ,(cos b, sqrt(1-cos b*cos b))] | (a,b)<-as ] lowerInnerCircle :: Int -> Int -> [(GLfloat, GLfloat)]@@ -487,14 +493,15 @@ data WhichCircle = FullCircle | UpperHalfCircle | LowerHalfCircle +circle :: WhichCircle -> Int -> Int -> CFloat -> IO () circle whichCircle numSegs skip factor =- let ips = case whichCircle of + let ips = case whichCircle of LowerHalfCircle -> lowerInnerCircle numSegs skip UpperHalfCircle -> upperInnerCircle numSegs skip- fullCircle -> lowerInnerCircle numSegs skip ++ upperInnerCircle numSegs skip- applyFactor dir ps = - map (\(x,y) -> (x*factor,y*factor,0)) $ ps- ups = applyFactor 1 $ ips + FullCircle -> lowerInnerCircle numSegs skip ++ upperInnerCircle numSegs skip+ applyFactor = + map (\(x,y) -> (x*factor,y*factor,0)) + ups = applyFactor ips in renderPrimitive Lines $ mapM_ pushLine (toTuples ups) toTuples :: [a] -> [(a,a)]@@ -502,13 +509,160 @@ toTuples (a:b:rest) = (a,b):toTuples rest -- Helpful OpenGL constants for rotation-xAxis = G.Vector3 1 0 0 :: G.Vector3 R -yAxis = G.Vector3 0 1 0 :: G.Vector3 R-zAxis = G.Vector3 0 0 1 :: G.Vector3 R+-- xAxis = G.Vector3 1 0 0 :: G.Vector3 R +-- yAxis = G.Vector3 0 1 0 :: G.Vector3 R+-- zAxis = G.Vector3 0 0 1 :: G.Vector3 R blinker :: IO Bool blinker = do t <- fmap utctDayTime getCurrentTime - let tFrac = t - fromIntegral (truncate t) - return $ tFrac < 0.5+ let tFrac = truncate $ 6 * (t - fromIntegral (truncate t::Int)) + return $ odd tFrac++data MenuEntry = MenuEntry {+ meId :: Int,+ meTrans :: MenuTransition,+ meText :: String,+ mePosx :: GLfloat,+ mePosy :: GLfloat,+ meEndx :: GLfloat,+ meEndy :: GLfloat+} deriving (Show)++menues :: [(MenuState, [MenuEntry])]+menues = [+ (MSMain, [MenuEntry 00 MTToFriendly "FRIENDLY" (-30) 10 0 5,+ MenuEntry 01 MTToTournament "TOURNAMENT" (-30) 0 0 (-5),+ MenuEntry 02 MTHelp "HELP" (-30) (-10) 0 (-15),+ MenuEntry 03 MTFinished "EXIT" (-30) (-20) 0 (-25)]), + (MSHelp, [MenuEntry 10 MTToMain "BACK" (-30) (-20) 0 (-20)]),+ (MSTournament, [MenuEntry 10 MTToMain "BACK" (-30) (-20) 0 (-20)]),+ (MSTerminated, [MenuEntry 20 MTFinished "" (-30) (-10) 0 (-15)])+ ] +++menuSelected (x, y) (mx, my) =+ x > 15 && x < 60 &&+ y > (55-my) && y < (60-my) +++whichMenuItem :: [MenuEntry] -> (GLfloat, GLfloat) -> Maybe MenuEntry+whichMenuItem mes (x,y) =+ find (\me -> menuSelected (x, y) (mePosx me, mePosy me)) mes+ +runMenu :: IORef (GLfloat, GLfloat) -> Maybe [RSEvent] -> MenuState -> IO (Bool, Maybe MenuTransition) +runMenu lastPos is mst = do+ xy <- readIORef lastPos+ let xyNew = getPosIfPossible xy is+ writeIORef lastPos xyNew++ clear [ ColorBuffer, DepthBuffer ]+ loadIdentity++ position (Light 0) $= Vertex4 100 (-100) 50 1 -- 1 0.4 0.8 1 ++ let Just menu = lookup mst menues + let mmi = whichMenuItem menu xyNew+ + let trans = if clicked is then meTrans <$> mmi else Nothing++ let go = trans == Just MTToFriendly + when (clicked is) $ print $ show trans++ renderMenu mst mmi++ return (go, trans) + +renderMenu mId mmi = do+ let Just mis = lookup mId menues++ color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat)++ renderFrame mId+ + forM_ mis $ \ mi -> + printIt (mePosx mi) (mePosy mi) 0.04 (meText mi)++ when (isJust mmi) $ + renderquad mmi++ flush+ swapBuffers++renderFrame MSMain =+ printIt (-30::GLfloat) (22::GLfloat) 0.04 "=== MAIN MENU ==="+renderFrame MSHelp = do+ printIt (-30::GLfloat) (22::GLfloat) 0.04 "=== HELP ==="+ forM_ ts $ \(x, y, t) -> printIt x y 0.01 t+ + where+ ts = [(-30, 15,"MOUSE:"),+ (-30, 13,"Move"),+ (-15, 13,"User controlled player follows mouse pointer"),+ (-30, 11,"Left button"),+ (-15, 11,"Select nearest player"),+ (-30, 09,"Wheel"),+ (-15, 09,"Zoom in / out"),+ (-30, 04,"KEYS:"),+ (-30, 02,"q/Q"),+ (-15, 02,"Move designated player (marked with !) to goal / to me"),+ (-30, 00,"w/W "),+ (-15, 00,"Move designated player to left / right"),+ (-30,-02,"e/E"),+ (-15,-02,"Move designated player forward / backward"),+ (-30,-04,"a/A"),+ (-15,-04,"Pass low / high (hold key for faster pass)"),+ (-30,-06,"s/S"),+ (-15,-06,"Kick low / high (hold key for faster kick)"),+ (-30,-08,"d/D"),+ (-15,-08,"Flip ball to designated player"),+ (-30,-10,"SPACE"),+ (-15,-10,"toggle ball from one side to other")] :: [(GLfloat, GLfloat, String)]+renderFrame MSTournament = do+ printIt (-30::GLfloat) (22::GLfloat) 0.04 "=== TOURNAMENT ==="+ printIt (-30::GLfloat) (00::GLfloat) 0.04 "<Nothing here yet>"+renderFrame _ = return ()+ +printIt x y sc t =+ preservingMatrix $ do+ translate $ G.Vector3 (x::GLfloat) (y::GLfloat) (-71::GLfloat)+ scale sc sc (sc::GLfloat)+ renderString Roman t+ + +renderquad mmi = do+ let vertex3f x y z = vertex $ Vertex3 x y (z :: GLfloat)+ c = Color4 1 0.5 10 0.5 :: Color4 R++ when (isJust mmi) $ + preservingMatrix $ do+ translate $ G.Vector3 (0::GLfloat) (0::GLfloat) (-71)+ let mi = fromJust mmi+ let (x,y) = (mePosx mi, mePosy mi) + (color c >>) . renderPrimitive Quads $ do+ vertex3f (-30) (y+4.5) 0+ vertex3f 20 (y+4.5) 0+ vertex3f 20 (y-0.5) 0+ vertex3f (-30) (y-0.5) 0++clicked Nothing = False+clicked (Just []) = False+clicked (Just (r:rs)) =+ r == RSMouseButtonDownLeft || clicked (Just rs)++getPosIfPossible :: (GLfloat, GLfloat) -> Maybe [RSEvent] -> (GLfloat, GLfloat) +getPosIfPossible xy Nothing = xy+getPosIfPossible xy (Just []) = xy+getPosIfPossible xy (Just (r:rs)) =+ case r of+ RSMouseMotion x y -> (realToFrac x, realToFrac y)+ _ -> getPosIfPossible xy (Just rs) + + +lll :: Maybe [a] -> Int+lll mxs = + case mxs of+ Nothing -> 0+ Just xs -> length xs+
Rules.hs view
@@ -62,12 +62,13 @@ rule_kick_off :: RuleFunction rule_kick_off _ facts vss = do- factKickOff facts []+ _ <- factKickOff facts [] att <- factAttacking facts [] FPTeam me <- factWhoAmI facts []- factEq facts [FPTeam me, att]+ _ <- factEq facts [FPTeam me, att] let x = if me == Home then 1 else (-1)- return $ [(vsObjId p, tm (TPTKickedOff, tspNull))| p <- teamPlayers Home vss ++ teamPlayers Away vss]+ return $ [(vsObjId p, tm (TPTKickedOff, tspNull))| p <- teamPlayers Home vss + ++ teamPlayers Away vss] -- , vsObjId p /= ballCarrier] ++ [(vsObjId game, GameMessage (GTRunGame, (snd . vsGameState) game))] ++ [(ballCarrier, pm (PPTLoseMe, BSPShoot (x *^ (vector3 (-19) (-3) 0)))) | isJust bc]@@ -205,7 +206,6 @@ Either (ParseErrorId, ParseErrorMsg) (Statement, [(ParamId, ParamName)]) gatherClauses [c] acc = do--- (Just (paramId, paramName), clause, params) <- parseClause c acc (maybeVar, clause, params) <- parseClause c acc return ([(fst `fmap` maybeVar, clause, params)], pushIfJust maybeVar acc) gatherClauses (c:cs) acc = do