summaryrefslogtreecommitdiff
path: root/src/Lib.hs
blob: 212f31e117c9d4ff2bff23552a7663301d3fb5c0 (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
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
{-# 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 = "antiquitysort" :> Get '[HTML] HomeView

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

type StaticAPI = "antiquitysort" :> "static" :> Raw

type API = HomeAPI :<|> PlayAPI :<|> StaticAPI

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://cyfraeviolae.org/git/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_ "/antiquitysort/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_ ("/antiquitysort/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_ "/antiquitysort/static/favicon.ico"]
    link_ [rel_ "stylesheet", type_ "text/css", href_ "/antiquitysort/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