summaryrefslogtreecommitdiff
path: root/src/Lib.hs
blob: 5188950efd90895ebdd907c4a16b521d4ab5a22c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
{-# 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 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
    , 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", class_ "nonbreaking"] "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 : [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&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_ [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"

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