diff options
Diffstat (limited to 'src/Lib.hs')
| -rw-r--r-- | src/Lib.hs | 552 |
1 files changed, 308 insertions, 244 deletions
@@ -1,152 +1,192 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# 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] } +{-# 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 + (==) Work {year = y1} Work {year = y2} = y1 == y2 + instance Ord Work where - compare Work{year=y1} Work{year=y2} = compare y1 y2 + compare Work {year = y1} Work {year = y2} = compare y1 y2 + manifestCodec :: Toml.TomlCodec Manifest -manifestCodec = Manifest +manifestCodec = + Manifest <$> Toml.list mediumCodec "mediums" .= mediums + mediumCodec :: Toml.TomlCodec Medium -mediumCodec = 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 +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 +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 + +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 +renderPeriod x = tshow x + data Level = Short | Long deriving (Eq, Show, Read, Bounded, Enum) + instance ToHttpApiData Period where - toUrlPiece = tshow + toUrlPiece = tshow + instance FromHttpApiData Period where - parseUrlPiece = parseBoundedUrlPiece + parseUrlPiece = parseBoundedUrlPiece + instance ToHttpApiData Level where - toUrlPiece = tshow + toUrlPiece = tshow + instance FromHttpApiData Level where - parseUrlPiece = parseBoundedUrlPiece + 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 + 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 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 + 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 + 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 + 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 + 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 PlayAPI = + "play" + :> QueryParams "m" MediumTag + :> QueryParams "p" Period + :> QueryParam "l" Level + :> QueryParam "s" GameState + :> Get '[HTML] PlayView type API = HomeAPI :<|> PlayAPI :<|> "static" :> Raw @@ -170,8 +210,8 @@ api = Proxy server :: Manifest -> Server API server manifest = handleHome manifest - :<|> handlePlay manifest - :<|> serveDirectoryWebApp "static/" + :<|> handlePlay manifest + :<|> serveDirectoryWebApp "static/" redirectTo :: T.Text -> Handler a redirectTo uri = throwError err302 {errHeaders = [("Location", DSC.cs uri)]} @@ -214,10 +254,14 @@ 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 + 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' @@ -233,7 +277,7 @@ handlePlay Manifest{mediums} mediumTags periods (Just level) levelLength :: Level -> Int levelLength Short = 6 -levelLength Long = 10 +levelLength Long = 10 -- from Haskell wiki fisherYatesStep :: R.RandomGen g => (M.Map Int a, g) -> (Int, a) -> (M.Map Int a, g) @@ -248,44 +292,46 @@ fisherYates gen l = toElems $ foldl fisherYatesStep (initial (head l) gen) (numerate (tail l)) where toElems (x, y) = (M.elems x, y) - numerate = zip [1..] + 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) + 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) ------------------------------- @@ -298,10 +344,11 @@ playURI mediumTags periods level gameState = "/" <> toUrlPiece (safeLink api (Pr ------------------------------- gameCrumbs :: Monad m => [MediumTag] -> [T.Text] -> [Period] -> Level -> [HtmlT m ()] -gameCrumbs _ labels periods level = [ - span_ $ toHtmlRaw $ T.intercalate " · " labels - , span_ $ toHtmlRaw $ T.intercalate " · " (renderPeriod <$> periods) - , span_ $ toHtml . tshow $ level ] +gameCrumbs _ labels periods level = + [ span_ $ toHtmlRaw $ T.intercalate " · " labels, + span_ $ toHtmlRaw $ T.intercalate " · " (renderPeriod <$> periods), + span_ $ toHtml . tshow $ level + ] instance ToHtml HomeView where toHtml (HomeView (Manifest mediums)) = @@ -312,119 +359,136 @@ instance ToHtml HomeView 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 : [class_ "disabled" | disabled]) $ 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" + 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 : [class_ "disabled" | disabled]) $ 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 <= 2) || (level == Long && misses <= 7) - then feedbackMiddling misses - else feedbackPoor 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)") +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 +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 +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 " · " - 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 + 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 " · " + 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 @@ -442,11 +506,11 @@ pageTemplate crumbs body = doctypehtml_ $ do (span_ [class_ "sep"] (toHtmlRaw (T.pack " | "))) (crumb : crumbs) body - where - crumb = span_ [class_ "ico"] $ do - a_ [href_ homeURI, class_ "title"] (strong_ "Antiquitysort") - span_ "@" - a_ [href_ "https://cyfraeviolae.org"] "cyfraeviolae.org" + where + crumb = span_ [class_ "ico"] $ do + a_ [href_ homeURI, class_ "title"] (strong_ "Antiquitysort") + span_ "@" + a_ [href_ "https://cyfraeviolae.org"] "cyfraeviolae.org" tshow :: Show a => a -> T.Text tshow = T.pack . show |