{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.Game.Scenario.Objective where

import Control.Applicative ((<|>))
import Control.Lens hiding (from, (<.>))
import Data.Aeson
import Data.Set qualified as Set
import Data.Text (Text)
import GHC.Generics (Generic)
import Servant.Docs (ToSample)
import Servant.Docs qualified as SD
import Swarm.Game.Achievement.Definitions
import Swarm.Game.Scenario.Objective.Logic as L
import Swarm.Language.Pipeline (ProcessedTerm)
import Swarm.Language.Syntax (Syntax)
import Swarm.Language.Text.Markdown qualified as Markdown
import Swarm.Util.Lens (makeLensesNoSigs)

------------------------------------------------------------
-- Scenario objectives
------------------------------------------------------------

data PrerequisiteConfig = PrerequisiteConfig
  { PrerequisiteConfig -> Bool
previewable :: Bool
  -- ^ Typically, only the currently "active" objectives are
  -- displayed to the user in the Goals dialog. An objective
  -- is "active" if all of its prerequisites are met.
  --
  -- However, some objectives may be "high-level", in that they may
  -- explain the broader intention behind potentially multiple
  -- prerequisites.
  --
  -- Set this option to 'True' to display this goal in the "upcoming" section even
  -- if the objective has currently unmet prerequisites.
  , PrerequisiteConfig -> Prerequisite Text
logic :: Prerequisite ObjectiveLabel
  -- ^ Boolean expression of dependencies upon other objectives. Variables in this expression
  -- are the "id"s of other objectives, and become "true" if the corresponding objective is completed.
  -- The "condition" of the objective at hand shall not be evaluated until its
  -- prerequisite expression evaluates as 'True'.
  --
  -- Note that the achievement of these objective dependencies is
  -- persistent; once achieved, they still count even if their "condition"
  -- might not still hold. The condition is never re-evaluated once true.
  }
  deriving (PrerequisiteConfig -> PrerequisiteConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrerequisiteConfig -> PrerequisiteConfig -> Bool
$c/= :: PrerequisiteConfig -> PrerequisiteConfig -> Bool
== :: PrerequisiteConfig -> PrerequisiteConfig -> Bool
$c== :: PrerequisiteConfig -> PrerequisiteConfig -> Bool
Eq, Int -> PrerequisiteConfig -> ShowS
[PrerequisiteConfig] -> ShowS
PrerequisiteConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrerequisiteConfig] -> ShowS
$cshowList :: [PrerequisiteConfig] -> ShowS
show :: PrerequisiteConfig -> String
$cshow :: PrerequisiteConfig -> String
showsPrec :: Int -> PrerequisiteConfig -> ShowS
$cshowsPrec :: Int -> PrerequisiteConfig -> ShowS
Show, forall x. Rep PrerequisiteConfig x -> PrerequisiteConfig
forall x. PrerequisiteConfig -> Rep PrerequisiteConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PrerequisiteConfig x -> PrerequisiteConfig
$cfrom :: forall x. PrerequisiteConfig -> Rep PrerequisiteConfig x
Generic, [PrerequisiteConfig] -> Encoding
[PrerequisiteConfig] -> Value
PrerequisiteConfig -> Encoding
PrerequisiteConfig -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PrerequisiteConfig] -> Encoding
$ctoEncodingList :: [PrerequisiteConfig] -> Encoding
toJSONList :: [PrerequisiteConfig] -> Value
$ctoJSONList :: [PrerequisiteConfig] -> Value
toEncoding :: PrerequisiteConfig -> Encoding
$ctoEncoding :: PrerequisiteConfig -> Encoding
toJSON :: PrerequisiteConfig -> Value
$ctoJSON :: PrerequisiteConfig -> Value
ToJSON)

instance FromJSON PrerequisiteConfig where
  -- Parsing JSON/YAML 'PrerequisiteConfig' has a shorthand option
  -- in which the boolean expression can be written directly,
  -- bypassing the "logic" key.
  -- Furthermore, an "Id" in a boolean expressions can be written
  -- as a bare string without needing the "id" key.
  parseJSON :: Value -> Parser PrerequisiteConfig
parseJSON Value
val = Value -> Parser PrerequisiteConfig
preLogic Value
val forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser PrerequisiteConfig
preObject Value
val
   where
    preObject :: Value -> Parser PrerequisiteConfig
preObject = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"prerequisite" forall a b. (a -> b) -> a -> b
$ \Object
v ->
      Bool -> Prerequisite Text -> PrerequisiteConfig
PrerequisiteConfig
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"previewable" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"logic"
    preLogic :: Value -> Parser PrerequisiteConfig
preLogic = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Prerequisite Text -> PrerequisiteConfig
PrerequisiteConfig Bool
False) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON

-- | An objective is a condition to be achieved by a player in a
--   scenario.
data Objective = Objective
  { Objective -> Document Syntax
_objectiveGoal :: Markdown.Document Syntax
  , Objective -> Maybe Text
_objectiveTeaser :: Maybe Text
  , Objective -> ProcessedTerm
_objectiveCondition :: ProcessedTerm
  , Objective -> Maybe Text
_objectiveId :: Maybe ObjectiveLabel
  , Objective -> Bool
_objectiveOptional :: Bool
  , Objective -> Maybe PrerequisiteConfig
_objectivePrerequisite :: Maybe PrerequisiteConfig
  , Objective -> Bool
_objectiveHidden :: Bool
  , Objective -> Maybe AchievementInfo
_objectiveAchievement :: Maybe AchievementInfo
  }
  deriving (Objective -> Objective -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Objective -> Objective -> Bool
$c/= :: Objective -> Objective -> Bool
== :: Objective -> Objective -> Bool
$c== :: Objective -> Objective -> Bool
Eq, Int -> Objective -> ShowS
[Objective] -> ShowS
Objective -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Objective] -> ShowS
$cshowList :: [Objective] -> ShowS
show :: Objective -> String
$cshow :: Objective -> String
showsPrec :: Int -> Objective -> ShowS
$cshowsPrec :: Int -> Objective -> ShowS
Show, forall x. Rep Objective x -> Objective
forall x. Objective -> Rep Objective x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Objective x -> Objective
$cfrom :: forall x. Objective -> Rep Objective x
Generic, [Objective] -> Encoding
[Objective] -> Value
Objective -> Encoding
Objective -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Objective] -> Encoding
$ctoEncodingList :: [Objective] -> Encoding
toJSONList :: [Objective] -> Value
$ctoJSONList :: [Objective] -> Value
toEncoding :: Objective -> Encoding
$ctoEncoding :: Objective -> Encoding
toJSON :: Objective -> Value
$ctoJSON :: Objective -> Value
ToJSON)

makeLensesNoSigs ''Objective

instance ToSample Objective where
  toSamples :: Proxy Objective -> [(Text, Objective)]
toSamples Proxy Objective
_ = forall a. [(Text, a)]
SD.noSamples

-- | An explanation of the goal of the objective, shown to the player
--   during play.  It is represented as a list of paragraphs.
objectiveGoal :: Lens' Objective (Markdown.Document Syntax)

-- | A very short (3-5 words) description of the goal for
-- displaying on the left side of the Objectives modal.
objectiveTeaser :: Lens' Objective (Maybe Text)

-- | A winning condition for the objective, expressed as a
--   program of type @cmd bool@.  By default, this program will be
--   run to completion every tick (the usual limits on the number
--   of CESK steps per tick do not apply).
objectiveCondition :: Lens' Objective ProcessedTerm

-- | Optional name by which this objective may be referenced
-- as a prerequisite for other objectives.
objectiveId :: Lens' Objective (Maybe Text)

-- | Indicates whether the objective is not required in order
-- to "win" the scenario. Useful for (potentially hidden) achievements.
-- If the field is not supplied, it defaults to False (i.e. the
-- objective is mandatory to "win").
objectiveOptional :: Lens' Objective Bool

-- | Dependencies upon other objectives
objectivePrerequisite :: Lens' Objective (Maybe PrerequisiteConfig)

-- | Whether the goal is displayed in the UI before completion.
-- The goal will always be revealed after it is completed.
--
-- This attribute often goes along with an Achievement.
objectiveHidden :: Lens' Objective Bool

-- | An optional achievement that is to be registered globally
-- when this objective is completed.
objectiveAchievement :: Lens' Objective (Maybe AchievementInfo)

instance FromJSON Objective where
  parseJSON :: Value -> Parser Objective
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"objective" forall a b. (a -> b) -> a -> b
$ \Object
v ->
    Document Syntax
-> Maybe Text
-> ProcessedTerm
-> Maybe Text
-> Bool
-> Maybe PrerequisiteConfig
-> Bool
-> Maybe AchievementInfo
-> Objective
Objective
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"goal" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Monoid a => a
mempty)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"teaser")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"condition")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"optional" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"prerequisite")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"hidden" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"achievement")

data CompletionBuckets = CompletionBuckets
  { CompletionBuckets -> [Objective]
incomplete :: [Objective]
  , CompletionBuckets -> [Objective]
completed :: [Objective]
  , CompletionBuckets -> [Objective]
unwinnable :: [Objective]
  }
  deriving (Int -> CompletionBuckets -> ShowS
[CompletionBuckets] -> ShowS
CompletionBuckets -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompletionBuckets] -> ShowS
$cshowList :: [CompletionBuckets] -> ShowS
show :: CompletionBuckets -> String
$cshow :: CompletionBuckets -> String
showsPrec :: Int -> CompletionBuckets -> ShowS
$cshowsPrec :: Int -> CompletionBuckets -> ShowS
Show, forall x. Rep CompletionBuckets x -> CompletionBuckets
forall x. CompletionBuckets -> Rep CompletionBuckets x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CompletionBuckets x -> CompletionBuckets
$cfrom :: forall x. CompletionBuckets -> Rep CompletionBuckets x
Generic, Value -> Parser [CompletionBuckets]
Value -> Parser CompletionBuckets
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CompletionBuckets]
$cparseJSONList :: Value -> Parser [CompletionBuckets]
parseJSON :: Value -> Parser CompletionBuckets
$cparseJSON :: Value -> Parser CompletionBuckets
FromJSON, [CompletionBuckets] -> Encoding
[CompletionBuckets] -> Value
CompletionBuckets -> Encoding
CompletionBuckets -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CompletionBuckets] -> Encoding
$ctoEncodingList :: [CompletionBuckets] -> Encoding
toJSONList :: [CompletionBuckets] -> Value
$ctoJSONList :: [CompletionBuckets] -> Value
toEncoding :: CompletionBuckets -> Encoding
$ctoEncoding :: CompletionBuckets -> Encoding
toJSON :: CompletionBuckets -> Value
$ctoJSON :: CompletionBuckets -> Value
ToJSON)

-- | TODO: #1044 Could also add an "ObjectiveFailed" constructor...
newtype Announcement
  = ObjectiveCompleted Objective
  deriving (Int -> Announcement -> ShowS
[Announcement] -> ShowS
Announcement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Announcement] -> ShowS
$cshowList :: [Announcement] -> ShowS
show :: Announcement -> String
$cshow :: Announcement -> String
showsPrec :: Int -> Announcement -> ShowS
$cshowsPrec :: Int -> Announcement -> ShowS
Show, forall x. Rep Announcement x -> Announcement
forall x. Announcement -> Rep Announcement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Announcement x -> Announcement
$cfrom :: forall x. Announcement -> Rep Announcement x
Generic, [Announcement] -> Encoding
[Announcement] -> Value
Announcement -> Encoding
Announcement -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Announcement] -> Encoding
$ctoEncodingList :: [Announcement] -> Encoding
toJSONList :: [Announcement] -> Value
$ctoJSONList :: [Announcement] -> Value
toEncoding :: Announcement -> Encoding
$ctoEncoding :: Announcement -> Encoding
toJSON :: Announcement -> Value
$ctoJSON :: Announcement -> Value
ToJSON)

data ObjectiveCompletion = ObjectiveCompletion
  { ObjectiveCompletion -> CompletionBuckets
completionBuckets :: CompletionBuckets
  -- ^ This is the authoritative "completion status"
  -- for all objectives.
  -- Note that there is a separate Set to store the
  -- completion status of prerequisite objectives, which
  -- must be carefully kept in sync with this.
  -- Those prerequisite objectives are required to have
  -- labels, but other objectives are not.
  -- Therefore only prerequisites exist in the completion
  -- map keyed by label.
  , ObjectiveCompletion -> Set Text
completedIDs :: Set.Set ObjectiveLabel
  }
  deriving (Int -> ObjectiveCompletion -> ShowS
[ObjectiveCompletion] -> ShowS
ObjectiveCompletion -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectiveCompletion] -> ShowS
$cshowList :: [ObjectiveCompletion] -> ShowS
show :: ObjectiveCompletion -> String
$cshow :: ObjectiveCompletion -> String
showsPrec :: Int -> ObjectiveCompletion -> ShowS
$cshowsPrec :: Int -> ObjectiveCompletion -> ShowS
Show, forall x. Rep ObjectiveCompletion x -> ObjectiveCompletion
forall x. ObjectiveCompletion -> Rep ObjectiveCompletion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ObjectiveCompletion x -> ObjectiveCompletion
$cfrom :: forall x. ObjectiveCompletion -> Rep ObjectiveCompletion x
Generic, Value -> Parser [ObjectiveCompletion]
Value -> Parser ObjectiveCompletion
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ObjectiveCompletion]
$cparseJSONList :: Value -> Parser [ObjectiveCompletion]
parseJSON :: Value -> Parser ObjectiveCompletion
$cparseJSON :: Value -> Parser ObjectiveCompletion
FromJSON, [ObjectiveCompletion] -> Encoding
[ObjectiveCompletion] -> Value
ObjectiveCompletion -> Encoding
ObjectiveCompletion -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ObjectiveCompletion] -> Encoding
$ctoEncodingList :: [ObjectiveCompletion] -> Encoding
toJSONList :: [ObjectiveCompletion] -> Value
$ctoJSONList :: [ObjectiveCompletion] -> Value
toEncoding :: ObjectiveCompletion -> Encoding
$ctoEncoding :: ObjectiveCompletion -> Encoding
toJSON :: ObjectiveCompletion -> Value
$ctoJSON :: ObjectiveCompletion -> Value
ToJSON)

-- | Concatenates all incomplete and completed objectives.
listAllObjectives :: CompletionBuckets -> [Objective]
listAllObjectives :: CompletionBuckets -> [Objective]
listAllObjectives (CompletionBuckets [Objective]
x [Objective]
y [Objective]
z) = [Objective]
x forall a. Semigroup a => a -> a -> a
<> [Objective]
y forall a. Semigroup a => a -> a -> a
<> [Objective]
z

addCompleted :: Objective -> ObjectiveCompletion -> ObjectiveCompletion
addCompleted :: Objective -> ObjectiveCompletion -> ObjectiveCompletion
addCompleted Objective
obj (ObjectiveCompletion CompletionBuckets
buckets Set Text
cmplIds) =
  CompletionBuckets -> Set Text -> ObjectiveCompletion
ObjectiveCompletion CompletionBuckets
newBuckets Set Text
newCmplById
 where
  newBuckets :: CompletionBuckets
newBuckets =
    CompletionBuckets
buckets
      { completed :: [Objective]
completed = Objective
obj forall a. a -> [a] -> [a]
: CompletionBuckets -> [Objective]
completed CompletionBuckets
buckets
      }
  newCmplById :: Set Text
newCmplById = case Objective -> Maybe Text
_objectiveId Objective
obj of
    Maybe Text
Nothing -> Set Text
cmplIds
    Just Text
lbl -> forall a. Ord a => a -> Set a -> Set a
Set.insert Text
lbl Set Text
cmplIds

addUnwinnable :: Objective -> ObjectiveCompletion -> ObjectiveCompletion
addUnwinnable :: Objective -> ObjectiveCompletion -> ObjectiveCompletion
addUnwinnable Objective
obj (ObjectiveCompletion CompletionBuckets
buckets Set Text
cmplIds) =
  CompletionBuckets -> Set Text -> ObjectiveCompletion
ObjectiveCompletion CompletionBuckets
newBuckets Set Text
cmplIds
 where
  newBuckets :: CompletionBuckets
newBuckets =
    CompletionBuckets
buckets
      { unwinnable :: [Objective]
unwinnable = Objective
obj forall a. a -> [a] -> [a]
: CompletionBuckets -> [Objective]
unwinnable CompletionBuckets
buckets
      }

setIncomplete ::
  ([Objective] -> [Objective]) ->
  ObjectiveCompletion ->
  ObjectiveCompletion
setIncomplete :: ([Objective] -> [Objective])
-> ObjectiveCompletion -> ObjectiveCompletion
setIncomplete [Objective] -> [Objective]
f (ObjectiveCompletion CompletionBuckets
buckets Set Text
cmplIds) =
  CompletionBuckets -> Set Text -> ObjectiveCompletion
ObjectiveCompletion CompletionBuckets
newBuckets Set Text
cmplIds
 where
  newBuckets :: CompletionBuckets
newBuckets =
    CompletionBuckets
buckets
      { incomplete :: [Objective]
incomplete = [Objective] -> [Objective]
f forall a b. (a -> b) -> a -> b
$ CompletionBuckets -> [Objective]
incomplete CompletionBuckets
buckets
      }

addIncomplete :: Objective -> ObjectiveCompletion -> ObjectiveCompletion
addIncomplete :: Objective -> ObjectiveCompletion -> ObjectiveCompletion
addIncomplete Objective
obj = ([Objective] -> [Objective])
-> ObjectiveCompletion -> ObjectiveCompletion
setIncomplete (Objective
obj forall a. a -> [a] -> [a]
:)

-- | Returns the "ObjectiveCompletion" with the "incomplete" goals
-- extracted to a separate tuple member.
-- This is intended as input to a "fold".
extractIncomplete :: ObjectiveCompletion -> (ObjectiveCompletion, [Objective])
extractIncomplete :: ObjectiveCompletion -> (ObjectiveCompletion, [Objective])
extractIncomplete ObjectiveCompletion
oc =
  (ObjectiveCompletion
withoutIncomplete, [Objective]
incompleteGoals)
 where
  incompleteGoals :: [Objective]
incompleteGoals = CompletionBuckets -> [Objective]
incomplete forall a b. (a -> b) -> a -> b
$ ObjectiveCompletion -> CompletionBuckets
completionBuckets ObjectiveCompletion
oc
  withoutIncomplete :: ObjectiveCompletion
withoutIncomplete = ([Objective] -> [Objective])
-> ObjectiveCompletion -> ObjectiveCompletion
setIncomplete (forall a b. a -> b -> a
const []) ObjectiveCompletion
oc