{-# LANGUAGE TemplateHaskell #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Data types and functions applicable across different
-- scoring methods.
module Swarm.Game.Scenario.Scoring.GenericMetrics (
  Progress (..),
  Metric (Metric),
  metricProgress,
  metricData,
  chooseBetter,
) where

import Control.Applicative ((<|>))
import Control.Lens
import Data.Aeson
import Data.List.Extra (dropPrefix)
import Data.Ord (Down (Down))
import GHC.Generics (Generic)
import Swarm.Util (maxOn)
import Swarm.Util.JSON (optionsMinimize, optionsUntagged)
import Swarm.Util.Lens (makeLensesNoSigs)

-- | This is a subset of the "ScenarioStatus" type
-- that excludes the "NotStarted" case.
data Progress
  = Attempted
  | Completed
  deriving (Progress -> Progress -> Bool
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
/= :: Progress -> Progress -> Bool
Eq, Eq Progress
Eq Progress =>
(Progress -> Progress -> Ordering)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Progress)
-> (Progress -> Progress -> Progress)
-> Ord Progress
Progress -> Progress -> Bool
Progress -> Progress -> Ordering
Progress -> Progress -> Progress
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Progress -> Progress -> Ordering
compare :: Progress -> Progress -> Ordering
$c< :: Progress -> Progress -> Bool
< :: Progress -> Progress -> Bool
$c<= :: Progress -> Progress -> Bool
<= :: Progress -> Progress -> Bool
$c> :: Progress -> Progress -> Bool
> :: Progress -> Progress -> Bool
$c>= :: Progress -> Progress -> Bool
>= :: Progress -> Progress -> Bool
$cmax :: Progress -> Progress -> Progress
max :: Progress -> Progress -> Progress
$cmin :: Progress -> Progress -> Progress
min :: Progress -> Progress -> Progress
Ord, Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> String
(Int -> Progress -> ShowS)
-> (Progress -> String) -> ([Progress] -> ShowS) -> Show Progress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Progress -> ShowS
showsPrec :: Int -> Progress -> ShowS
$cshow :: Progress -> String
show :: Progress -> String
$cshowList :: [Progress] -> ShowS
showList :: [Progress] -> ShowS
Show, ReadPrec [Progress]
ReadPrec Progress
Int -> ReadS Progress
ReadS [Progress]
(Int -> ReadS Progress)
-> ReadS [Progress]
-> ReadPrec Progress
-> ReadPrec [Progress]
-> Read Progress
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Progress
readsPrec :: Int -> ReadS Progress
$creadList :: ReadS [Progress]
readList :: ReadS [Progress]
$creadPrec :: ReadPrec Progress
readPrec :: ReadPrec Progress
$creadListPrec :: ReadPrec [Progress]
readListPrec :: ReadPrec [Progress]
Read, (forall x. Progress -> Rep Progress x)
-> (forall x. Rep Progress x -> Progress) -> Generic Progress
forall x. Rep Progress x -> Progress
forall x. Progress -> Rep Progress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Progress -> Rep Progress x
from :: forall x. Progress -> Rep Progress x
$cto :: forall x. Rep Progress x -> Progress
to :: forall x. Rep Progress x -> Progress
Generic)

instance FromJSON Progress where
  parseJSON :: Value -> Parser Progress
parseJSON = Options -> Value -> Parser Progress
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
optionsUntagged

instance ToJSON Progress where
  toJSON :: Progress -> Value
toJSON = Options -> Progress -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
optionsUntagged

data Metric a = Metric
  { forall a. Metric a -> Progress
_metricProgress :: Progress
  , forall a. Metric a -> a
_metricData :: a
  }
  deriving (Metric a -> Metric a -> Bool
(Metric a -> Metric a -> Bool)
-> (Metric a -> Metric a -> Bool) -> Eq (Metric a)
forall a. Eq a => Metric a -> Metric a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Metric a -> Metric a -> Bool
== :: Metric a -> Metric a -> Bool
$c/= :: forall a. Eq a => Metric a -> Metric a -> Bool
/= :: Metric a -> Metric a -> Bool
Eq, Eq (Metric a)
Eq (Metric a) =>
(Metric a -> Metric a -> Ordering)
-> (Metric a -> Metric a -> Bool)
-> (Metric a -> Metric a -> Bool)
-> (Metric a -> Metric a -> Bool)
-> (Metric a -> Metric a -> Bool)
-> (Metric a -> Metric a -> Metric a)
-> (Metric a -> Metric a -> Metric a)
-> Ord (Metric a)
Metric a -> Metric a -> Bool
Metric a -> Metric a -> Ordering
Metric a -> Metric a -> Metric a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Metric a)
forall a. Ord a => Metric a -> Metric a -> Bool
forall a. Ord a => Metric a -> Metric a -> Ordering
forall a. Ord a => Metric a -> Metric a -> Metric a
$ccompare :: forall a. Ord a => Metric a -> Metric a -> Ordering
compare :: Metric a -> Metric a -> Ordering
$c< :: forall a. Ord a => Metric a -> Metric a -> Bool
< :: Metric a -> Metric a -> Bool
$c<= :: forall a. Ord a => Metric a -> Metric a -> Bool
<= :: Metric a -> Metric a -> Bool
$c> :: forall a. Ord a => Metric a -> Metric a -> Bool
> :: Metric a -> Metric a -> Bool
$c>= :: forall a. Ord a => Metric a -> Metric a -> Bool
>= :: Metric a -> Metric a -> Bool
$cmax :: forall a. Ord a => Metric a -> Metric a -> Metric a
max :: Metric a -> Metric a -> Metric a
$cmin :: forall a. Ord a => Metric a -> Metric a -> Metric a
min :: Metric a -> Metric a -> Metric a
Ord, Int -> Metric a -> ShowS
[Metric a] -> ShowS
Metric a -> String
(Int -> Metric a -> ShowS)
-> (Metric a -> String) -> ([Metric a] -> ShowS) -> Show (Metric a)
forall a. Show a => Int -> Metric a -> ShowS
forall a. Show a => [Metric a] -> ShowS
forall a. Show a => Metric a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Metric a -> ShowS
showsPrec :: Int -> Metric a -> ShowS
$cshow :: forall a. Show a => Metric a -> String
show :: Metric a -> String
$cshowList :: forall a. Show a => [Metric a] -> ShowS
showList :: [Metric a] -> ShowS
Show, ReadPrec [Metric a]
ReadPrec (Metric a)
Int -> ReadS (Metric a)
ReadS [Metric a]
(Int -> ReadS (Metric a))
-> ReadS [Metric a]
-> ReadPrec (Metric a)
-> ReadPrec [Metric a]
-> Read (Metric a)
forall a. Read a => ReadPrec [Metric a]
forall a. Read a => ReadPrec (Metric a)
forall a. Read a => Int -> ReadS (Metric a)
forall a. Read a => ReadS [Metric a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Metric a)
readsPrec :: Int -> ReadS (Metric a)
$creadList :: forall a. Read a => ReadS [Metric a]
readList :: ReadS [Metric a]
$creadPrec :: forall a. Read a => ReadPrec (Metric a)
readPrec :: ReadPrec (Metric a)
$creadListPrec :: forall a. Read a => ReadPrec [Metric a]
readListPrec :: ReadPrec [Metric a]
Read, (forall x. Metric a -> Rep (Metric a) x)
-> (forall x. Rep (Metric a) x -> Metric a) -> Generic (Metric a)
forall x. Rep (Metric a) x -> Metric a
forall x. Metric a -> Rep (Metric a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Metric a) x -> Metric a
forall a x. Metric a -> Rep (Metric a) x
$cfrom :: forall a x. Metric a -> Rep (Metric a) x
from :: forall x. Metric a -> Rep (Metric a) x
$cto :: forall a x. Rep (Metric a) x -> Metric a
to :: forall x. Rep (Metric a) x -> Metric a
Generic)

metricSerializeOptions :: Options
metricSerializeOptions :: Options
metricSerializeOptions = Options
optionsMinimize {fieldLabelModifier = camelTo2 '_' . dropPrefix "_metric"}

instance FromJSON a => FromJSON (Metric a) where
  parseJSON :: Value -> Parser (Metric a)
parseJSON Value
v =
    ((Progress -> a -> Metric a) -> (Progress, a) -> Metric a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Progress -> a -> Metric a
forall a. Progress -> a -> Metric a
Metric ((Progress, a) -> Metric a)
-> Parser (Progress, a) -> Parser (Metric a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Progress, a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) -- parse saves from time when metric did not have named fields
      Parser (Metric a) -> Parser (Metric a) -> Parser (Metric a)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Options -> Value -> Parser (Metric a)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
metricSerializeOptions Value
v

instance ToJSON a => ToJSON (Metric a) where
  toJSON :: Metric a -> Value
toJSON = Options -> Metric a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
metricSerializeOptions

makeLensesNoSigs ''Metric

-- | The player progress, so that we know if this game was completed.
metricProgress :: Lens' (Metric a) Progress

-- | Metric data, for example start and end time.
metricData :: Lens' (Metric a) a

-- | This encodes the notion of "more play is better"
-- for incomplete games (rationale: more play = more fun),
--  whereas "smaller inputs are better" for completed games.
--
-- Since 'Maybe' has its own 'Ord' instance where
-- @Nothing < Just x@ regardless of @x@, when we want to
-- choose the minimum value we @fmap Down@ to ensure that
-- the 'Just' is selected while inverting the ordering of
-- the inner member.
chooseBetter ::
  Ord a =>
  -- | criteria; record field extractor
  (b -> Maybe a) ->
  -- | x
  Metric b ->
  -- | y
  Metric b ->
  Metric b
chooseBetter :: forall a b.
Ord a =>
(b -> Maybe a) -> Metric b -> Metric b -> Metric b
chooseBetter b -> Maybe a
criteria (Metric Progress
Attempted b
x) (Metric Progress
Attempted b
y) =
  Progress -> b -> Metric b
forall a. Progress -> a -> Metric a
Metric Progress
Attempted (b -> Metric b) -> b -> Metric b
forall a b. (a -> b) -> a -> b
$ (b -> Maybe a) -> b -> b -> b
forall b a. Ord b => (a -> b) -> a -> a -> a
maxOn b -> Maybe a
criteria b
x b
y
chooseBetter b -> Maybe a
criteria (Metric Progress
Completed b
x) (Metric Progress
Completed b
y) =
  Progress -> b -> Metric b
forall a. Progress -> a -> Metric a
Metric Progress
Completed (b -> Metric b) -> b -> Metric b
forall a b. (a -> b) -> a -> b
$ (b -> Maybe (Down a)) -> b -> b -> b
forall b a. Ord b => (a -> b) -> a -> a -> a
maxOn ((a -> Down a) -> Maybe a -> Maybe (Down a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Down a
forall a. a -> Down a
Down (Maybe a -> Maybe (Down a))
-> (b -> Maybe a) -> b -> Maybe (Down a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe a
criteria) b
x b
y
-- Having exhausted the possibilities where either both
-- are Completed or both are Attempted, now we can just
-- choose the Completed one.
chooseBetter b -> Maybe a
_ x :: Metric b
x@(Metric Progress
Completed b
_) Metric b
_ = Metric b
x
chooseBetter b -> Maybe a
_ Metric b
_ y :: Metric b
y@(Metric Progress
Completed b
_) = Metric b
y