{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Advent.Types (
Day(..)
, Part(..)
, SubmitInfo(..)
, SubmitRes(..), showSubmitRes
, PublicCode(..)
, Leaderboard(..)
, LeaderboardMember(..)
, Rank(..)
, DailyLeaderboard(..)
, DailyLeaderboardMember(..)
, GlobalLeaderboard(..)
, GlobalLeaderboardMember(..)
, mkDay, mkDay_, dayInt
, _DayInt, pattern DayInt
, partInt
, partChar
, fullDailyBoard
, dlbmCompleteTime
, dlbmTime
, challengeReleaseTime
, parseSubmitRes
) where
import Control.Applicative
import Data.Aeson
import Data.Aeson.Types
import Data.Bifunctor
import Data.Char
import Data.Finite
import Data.Foldable
import Data.Functor.Classes
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import Data.Maybe
import Data.Profunctor
import Data.Text (Text)
import Data.Time hiding (Day)
import Data.Time.Clock.POSIX
import Data.Typeable
import Data.Void
import GHC.Generics
import Servant.API
import Text.Printf
import Text.Read (readMaybe)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Text.HTML.TagSoup as H
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Text.Megaparsec.Char.Lexer as P
import qualified Web.FormUrlEncoded as WF
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup ((<>))
#endif
#if !MIN_VERSION_time(1,9,0)
import Data.Time.LocalTime.Compat
#endif
newtype Day = Day { dayFinite :: Finite 25 }
deriving (Eq, Ord, Enum, Bounded, Typeable, Generic)
instance Show Day where
showsPrec = showsUnaryWith (\d -> showsPrec d . dayInt) "mkDay"
data Part = Part1 | Part2
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)
data SubmitInfo = SubmitInfo
{ siLevel :: Part
, siAnswer :: String
}
deriving (Show, Read, Eq, Ord, Typeable, Generic)
data SubmitRes
= SubCorrect (Maybe Integer)
| SubIncorrect Int (Maybe String)
| SubWait Int
| SubInvalid
| SubUnknown String
deriving (Show, Read, Eq, Ord, Typeable, Generic)
newtype PublicCode = PublicCode { getPublicCode :: Integer }
deriving (Show, Read, Eq, Ord, Typeable, Generic)
data Leaderboard = LB
{ lbEvent :: Integer
, lbOwnerId :: Integer
, lbMembers :: Map Integer LeaderboardMember
}
deriving (Show, Eq, Ord, Typeable, Generic)
data LeaderboardMember = LBM
{ lbmGlobalScore :: Integer
, lbmName :: Maybe Text
, lbmLocalScore :: Integer
, lbmId :: Integer
, lbmLastStarTS :: Maybe UTCTime
, lbmStars :: Int
, lbmCompletion :: Map Day (Map Part UTCTime)
}
deriving (Show, Eq, Ord, Typeable, Generic)
newtype Rank = Rank { getRank :: Finite 100 }
deriving (Show, Eq, Ord, Typeable, Generic)
data DailyLeaderboardMember = DLBM
{ dlbmRank :: Rank
, dlbmDecTime :: NominalDiffTime
, dlbmUser :: Either Integer Text
, dlbmLink :: Maybe Text
, dlbmImage :: Maybe Text
, dlbmSupporter :: Bool
}
deriving (Show, Eq, Ord, Typeable, Generic)
dlbmCompleteTime :: Integer -> Day -> NominalDiffTime -> ZonedTime
dlbmCompleteTime y d t = r
{ zonedTimeToLocalTime = dlbmTime d t `addLocalTime` zonedTimeToLocalTime r
}
where
r = challengeReleaseTime y d
dlbmTime :: Day -> NominalDiffTime -> NominalDiffTime
dlbmTime d = uncurry daysAndTimeOfDayToTime
. first (subtract (dayInt d - 1))
. timeToDaysAndTimeOfDay
data DailyLeaderboard = DLB {
dlbStar1 :: Map Rank DailyLeaderboardMember
, dlbStar2 :: Map Rank DailyLeaderboardMember
}
deriving (Show, Eq, Ord, Typeable, Generic)
data GlobalLeaderboardMember = GLBM
{ glbmRank :: Rank
, glbmScore :: Integer
, glbmUser :: Either Integer Text
, glbmLink :: Maybe Text
, glbmImage :: Maybe Text
, glbmSupporter :: Bool
}
deriving (Show, Eq, Ord, Typeable, Generic)
newtype GlobalLeaderboard = GLB {
glbMap :: Map Rank (Integer, NonEmpty GlobalLeaderboardMember)
}
deriving (Show, Eq, Ord, Typeable, Generic)
instance ToHttpApiData Part where
toUrlPiece = T.pack . show . partInt
toQueryParam = toUrlPiece
instance ToHttpApiData Day where
toUrlPiece = T.pack . show . dayInt
toQueryParam = toUrlPiece
instance ToHttpApiData PublicCode where
toUrlPiece = (<> ".json") . T.pack . show . getPublicCode
toQueryParam = toUrlPiece
instance WF.ToForm SubmitInfo where
toForm = WF.genericToForm WF.FormOptions
{ WF.fieldLabelModifier = camelTo2 '-' . drop 2 }
instance FromJSON Leaderboard where
parseJSON = withObject "Leaderboard" $ \o ->
LB <$> (strInt =<< (o .: "event"))
<*> (strInt =<< (o .: "owner_id"))
<*> o .: "members"
where
strInt t = case readMaybe t of
Nothing -> fail "bad int"
Just i -> pure i
instance FromJSON LeaderboardMember where
parseJSON = withObject "LeaderboardMember" $ \o ->
LBM <$> o .: "global_score"
<*> optional (o .: "name")
<*> o .: "local_score"
<*> (strInt =<< (o .: "id"))
<*> optional (fromEpoch =<< (o .: "last_star_ts"))
<*> o .: "stars"
<*> (do cdl <- o .: "completion_day_level"
(traverse . traverse) ((fromEpoch =<<) . (.: "get_star_ts")) cdl
)
where
strInt t = case readMaybe t of
Nothing -> fail "bad int"
Just i -> pure i
fromEpoch t = case readMaybe t of
Nothing -> fail "bad stamp"
Just i -> pure . posixSecondsToUTCTime $ fromInteger i
instance ToJSONKey Day where
toJSONKey = toJSONKeyText $ T.pack . show . dayInt
instance FromJSONKey Day where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance ToJSONKey Part where
toJSONKey = toJSONKeyText $ \case
Part1 -> "1"
Part2 -> "2"
instance FromJSONKey Part where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance ToJSON Part where
toJSON = String . (\case Part1 -> "1"; Part2 -> "2")
instance FromJSON Part where
parseJSON = withText "Part" $ \case
"1" -> pure Part1
"2" -> pure Part2
_ -> fail "Bad part"
instance ToJSON Day where
toJSON = String . T.pack . show . dayInt
instance FromJSON Day where
parseJSON = withText "Day" $ \t ->
case readMaybe (T.unpack t) of
Nothing -> fail "No read day"
Just i -> case mkDay i of
Nothing -> fail "Day out of range"
Just d -> pure d
instance ToJSONKey Rank where
toJSONKey = toJSONKeyText $ T.pack . show . (+ 1) . getFinite . getRank
instance FromJSONKey Rank where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance ToJSON Rank where
toJSON = String . T.pack . show . (+ 1) . getFinite . getRank
instance FromJSON Rank where
parseJSON = withText "Rank" $ \t ->
case readMaybe (T.unpack t) of
Nothing -> fail "No read rank"
Just i -> case packFinite (i - 1) of
Nothing -> fail "Rank out of range"
Just d -> pure $ Rank d
instance ToJSON DailyLeaderboard where
toJSON = genericToJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 3 }
instance FromJSON DailyLeaderboard where
parseJSON = genericParseJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 3 }
instance ToJSON GlobalLeaderboard where
toJSON = genericToJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 3 }
instance FromJSON GlobalLeaderboard where
parseJSON = genericParseJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 3 }
instance ToJSON DailyLeaderboardMember where
toJSON = genericToJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 4 }
instance FromJSON DailyLeaderboardMember where
parseJSON = genericParseJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 4 }
instance ToJSON GlobalLeaderboardMember where
toJSON = genericToJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 4 }
instance FromJSON GlobalLeaderboardMember where
parseJSON = genericParseJSON defaultOptions
{ fieldLabelModifier = camelTo2 '-' . drop 4 }
parseSubmitRes :: Text -> SubmitRes
parseSubmitRes = either (SubUnknown . P.errorBundlePretty) id
. P.runParser choices "Submission Response"
. mconcat
. mapMaybe deTag
. H.parseTags
where
deTag (H.TagText t) = Just t
deTag _ = Nothing
choices = asum [ P.try parseCorrect P.<?> "Correct"
, P.try parseIncorrect P.<?> "Incorrect"
, P.try parseWait P.<?> "Wait"
, parseInvalid P.<?> "Invalid"
]
parseCorrect :: P.Parsec Void Text SubmitRes
parseCorrect = do
_ <- P.manyTill P.anySingle (P.string' "that's the right answer") P.<?> "Right answer"
r <- optional . (P.<?> "Rank") . P.try $ do
P.manyTill P.anySingle (P.string' "rank")
*> P.skipMany (P.satisfy (not . isDigit))
P.decimal
pure $ SubCorrect r
parseIncorrect = do
_ <- P.manyTill P.anySingle (P.string' "that's not the right answer") P.<?> "Not the right answer"
hint <- optional . (P.<?> "Hint") . P.try $ do
P.manyTill P.anySingle "your answer is" *> P.space1
P.takeWhile1P (Just "dot") (/= '.')
P.manyTill P.anySingle (P.string' "wait") *> P.space1
waitAmt <- (1 <$ P.string' "one") <|> P.decimal
pure $ SubIncorrect (waitAmt * 60) (T.unpack <$> hint)
parseWait = do
_ <- P.manyTill P.anySingle (P.string' "an answer too recently") P.<?> "An answer too recently"
P.skipMany (P.satisfy (not . isDigit))
m <- optional . (P.<?> "Delay minutes") . P.try $
P.decimal <* P.char 'm' <* P.space1
s <- P.decimal <* P.char 's' P.<?> "Delay seconds"
pure . SubWait $ maybe 0 (* 60) m + s
parseInvalid = SubInvalid <$ P.manyTill P.anySingle (P.string' "solving the right level")
showSubmitRes :: SubmitRes -> String
showSubmitRes = \case
SubCorrect Nothing -> "Correct"
SubCorrect (Just r) -> printf "Correct (Rank %d)" r
SubIncorrect i Nothing -> printf "Incorrect (%d minute wait)" (i `div` 60)
SubIncorrect i (Just h) -> printf "Incorrect (%s) (%d minute wait)" h (i `div` 60)
SubWait i -> let (m,s) = i `divMod` 60
in printf "Wait (%d min %d sec wait)" m s
SubInvalid -> "Invalid"
SubUnknown r -> printf "Unknown (%s)" r
dayInt :: Day -> Integer
dayInt = (+ 1) . getFinite . dayFinite
partInt :: Part -> Int
partInt Part1 = 1
partInt Part2 = 2
mkDay :: Integer -> Maybe Day
mkDay = fmap Day . packFinite . subtract 1
mkDay_ :: Integer -> Day
mkDay_ = fromMaybe e . mkDay
where
e = errorWithoutStackTrace "Advent.mkDay_: Date out of range (1 - 25)"
_DayInt :: (Choice p, Applicative f) => p Day (f Day) -> p Integer (f Integer)
_DayInt = dimap a b . right'
where
a i = maybe (Left i) Right . mkDay $ i
b = either pure (fmap dayInt)
pattern DayInt :: Day -> Integer
pattern DayInt d <- (mkDay->Just d)
where
DayInt d = dayInt d
partChar :: Part -> Char
partChar Part1 = 'a'
partChar Part2 = 'b'
fullDailyBoard
:: DailyLeaderboard
-> Bool
fullDailyBoard DLB{..} = (M.size dlbStar1 + M.size dlbStar2) >= 200
challengeReleaseTime
:: Integer
-> Day
-> ZonedTime
challengeReleaseTime y d = ZonedTime
{ zonedTimeToLocalTime = LocalTime
{ localDay = fromGregorian y 12 (fromIntegral (dayInt d))
, localTimeOfDay = midnight
}
, zonedTimeZone = read "EST"
}