{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Rules (
runRules
,runner
,parseRule
,basicRules
,Rule(..)
,Priority(..)
,RuleId(..)
,ParseErrorId
,ParseErrorMsg)
where
import FRP.Yampa.Geometry
import Data.List
import Data.Function (on)
import Data.Maybe
import Debug.Trace
import Object
import BasicTypes
import Message
import AL
import Helper
-- *************************************************************************
--
-- Framework for defining rules
--
-- ************************************************************************
concatMaybe :: Maybe [a] -> [a]
concatMaybe Nothing = []
concatMaybe (Just xs) = xs
uncollect :: [(a, [b])] -> [(a, b)]
uncollect = concatMap (\(a, bs) -> zip (repeat a) bs)
runRules' :: [ObjId] -> Facts -> [VisibleState] -> RuleBase -> [(ObjId, [(Priority, MessageBody)])]
runRules' teamMates' facts vss =
collect . map (\(p,(o,m)) -> (o, (p,m))) . uncollect
. map (\rule -> (opPriority rule, concatMaybe $ opRule rule teamMates' facts vss))
-- collect all the messages for each player that have the lowest prio
runRules :: [ObjId] -> Facts -> [VisibleState] -> RuleBase -> [(ObjId, MessageBody)]
runRules teamMates' facts vss =
concatMap (\(o, pms) ->
let pmsSort = sortBy (compare `on` fst) pms
lowest = fst $ head pmsSort
relevantMsgs = map snd $ takeWhile ((lowest ==) . fst) pmsSort
in zip (repeat o) relevantMsgs)
. runRules' teamMates' facts vss
-- *************************************************************************
--
-- Basic rules for all teams, not changeable by user
--
-- ************************************************************************
rule_kick_off :: RuleFunction
rule_kick_off _ facts vss = do
factKickOff facts []
att <- factAttacking facts []
FPTeam me <- factWhoAmI facts []
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]
-- , vsObjId p /= ballCarrier]
++ [(vsObjId game, GameMessage (GTRunGame, (snd . vsGameState) game))]
++ [(ballCarrier, pm (PPTLoseMe, BSPShoot (x *^ (vector3 (-19) (-3) 0)))) | isJust bc]
where game = fetchGameVS vss
bc@(Just ballCarrier) = playerWithBall vss
-- Weitere Verbesserungsmöglichkeiten:
-- a. checken, dass nicht der einwerfende Spieler der erste ist, der den Ball wieder
-- aufnimmt
-- b. nicht sofort werfen, sondern eine halbe Sekunde oder so warten (vielleicht FactThrowinIn
-- erst dann einstellen, wenn eine Mindestzeit rum ist?) Sonst sieht es doof aus
-- c. der einwerfende Spieler soll in Richtung des Spots schauen, zu dem er werden will;
-- vielleicht wäre ein TS "AimingForThrowIn" gut
-- d. solange zielen (AimingForThrowIn), bis Güte des Spots über einen Schwellenwert
-- liegt ODER die Zeit seit Start der Einwurfaktion überschritten ist
rule_throw_in :: RuleFunction
rule_throw_in _ facts _ = do
FPPlayerId p <- factThrowingIn facts []
FPFromTo curr dest <- factBestPosition facts []
return $ (p, pm (PPTLoseMe,
#if DEBUG_MODE
trace ("RULE=" ++ show (BSPShoot (towards curr dest)) ++ show "; " ++ show dest)
#endif
BSPShoot (towards curr dest))) :
(1, GameMessage (GTBallInPlay, GPTeamPosition Home (-1) [] (Point2 0 0) 0 False InPlay)) :
[(p, tm (TPTReposition, tspNull))]
rule_stop_idling :: RuleFunction
rule_stop_idling _ facts _ = do
FPPlayers ps <- factIdling facts []
return $ map (\p -> (p, tm (TPTHoldPosition, tspNull))) ps
rule_punt :: RuleFunction
rule_punt _ facts _ = do
FPPlayerVector p v <- factPunt facts []
return $ [(p, pm (PPTLoseMe, BSPShoot v))]
-- was passiert beim Anstoß:
-- * 2 Spieler stehen am Anstoßpunkt
-- * ein Spieler hat den Ball
-- * auf Knopfdruck (bei eigenem Spieler) oder auf AI-Befehl geht der Ball von einem
-- auf den anderen Spieler über
-- * vorher kann sich keiner irgendwie drehen oder sonstwas
-- * Frage: Laufen dann alle in Position? Oder wird "neu aufgestellt?" Letzteres ist
-- wohl deutlich einfacher... Dann braucht es auch das ganze Status-Gehampel nicht...
-- * Frage: Ist man vor dem eigentlich Anstoß innerhalb der reactimate-Schleife oder
-- außerhalb?
-- PRO außerhalb: Ganz wenig Rumgehampel mit Status und Knorz (sonst muss mindestens mal
-- die handgesteuerten Spieler in einen Status versetzen, in dem er nicht
-- gesteuert werden kann AUSSER wenn er selber den Anstoß macht, dann ist der
-- einzige Steuerimpuls aber der Anstoß an sich)
-- CON außerhalb: Rendering und Keyboard-Knorzung muss noch mal gebastelt oder
-- mindestens mal angestoßen werden...
-- klingt so, als sollte man es erst mal mit innerhalb probieren...
basicRules :: [Rule]
basicRules = [Rule (RuleId (-1000)) "throw in" (Priority 1) rule_throw_in
,Rule (RuleId (-1001)) "kickoff" (Priority 0) rule_kick_off
,Rule (RuleId (-1002)) "punt" (Priority 4) rule_punt
,Rule (RuleId (-1003)) "stop idling" (Priority 10) rule_stop_idling
]
-- just some dummy stuff to later integrate more easily...
type Clause = Facts -> [FactParam] -> Maybe FactParam
type MsgMaker = [VisibleState] -> [FactParam] -> [Message]
type ParamId = Int
type Statement = [(Maybe ParamId, Clause, [RuleParam])]
data RuleParam = PId ParamId | PConst FactParam deriving (Show)
-- wrapper to run a parsed rule (set of clauses and message function)
runner :: Statement -> (MsgMaker, [RuleParam]) -> RuleFunction
runner clauses msgMaker myTeamMates facts vss =
run myTeamMates vss facts clauses msgMaker emptyAL
-- first runs a set of clauses and collects facts, then runs messaging function
-- lets only those messages through that are intended for own team (no cheating!)
run :: [ObjId] -> [VisibleState] -> Facts -> Statement ->
(MsgMaker, [RuleParam]) -> AL ParamId FactParam -> Maybe [Message]
run myTeamMates vss _ [] (msgMaker, params) paramFacts =
return $ filterTeam myTeamMates $ msgMaker vss $ fetchParams paramFacts params
run myTeamMates vss facts ((pId, clause, clauseParams):rs) msg paramFactsSoFar = do
fp <- clause facts $ fetchParams paramFactsSoFar clauseParams
run myTeamMates vss facts rs msg $ maybeInsertAL pId fp paramFactsSoFar
maybeInsertAL :: Maybe k -> a -> AL k a -> AL k a
maybeInsertAL Nothing _ paramFactsSoFar = paramFactsSoFar
maybeInsertAL (Just pId) fp paramFactsSoFar = insertAL pId fp paramFactsSoFar
filterTeam :: Eq a => [a] -> [(a, t)] -> [(a, t)]
filterTeam teamMates' =
filter (\(oid,_) -> elem oid teamMates')
fetchParams :: AL ParamId FactParam -> [RuleParam] -> [FactParam]
fetchParams _ [] = []
fetchParams pvs (p:ps) =
case p of
PId p' -> pvs ! p' : fetchParams pvs ps
PConst c -> c : fetchParams pvs ps
type ParamName = String
type RulePriority = Int
type ParseErrorId = Int
type ParseErrorMsg = String
parseRule :: [String] ->
Either (ParseErrorId, ParseErrorMsg)
(RuleName
,RulePriority
,Statement
,(MsgMaker, [RuleParam]))
parseRule ls = do
-- let ls = lines ruleString
let ln = length ls
checkRuleStructure ls
(ruleName, rulePrio) <- parseRuleHead (ls !! 0)
(clauses, params) <- gatherClauses (take (ln - 2) (tail ls)) []
(msg, msgParams) <- parseMsg (last ls) params
return (ruleName, rulePrio, clauses, (msg, msgParams))
checkRuleStructure :: Num t => [a] -> Either (t, String) ()
checkRuleStructure ls =
if length ls < 3 then
Left $ (10, "rule must consist of rule head, at least one clause and message")
else
Right ()
gatherClauses :: [String] -> [(ParamId, ParamName)] ->
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
(maybeVar, clause, params) <- parseClause c acc
(restClauses, newAcc) <- gatherClauses cs (pushIfJust maybeVar acc)
return ((fst `fmap` maybeVar, clause, params) : restClauses, newAcc)
pushIfJust :: Maybe a -> [a] -> [a]
pushIfJust Nothing xs = xs
pushIfJust (Just x) xs = x : xs
parseRuleHead :: String -> Either (ParseErrorId, ParseErrorMsg)
(RuleName, RulePriority)
parseRuleHead rh =
let ws = words rh
in
if null ws || head ws /= "rule" || length ws /= 4 ||
ws !! 2 /= "priority" ||
null (reads (ws !! 3) :: [(Int, String)])
then Left (1, "rule head must be of form 'rule rulename priority xxx'")
else Right (ws !! 1, fst $ head (reads (ws !! 3) :: [(Int, String)]))
parseClause :: String -> [(ParamId, ParamName)] ->
Either (ParseErrorId, ParseErrorMsg)
(Maybe (ParamId, ParamName), Clause, [RuleParam])
parseClause clause params = do
let tokens = words clause
hasVar <- checkClauseStructure tokens
maybeVar <- checkVariable params (tokens !! 0) hasVar
fact <- checkFact (tokens !! (if hasVar then 2 else 1))
ps <- parseParams params (drop (if hasVar then 3 else 2) tokens)
return (maybeVar, fact, ps)
checkClauseStructure :: Num t => [String] -> Either (t, String) Bool
checkClauseStructure tokens =
if length tokens >= 3 && tokens !! 1 == "is"
then Right True
else if length tokens >= 2 && tokens !! 0 == "check"
then Right False
else Left (2, "clause must be of form 'var is fact params' or 'check fact params': " ++
concat (zipWith (++) tokens (repeat " ")))
checkVariable :: [(ParamId, ParamName)] -> String -> Bool ->
Either (ParseErrorId, ParseErrorMsg) (Maybe (ParamId, ParamName))
checkVariable params token True =
if elem token (map snd params)
then Left (2, "variable name already used: " ++ token)
else Right $ Just (newParamId params, token)
checkVariable _ _ False = Right Nothing
newParamId :: (Num a, Ord a) => [(a, b)] -> a
newParamId params =
if null params then 1
else 1 + (maximum $ map fst params)
parseParams :: Num t => [(ParamId, String)] -> [String] -> Either (t, String) [RuleParam]
parseParams _ [] = Right []
parseParams params ("scalar":tokens) = do
(scalar, rest) <- checkParamScalar tokens
result <- parseParams params rest
return $ (PConst (FPScalar scalar)) : result
parseParams params ("spot":tokens) = do
(x, y, rest) <- checkParamSpot tokens
result <- parseParams params rest
return $ (PConst (FPSpot $ Spot x y)) : result
parseParams params (paramName:tokens) = do
pid <- checkParamName params paramName
result <- parseParams params tokens
return $ (PId pid) : result
checkParamScalar :: Num t => [String] -> Either (t, String) (Double, [String])
checkParamScalar tokens =
if null tokens then Left (4, "unexpected end of clause after scalar keyword")
else if null (reads (head tokens) :: [(Double, String)])
then Left (5, "no number after scalar: " ++ head tokens)
else Right (fst $ head (reads (head tokens) :: [(Double, String)]), tail tokens)
checkParamSpot :: Num t => [String] -> Either (t, String) (Double, Double, [String])
checkParamSpot tokens =
if length tokens < 2 then Left (4, "unexpected end of clause after spot keyword")
else if null (reads (tokens !! 0) :: [(Double, String)]) ||
null (reads (tokens !! 1) :: [(Double, String)])
then Left (5, "no number after spot: " ++ (tokens !! 0) ++ ", " ++ (tokens !! 1))
else Right (fst $ head (reads (tokens !! 0) :: [(Double, String)]),
fst $ head (reads (tokens !! 1) :: [(Double, String)]),
drop 2 tokens)
checkParamName :: Num t => [(b, String)] -> String -> Either (t, String) b
checkParamName params paramName =
case find ((paramName ==) . snd) params of
Just (pid, _) -> Right pid
Nothing -> Left (6, "parameter not known: " ++ paramName)
parseMsg :: String -> [(ParamId, ParamName)] ->
Either (ParseErrorId, ParseErrorMsg)
(MsgMaker, [RuleParam])
parseMsg input params = do
let tokens = words input
checkMsgStructure tokens
msg <- checkMsg (tokens !! 1)
ps <- parseParams params (drop 2 tokens)
return (msg, ps)
checkMsgStructure :: Num t => [String] -> Either (t, String) ()
checkMsgStructure tokens =
if null tokens || length tokens < 2 ||
tokens !! 0 /= "send"
then Left (8, "message must be of form 'send msg params': " ++
concat (zipWith (++) tokens (repeat " ")))
else Right ()
checkMsg :: Num t => String -> Either (t, String) MsgMaker
checkMsg "msgKick" = Right msgKick
checkMsg "msgPassTo" = Right msgPassTo
checkMsg "msgIntercept" = Right msgIntercept
checkMsg x = Left (3, "no valid message: " ++ x)
checkFact :: String -> Either a (Facts -> FactFunction)
checkFact "factCanIntercept" = Right factCanIntercept
checkFact "factIsCloseTo" = Right factIsCloseTo
checkFact "factInLineWith" = Right factInLineWith
checkFact "factBestFreePlayer" = Right factBestFreePlayer
checkFact "factNearestAIPlayer" = Right factNearestAIPlayer
checkFact "factBallIsFree" = Right factBallIsFree
checkFact "factAttacking" = Right factAttacking
checkFact "factThrowingIn" = Right factThrowingIn
checkFact "factBestPosition" = Right factBestPosition
checkFact "factKickOff" = Right factKickOff
checkFact "factBallCarrier" = Right factBallCarrier
checkFact "factPlayerSpot" = Right factPlayerSpot
checkFact "factSpotValue" = Right factSpotValue
checkFact "factBestShootingVector" = Right factBestShootingVector
checkFact "factBestPassingVector" = Right factBestPassingVector
checkFact "factPunt" = Right factPunt
checkFact "factIdling" = Right factIdling
checkFact "factWhoAmI" = Right factWhoAmI
checkFact "factEq" = Right factEq
checkFact "factGT" = Right factGT
checkFact "factGetVector" = Right factGetVector
msgKick :: MsgMaker
msgKick _ [FPPlayerId ballCarrier, FPVector goalVector] =
[(ballCarrier, tm (TPTKickTowards,
(TacticalStateParam Nothing (Just goalVector)
False Nothing Nothing Nothing Nothing)))]
msgPassTo :: MsgMaker
msgPassTo _ [FPPlayerId ballCarrier, FPPlayerId receiver] =
[(ballCarrier, tm (TPTKickTowards,
(TacticalStateParam Nothing Nothing False
(Just receiver) Nothing (Just RTLow) Nothing)))]
msgIntercept :: MsgMaker
msgIntercept _ [FPPlayerId np, FPSpot p1] =
[(np, tm (TPTIntercept,
TacticalStateParam (Just $ spotToPoint p1) Nothing False Nothing Nothing Nothing Nothing))]