{-# 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 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))]