path: root/src/Lib.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

module Lib ( startApp, loadManifest )
where

import qualified Control.Exception        as E
import qualified Control.Exception.Safe   as CES
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.State
import qualified Data.Binary              as B
import qualified Data.Binary.Get          as BG
import           Data.Bits
import qualified Data.ByteString.Lazy     as BSL
import           Data.Either.Combinators
import qualified Data.List                as L
import qualified Data.List.Split          as DLS
import qualified Data.Map                 as M
import           Data.Sort
import qualified Data.String.Conversions  as DSC
import qualified Data.Text                as T
import           GHC.Generics
import           Lucid
import           Network.Wai.Handler.Warp
import           Servant                  hiding ((:.))
import           Servant.HTML.Lucid
import qualified System.Random            as R
import           Text.Hex
import           Toml
import           Web.HttpApiData

newtype Manifest = Manifest { mediums :: [Medium] }
data Medium = Medium { tag         :: MediumTag
                     , label       :: T.Text
                     , description :: T.Text
                     , disabled    :: Bool
                     , works       :: [Work] }
data Figure = Figure { file   :: T.Text
                     , byline :: T.Text }
data Work = Work { name     :: T.Text
                 , year     :: Integer
                 , location :: T.Text
                 , wiki     :: T.Text
                 , figures  :: [Figure] }
instance Eq Work where
    (==) Work{year=y1} Work{year=y2} = y1 == y2
instance Ord Work where
    compare Work{year=y1} Work{year=y2} = compare y1 y2
manifestCodec :: Toml.TomlCodec Manifest
manifestCodec = Manifest
    <$> Toml.list mediumCodec "mediums" .= mediums
mediumCodec :: Toml.TomlCodec Medium
mediumCodec = Medium
    <$> Toml.diwrap (Toml.text "tag") .= tag
    <*> Toml.text "label" .= label
    <*> Toml.text "description" .= description
    <*> Toml.bool "disabled" .= disabled
    <*> Toml.list workCodec "works" .= works
workCodec :: Toml.TomlCodec Work
workCodec = Work
    <$> Toml.text "name" .= name
    <*> Toml.integer "year" .= year
    <*> Toml.text "location" .= location
    <*> Toml.text "wiki" .= wiki
    <*> Toml.list figureCodec "figures" .= figures
figureCodec :: Toml.TomlCodec Figure
figureCodec = Figure
    <$> Toml.text "file" .= file
    <*> Toml.text "byline" .= byline

newtype HomeView = HomeView Manifest
data PlayView = GameView [MediumTag] [T.Text] [Period] Level GameState (Work, Work)
              | FinalView [MediumTag] [T.Text] [Period] Level [Work] [Work] Integer
newtype MediumTag = MediumTag T.Text deriving (Eq, Show, Ord, ToHttpApiData, FromHttpApiData, ToHtml)
data Period = Ancient | Postclassical | EarlyModern | Modern deriving (Eq, Show, Read, Bounded, Enum)
renderPeriod :: Period -> T.Text
renderPeriod EarlyModern = "Early modern"
renderPeriod x           = tshow x
data Level = Short | Long deriving (Eq, Show, Read, Bounded, Enum)
instance ToHttpApiData Period where
    toUrlPiece = tshow
instance FromHttpApiData Period where
    parseUrlPiece = parseBoundedUrlPiece
instance ToHttpApiData Level where
    toUrlPiece = tshow
instance FromHttpApiData Level where
    parseUrlPiece = parseBoundedUrlPiece

periodElem :: Integer -> [Period] -> Bool
periodElem x = L.any (isIn x)
    where isIn y Ancient       = y <= 600
          isIn y Postclassical = y >= 400 && y <= 1600
          isIn y EarlyModern   = y >= 1400 && y <= 1850
          isIn y Modern        = y >= 1750
data Order = Less | Greater deriving (Eq, Show)
newtype Decisions = Decisions [Order] deriving (Eq, Show)
newtype Version = Version B.Word8 deriving (Eq, Show, FromHttpApiData, Generic, Num)
newtype Seed = Seed B.Word16 deriving (Eq, Show, FromHttpApiData, Generic, Num, R.Random)
-- TODO fml use bitvec pkg
instance B.Binary Decisions where
    get = do
        c <- fromIntegral <$> B.getWord8
        b <- BG.getByteString (div c 8 + (if 0 == mod c 8 then 0 else 1))
        let res = concatMap (\x -> fmap (\i -> if 0 == shiftR x i .&. 1 then Less else Greater) [0..7]) (BSL.unpack . BSL.fromStrict $ b)
        return $ Decisions (take c res)
    put (Decisions comps) =
        B.putWord8 (fromIntegral (mod (length comps) 256))
        <>
        mapM_ B.putWord8 intchunks
            where
                chunks = DLS.chunksOf 8 comps
                convchunk = fmap (\x -> if x == Less then (0 :: Integer) else 1)
                intify convd = (fromIntegral $ Prelude.sum $ (\(x, i) -> x * (2 ^ i)) <$> zip convd [(0 :: Integer)..]) :: B.Word8
                intchunks = fmap (intify .convchunk) chunks
instance B.Binary Version
instance B.Binary Seed
data GameState = GameState Version Seed Decisions deriving (Eq, Show)
instance B.Binary GameState where
    get = GameState <$> B.get <*> B.get <*> B.get
    put (GameState version seed decisions) = B.put version >> B.put seed >> B.put decisions

instance ToHttpApiData GameState where
    toUrlPiece = encodeHex . BSL.toStrict . B.encode
instance FromHttpApiData GameState where
    parseUrlPiece s = do
        b <- maybeToRight "failed to decode state" (decodeHex s)
        case B.decodeOrFail (BSL.fromStrict b) of
          Left (_, _, err) -> Left (T.pack err)
          Right (_, _, x)  -> Right x

type HomeAPI = Get '[HTML] HomeView
type PlayAPI = "play"
                :> QueryParams "m" MediumTag
                :> QueryParams "p" Period
                :> QueryParam "l" Level
                :> QueryParam "s" GameState
                :> Get '[HTML] PlayView

type API = HomeAPI :<|> PlayAPI :<|> "static" :> Raw

startApp :: Manifest -> IO ()
startApp manifest = run 8090 (app manifest)

app :: Manifest -> Application
app manifest = serve api $ hoistServer api handleErrors (server manifest)

handleErrors :: Handler a -> Handler a
handleErrors f =
  CES.catches
    f
    [ CES.Handler (loggify handleAppException),
      CES.Handler (loggify handleArbitraryException)
    ]

api :: Proxy API
api = Proxy

server :: Manifest -> Server API
server manifest =
  handleHome manifest
  :<|> handlePlay manifest
  :<|> serveDirectoryWebApp "static/"

redirectTo :: T.Text -> Handler a
redirectTo uri = throwError err302 {errHeaders = [("Location", DSC.cs uri)]}

------------------------------

loadManifest :: IO (Either [TomlDecodeError] Manifest)
loadManifest = Toml.decodeFileEither manifestCodec "static/manifest.toml"

data AppException = NotEnoughWorks | NeedAMedium | NeedAPeriod | NeedLevel deriving (Show)

instance E.Exception AppException

loggify :: E.Exception b => (b -> Handler a) -> b -> Handler a
loggify f ex = do
  liftIO $ print ex
  f ex

handleArbitraryException :: E.SomeException -> Handler a
handleArbitraryException _ = throwError err500 {errBody = "500: An unexpected error occurred."}

handleAppException :: AppException -> Handler a
handleAppException NotEnoughWorks =
  throwError err400 {errBody = "400: Sorry, not enough works match these options. Please choose more folios or periods."}
handleAppException NeedAMedium =
  throwError err400 {errBody = "400: Need at least one folio."}
handleAppException NeedAPeriod =
  throwError err400 {errBody = "400: Need at least one period."}
handleAppException NeedLevel =
  throwError err400 {errBody = "400: Need a duration."}

handleHome :: Manifest -> Handler HomeView
handleHome manifest = return $ HomeView manifest

currentVersion :: Version
currentVersion = Version 1

handlePlay :: Manifest -> [MediumTag] -> [Period] -> Maybe Level -> Maybe GameState -> Handler PlayView
handlePlay _ [] _ _ _ = E.throw NeedAMedium
handlePlay _ _ [] _ _ = E.throw NeedAPeriod
handlePlay _ _ _ Nothing _ = E.throw NeedLevel
handlePlay _ mediumTags periods (Just level) Nothing = do
    seed <- liftIO R.randomIO
    redirectTo $ playURI mediumTags periods level (Just (GameState currentVersion seed (Decisions [])))
handlePlay Manifest{mediums} mediumTags periods (Just level)
        (Just gameState@(GameState _ (Seed seed) (Decisions comparisons))) = do
    let mediums' = filter ((`elem` mediumTags) . tag) mediums
        labels = fmap label mediums'
        works' = concatMap works mediums'
        works'' = filter ((`periodElem` periods) . year) works'
    liftIO $ when (length works'' < levelLength level) $ E.throw NotEnoughWorks
    let rng = R.mkStdGen (fromIntegral seed)
        (works''', _) = fisherYates rng works''
        works'''' = take (levelLength level) works'''
        (userWorks, nextPair, misses) = antiquitySort works'''' comparisons
    case nextPair of
      Just workPair -> return $ GameView mediumTags labels periods level gameState workPair
      Nothing -> return $ FinalView mediumTags labels periods level userWorks (sortOn year works'''') misses

levelLength :: Level -> Int
levelLength Short = 6
levelLength Long  = 10

-- from Haskell wiki
fisherYatesStep :: R.RandomGen g => (M.Map Int a, g) -> (Int, a) -> (M.Map Int a, g)
fisherYatesStep (m, gen) (i, x) = ((M.insert j x . M.insert i (m M.! j)) m, gen')
  where
    (j, gen') = R.randomR (0, i) gen

-- from Haskell wiki
fisherYates :: R.RandomGen g => g -> [a] -> ([a], g)
fisherYates gen [] = ([], gen)
fisherYates gen l =
  toElems $ foldl fisherYatesStep (initial (head l) gen) (numerate (tail l))
  where
    toElems (x, y) = (M.elems x, y)
    numerate = zip [1..]
    initial x g = (M.singleton 0 x, g)

antiquitySort :: Ord a => [a] -> [Order] -> ([a], Maybe (a, a), Integer)
antiquitySort elements orders =
    let ((sortedElements, misses), (_, next)) = runState (antiquitySort' elements) (orders, Nothing)
    in (sortedElements, next, misses)
   where
       antiquitySort' :: Ord a => [a] -> State ([Order], Maybe (a, a)) ([a], Integer)
       antiquitySort' [] = return ([], 0)
       antiquitySort' [x] = return ([x], 0)
       antiquitySort' xs = do
           let (ys, zs) = splitAt (div (length xs) 2) xs
           (sortedYs, missesYs) <- antiquitySort' ys
           (sortedZs, missesZs) <- antiquitySort' zs
           (sortedXs, missesCombine) <- combine sortedYs sortedZs
           return (sortedXs, missesYs + missesZs + missesCombine)
       combine :: Ord a => [a] -> [a] -> State ([Order], Maybe (a, a)) ([a], Integer)
       combine [] ys = return (ys, 0)
       combine xs [] = return (xs, 0)
       combine allXs@(x:xs) allYs@(y:ys) = consumeOrder >>= \case
         Nothing -> do
             get >>= \case
                (cs, Nothing) -> put (cs, Just (x, y))
                _ -> return ()
             return (allXs ++ allYs, 0)
         Just Less -> do
             (combined, misses) <- combine xs allYs
             return (x:combined, misses + (if x < y then 0 else 1))
         Just Greater -> do
             (combined, misses) <- combine allXs ys
             return (y:combined, misses + (if x > y then 0 else 1))
       consumeOrder :: State ([Order], Maybe (a, a)) (Maybe Order)
       consumeOrder = get >>= \case
         ([], _) -> return Nothing
         (x:xs, next) -> do
             put (xs, next)
             return (Just x)

-------------------------------

homeURI :: T.Text
homeURI = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy HomeAPI) :: Link)

playURI :: [MediumTag] -> [Period] -> Level -> Maybe GameState -> T.Text
playURI mediumTags periods level gameState = "/" <> toUrlPiece (safeLink api (Proxy :: Proxy PlayAPI) mediumTags periods (Just level) gameState :: Link)

-------------------------------

gameCrumbs :: Monad m => [MediumTag] -> [T.Text] -> [Period] -> Level -> [HtmlT m ()]
gameCrumbs _ labels periods level = [
    span_ $ toHtmlRaw $ T.intercalate " &middot; " labels
    -- TODO
    , span_ $ toHtmlRaw $ T.intercalate " &middot; " (renderPeriod <$> periods)
    , span_ $ toHtml . tshow $ level ]

instance ToHtml HomeView where
  toHtml (HomeView (Manifest mediums)) =
    pageTemplate
      [a_ [href_ "https://git.cyfraeviolae.org/antiquitysort"] "source code"]
      homeBody
    where
      homeBody = div_ [class_ "narrow"] $ do
        p_ $ toHtmlRaw $ T.pack "The spectral sorcerer Roseacrucis has cast his nefarious randomizing algorithms upon the Library&rsquo;s chronicles. Your mission is to restore the well&dash;ordering of our cultural histories."
        form_ [method_ "get", action_ "/play"] $ do
            fieldset_ $ do
                legend_ "Folios"
                forM_ mediums $ \Medium{tag=(MediumTag tagm),label,description,disabled} -> div_ $ do
                    input_ $ [type_ "checkbox", name_ "m", value_ tagm, id_ tagm] ++
                            [checked_ | tagm == "ReligiousArchitecture"] ++
                            [disabled_ "1" | disabled]
                    label_ [for_ tagm] $ do
                        span_ $ strong_ $ toHtml label <> ". "
                        if disabled
                           then span_ "Coming soon."
                           else span_ $ toHtmlRaw description
            fieldset_ $ do
                legend_ "Periods"
                div_ $ do
                    input_ [type_ "checkbox", name_ "p", value_ "Ancient", id_ "Ancient", checked_]
                    label_ [for_ "Ancient"] $ do
                        span_ $ strong_ "Ancient "
                        span_ $ toHtmlRaw $ T.pack "(3000 BCE&mdash;600 CE)"
                div_ $ do
                    input_ [type_ "checkbox", name_ "p", value_ "Postclassical", id_ "Postclassical"]
                    label_ [for_ "Postclassical"] $ do
                        span_ $ strong_ "Postclassical "
                        span_ $ toHtmlRaw $ T.pack "(400 CE&mdash;1600 CE)"
                div_ $ do
                    input_ [type_ "checkbox", name_ "p", value_ "EarlyModern", id_ "EarlyModern"]
                    label_ [for_ "EarlyModern"] $ do
                        span_ $ strong_ "Early modern "
                        span_ $ toHtmlRaw $ T.pack "(1400 CE&mdash;1850 CE)"
                div_ $ do
                    input_ [type_ "checkbox", name_ "p", value_ "Modern", id_ "Modern"]
                    label_ [for_ "Modern"] $ do
                        span_ $ strong_ "Modern "
                        span_ $ toHtmlRaw $ T.pack "(1750 CE&mdash;)"
            fieldset_ $ do
                legend_ "Duration"
                div_ $ do
                    input_ [type_ "radio", name_ "l", value_ "Short", id_ "Short", checked_]
                    label_ [for_ "Short"] $ do
                        span_ $ strong_ "Short "
                        span_ "(6 works, less than 11 questions)"
                div_ $ do
                    input_ [type_ "radio", name_ "l", value_ "Long", id_ "Long"]
                    label_ [for_ "Long"] $ do
                        span_ $ strong_ "Long "
                        span_ "(10 works, less than 25 questions)"
            button_ [type_ "submit"] "Start"
  toHtmlRaw = toHtml

feedbackPerfect :: Integer -> T.Text
feedbackPerfect _ = "Hurrah! The chronicles are once again in perfect order. You have foiled not only the perfidious Roseacrucis, but even the divine disorder induced by the Arrow of Time itself. The Library moves to induct you into the illustrious Order of the Temporal Modality. But our revelry must be short-lived, for Roseacrucis may one day return&hellip;"
feedbackMiddling :: Integer -> T.Text
feedbackMiddling misses = "The Library congratulates your worthy efforts, for only " <> (if misses == 1 then "one question was" else tshow misses <> " questions were") <> " answered incorrectly. With further training, you may one day defeat Roseacrucis."
feedbackPoor :: Integer -> T.Text
feedbackPoor misses = "The Library regrets to inform you that due to the " <> (if misses == 1 then "one question" else tshow misses <> " questions") <> " that you answered incorrectly, we have made absolutely no progress in emending the enigma of entropy engendered by Roseacrucis."

feedback :: Level -> Integer -> T.Text
feedback _ 0 = feedbackPerfect 0
feedback level misses =
    if (level == Short && misses <= 2) || (level == Long && misses <= 7)
       then feedbackMiddling misses
       else feedbackPoor misses

showCard :: Monad m => Work -> HtmlT m ()
showCard Work{name,year,wiki} = do
    a_ [href_ wiki] (toHtml name)
    span_ $ toHtml $ " (" <> tshow (abs year) <> " " <> (if year < 0 then "BCE)" else "CE)")

renderWork :: Monad m => Work -> HtmlT m () -> HtmlT m ()
renderWork Work{figures} header = div_ [class_ "work"] $ do
    div_ header
    div_ [class_ "subwork"] $ mapM_ renderFigure figures
renderFigure :: Monad m => Figure -> HtmlT m ()
renderFigure Figure{file,byline} = figure_ $ do
    img_ [src_ ("/static/assets/" <> file)]
    figcaption_ $ toHtml byline

instance ToHtml PlayView where
    toHtml (FinalView mediumTags labels periods level userWorks sortedWorks misses) =
        pageTemplate (gameCrumbs mediumTags labels periods level) body
        where
            body = do
                div_ [class_ "row"] $ div_ [class_ "narrow"] $ do
                    p_ . toHtmlRaw $ feedback level misses
                    p_ $ em_ $ do
                        a_ [href_ (playURI mediumTags periods level Nothing)] "Retry"
                        span_ ", or "
                        a_ [href_ homeURI] "choose different folios and periods"
                        span_ "."
                div_ [class_ "row"] $ table_ $ do
                        tr_ $ th_ "Your ordering" <> th_ "Correct ordering"
                        mapM_ (\(userWork, sortedWork) -> tr_ $
                                td_ (showCard userWork) <> td_ (showCard sortedWork))
                              (zip userWorks sortedWorks)
                div_ [class_ "row"] $ div_ [class_ ""] $ mapM_ (\work -> do
                        renderWork work $ p_ $ do
                            strong_ $ showCard work
                            span_ $ toHtmlRaw $ T.pack " &middot; "
                            span_ $ em_ (toHtml $ location work)
                        br_ []) sortedWorks
    toHtml (GameView mediumTags labels periods level (GameState v s (Decisions comps)) (work1, work2)) =
        pageTemplate (gameCrumbs mediumTags labels periods level) body
        where
            body = do
                div_ [class_ "row"] $ p_ $ do
                    strong_ . toHtml $ "Question " <> tshow (length comps + 1) <> ". "
                    span_ "Select the work that was created first."
                    small_ $ em_ " Dates for ancient works are approximate and reflect when construction began."
                div_ [class_ "row"] $ do
                    renderWork work1 (strong_ $ a_ [href_ (mkURI Less)] "Work A was created first.")
                    hr_ []
                    renderWork work2 (strong_ $ a_ [href_ (mkURI Greater)] "Work B was created first.")
            mkURI nxt = playURI mediumTags periods level (Just (GameState v s (Decisions (comps ++ [nxt]))))
    toHtmlRaw = toHtml

pageTemplate :: Monad m => [HtmlT m ()] -> HtmlT m () -> HtmlT m ()
pageTemplate crumbs body = doctypehtml_ $ do
  head_ $ do
    title_ "Antiquitysort"
    meta_ [charset_ "utf-8"]
    meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
    link_ [rel_ "shortcut icon", type_ "image/x-icon", href_ "/static/favicon.ico"]
    link_ [rel_ "stylesheet", type_ "text/css", href_ "/static/style.css"]
  body_ $
    div_ [class_ "container"] $ do
      div_ [class_ "row navbar"] $
        sequence_ $
          L.intersperse
            (span_ [] (toHtmlRaw (T.pack " / ")))
            (crumb : crumbs)
      body
    where
        crumb = do
            a_ [href_ homeURI, class_ "title"] (strong_ "Antiquitysort")
            span_ "@"
            a_ [href_ "https://cyfraeviolae.org", class_ "title"] "cyfraeviolae"

tshow :: Show a => a -> T.Text
tshow = T.pack . show