diff options
Diffstat (limited to 'src/Lib.hs')
| -rw-r--r-- | src/Lib.hs | 445 |
1 files changed, 445 insertions, 0 deletions
diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..e3593db --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,445 @@ +{-# 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) +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_ $ toHtml $ T.intercalate ", " labels + , span_ $ toHtml $ T.intercalate ", " (fmap tshow 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’s chronicles. Your mission is to restore the well‐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—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—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—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—)" + 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…" +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 <= 4) || (level == Long && misses <= 8) + 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_ $ strong_ 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_ $ do + a_ [href_ (playURI mediumTags periods level Nothing)] "Retry the current game" + 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_ $ showCard work <> p_ (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. Dates for ancient works are approximate and reflect when construction began." + div_ [class_ "row"] $ do + renderWork work1 (a_ [href_ (mkURI Less)] "Work A was created first.") + hr_ [] + renderWork work2 (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_ [class_ "sep"] (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 |