{-# 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 ", " labels,
    span_ $ toHtmlRaw $ T.intercalate ", " (renderPeriod <$> periods),
    span_ $ toHtml . tshow $ level
  ]

instance ToHtml HomeView where
  toHtml (HomeView (Manifest mediums)) =
    pageTemplate
      []
      homeBody
    where
      homeBody = div_ $ 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."
        br_ []
        form_ [method_ "get", action_ "/antiquitysort/play"] $ do
          div_ $ 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_ $ toHtml label <> ". "
                if disabled
                  then span_ "Coming soon."
                  else span_ $ toHtmlRaw description
          br_ []
          div_ $ do
            legend_ "Periods"
            div_ $ do
              input_ [type_ "checkbox", name_ "p", value_ "Ancient", id_ "Ancient", checked_]
              label_ [for_ "Ancient"] $ do
                span_ $ "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_ $ "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_ $ "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_ $ "Modern "
                span_ $ toHtmlRaw $ T.pack "(1750 CE&mdash;)"
          br_ []
          div_ $ do
            legend_ "Duration"
            div_ $ do
              input_ [type_ "radio", name_ "l", value_ "Short", id_ "Short", checked_]
              label_ [for_ "Short"] $ do
                span_ $ "Short "
                span_ "(6 works, less than 11 questions)"
            div_ $ do
              input_ [type_ "radio", name_ "l", value_ "Long", id_ "Long"]
              label_ [for_ "Long"] $ do
                span_ $ "Long "
                span_ "(10 works, less than 25 questions)"
          br_ []
          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_ "wrapper"] $ mapM_ renderFigure figures

renderFigure :: Monad m => Figure -> HtmlT m ()
renderFigure Figure {file, byline} = figure_ $ do
  img_ [src_ ("/antiquitysort/static/assets/" <> file)]
  br_ []
  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_  $
          div_ $ 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_ "."
        br_ []
        div_  $
          table_ $ do
            tr_ $ th_ "Your ordering" <> th_ "Correct ordering"
            mapM_
              ( \(userWork, sortedWork) ->
                  tr_ $
                    td_ (showCard userWork) <> td_ (showCard sortedWork)
              )
              (zip userWorks sortedWorks)
        div_  $
          div_ $
            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_  $
          p_ $ do
            strong_ . toHtml $ "Question " <> tshow (length comps + 1) <> ". "
            span_ "Select the work that was created first."
            br_ []
            small_ $ em_ " Dates for ancient works are approximate and reflect when construction began."
        br_ []
        div_  $ 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_ "/static/styles.css"]
    link_ [rel_ "stylesheet", type_ "text/css", href_ "/antiquitysort/static/styles.css"]
  body_ $
    div_ [class_ "container"] $ do
      div_ $ do
        div_ [class_ "home"] $ do
          a_ [href_ homeURI, class_ "home-title"] (strong_ "Antiquitysort")
          span_ " at "
          a_ [href_ "/"] "cyfraeviolae.org"
        div_ [class_ "crumbs"] $ sequence_ $
          L.intersperse
            (span_ [class_ "sep"] (toHtmlRaw (T.pack " &middot; ")))
            (srcCrumb : crumbs)
      body
  where
    srcCrumb = a_ [href_ "/git/antiquitysort"] "source code"

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