{-# LANGUAGE OverloadedLists #-}

module Rosetta.Matching where

import Data.ByteString.Builder (Builder)

-- import Data.Char qualified as Char
import Data.List qualified as List
import Data.Map.Strict qualified as Map

-- import Data.Set qualified as Set
import Data.Text qualified as Text
import System.Random qualified as Random
import System.Random.Shuffle as Random

-- import Data.Text.Short qualified as ShortText
import System.FilePath.Posix ((</>))
import System.FilePath.Posix qualified as File
import Text.Blaze
import Text.Blaze.Html5 qualified as HTML
import Text.Blaze.Html5.Attributes qualified as HA
import Text.Blaze.Renderer.Utf8 qualified as Blaze
import Prelude (div, even)

import Language
import Language.Chinese (ChineseDict (..), ChineseDictEntries (..))
import Language.Chinese qualified
import Language.Chinese qualified as Chinese
import Language.English qualified as English
import Language.French qualified as French
import Language.Pronunciation qualified as Pron
import Paths_worksheets qualified as Self
import Worksheets.Utils.Char as Char
import Worksheets.Utils.HTML (Length, className, classes, cm, fr, styles)
import Worksheets.Utils.HTML qualified as HTML
import Worksheets.Utils.IPA qualified as IPA
import Worksheets.Utils.Paper
import Worksheets.Utils.Prelude

type Difficulties = Map Langue (Map UnicodeBlock Difficulty)
data Difficulty = Difficulty
  { difficultyCharWidth :: Length
  , difficultyCharHeight :: Length
  , difficultyWordSpacing :: Length
  , difficultyFontSize :: Length
  , difficultyFontFamily :: Text
  , difficultyFontVariant :: Text
  , difficultyColor :: Text
  , difficultyLineHeight :: Maybe Double
  }
  deriving (Eq, Show, Generic)
instance HasTypeDefault Difficulty where
  typeDefault =
    Difficulty
      { difficultyCharWidth = 1 & cm
      , difficultyCharHeight = 1 & cm
      , difficultyWordSpacing = 0.5 & cm
      , difficultyFontSize = 1 & cm
      , difficultyFontFamily = "Arial"
      , difficultyFontVariant = "small-caps"
      , difficultyColor = "#000000"
      , difficultyLineHeight = Nothing
      }

difficultyBig :: Char.UnicodeBlock -> Modifier Difficulty
difficultyBig ub v = case ub of
  Char.UnicodeBlockLatin{} ->
    v
      { difficultyCharWidth = 1 & cm
      , difficultyCharHeight = 1 & cm
      , difficultyWordSpacing = 0.5 & cm
      , difficultyFontSize = 0.90 & cm
      }
  Char.UnicodeBlockCJK{} ->
    v
      { difficultyCharWidth = 1.50 & cm
      , difficultyCharHeight = 1.50 & cm
      , difficultyWordSpacing = 0.5 & cm
      , difficultyFontSize = 1.40 & cm
      }
  Char.UnicodeBlockHalfwidth_and_Fullwidth_Forms{} ->
    v
      { difficultyCharWidth = 1.50 & cm
      , difficultyCharHeight = 1.50 & cm
      , difficultyWordSpacing = 0.5 & cm
      , difficultyFontSize = 1.40 & cm
      }
  _ -> v

data Matter
  = MatterText
      { matterText :: Pron.InputLexemes
      , matterLangue :: Langue
      }
  | MatterSyls
      { matterSyls :: [[Pron.Syl]]
      , matterLangue :: Langue
      }
  | MatterSound
      { matterSyls :: [[Pron.Syl]]
      , matterLangue :: Langue
      }
  | MatterPicture
      { matterPicture :: File.FilePath
      , matterPictureCSS :: HTML.CSSBlock
      }
  deriving (Eq, Show, Generic)

-- deriving (HasTypeDefault) via (Generically Matter)

data Match = Match
  { matchMatters :: [Matter]
  }
  deriving (Eq, Show, Generic)

instance HasTypeDefault Match where
  typeDefault =
    Match
      { matchMatters = []
      }

data Page = Page
  { pageMatches :: [Match]
  , pageMatchesNum :: Natural
  , pageSize :: PageSize
  , pageOrientation :: PageOrientation
  }
  deriving (Eq, Show, Generic)
instance HasTypeDefault Page where
  typeDefault =
    Page
      { pageMatches = mempty
      , pageMatchesNum = 10
      , pageSize = typeDefault
      , pageOrientation = typeDefault
      }

data Pages = Pages
  { pagesList :: [Page]
  , pagesDifficulties :: Difficulties
  }
  deriving (Eq, Show, Generic)
instance HasTypeDefault Pages where
  typeDefault =
    Pages
      { pagesList = []
      , pagesDifficulties =
          [ lang :=
              [ block := typeDefault
              | block <- Char.unicodeBlocks & toList
              ]
                & Map.fromList
          | lang <- langues & toList
          ]
            & Map.fromList
      }

data Dicts = Dicts
  { dictsChinese :: Chinese.ChineseDict
  , dictsFrench :: Pron.Table
  , dictsEnglish :: Pron.Table
  }

pagesHTML :: Dicts -> Text -> Pages -> IO Builder
pagesHTML Dicts{..} title pagesUnchunked = do
  -- FIXME: this absolute path is not portable out of my system
  dataPath <- Self.getDataDir <&> File.normalise
  randomGen <- Random.getStdGen
  pagesListShuffled :: [[Page]] <-
    forM (pagesUnchunked & pagesList) \page -> do
      pagesMatchesShuffled <- page & pageMatches & Random.shuffleM
      forM (pagesMatchesShuffled & chunksOf (page & pageMatchesNum)) \matches -> do
        let matchesSyls =
              matches <&> \match ->
                Match $
                  match & matchMatters & foldMap \case
                    MatterText{matterLangue = LangueAnglais, matterText} ->
                      [ MatterSound{matterSyls, matterLangue = LangueAnglais}
                      , MatterSyls{matterSyls, matterLangue = LangueAnglais}
                      ]
                      where
                        matterSyls =
                          matterText
                            & Pron.unInputLexemes
                            & Pron.runParser dictsEnglish
                            & either errorShow id
                            & Pron.words
                            & Pron.addIndexes
                    MatterText{matterLangue = LangueFrançais, matterText} ->
                      [ MatterSound{matterSyls, matterLangue = LangueFrançais}
                      , MatterSyls{matterSyls, matterLangue = LangueFrançais}
                      ]
                      where
                        matterSyls =
                          matterText
                            & Pron.unInputLexemes
                            & Pron.runParser dictsFrench
                            & either errorShow id
                            & Pron.words
                            & Pron.addIndexes
                    MatterText{matterLangue = LangueMandarin, matterText} ->
                      [ MatterSound{matterSyls, matterLangue = LangueMandarin}
                      , MatterSyls{matterSyls, matterLangue = LangueMandarin}
                      ]
                      where
                        matterSyls =
                          matterText
                            & Pron.unInputLexemes
                            & Chinese.pronunciation dictsChinese
                            & Pron.addIndexes
                    x@MatterPicture{} -> [x]
                    x -> errorShow $ "pagesHTML: unsupported Matter: " <> show x
        pageMatches <- forM (matchesSyls <&> matchMatters & List.transpose) \matters ->
          Random.shuffleM matters
        -- return matters
        return page{pageMatches = pageMatches & List.transpose <&> Match}
  return $ Blaze.renderMarkupBuilder do
    HTML.docTypeHtml do
      HTML.head do
        HTML.title $ title & HTML.toHtml
        forM_
          ( [ "styles/Paper.css"
            , "styles/Rosetta/Common.css"
            , "styles/Rosetta/Matching.css"
            ]
              & list
          )
          \cssFile ->
            HTML.link
              ! HA.rel "stylesheet"
              ! HA.type_ "text/css"
              ! HA.href (dataPath </> cssFile & toValue)
        -- styleCSS $ cssPrintPage pageOrientation pageSize
        HTML.styleCSS $ pagesUnchunked & pagesDifficulties & difficultyCSS
      HTML.body do
        forM_ pagesListShuffled \pages -> do
          "\n"
          forM_ pages \page -> do
            HTML.section
            ! classes
              [ "rosetta-matching"
              , "A4"
              , "sheet"
              , page & pageOrientation & HTML.cssPageOrientation
              ]
            ! styles
              [ "size" :=
                  List.unwords
                    [ page & pageSize & HTML.cssPageSize
                    , page & pageOrientation & HTML.cssPageOrientation
                    ]
              ]
            $ do
              "\n"
              let matchColumns = page & pageMatches & foldMap (matchMatters >>> List.length >>> Max) & getMax
              let matchRows = page & pageMatches & List.length
              HTML.div
                ! classes ["matches"]
                ! styles
                  [ "grid-template-columns" := "1em 1fr" & List.replicate matchColumns & List.unwords
                  , "grid-template-rows" := "2cm" & List.replicate matchRows & List.unwords
                  ]
                $ do
                  let pageMatchNum = page & pageMatches & List.length
                  forM_ (page & pageMatches & ol0) \(matchIdx :: Int, match) -> do
                    "\n"
                    -- when (matchIdx /= 0) do
                    --   forM_ (match & matchMatters) \_matter -> do
                    --     HTML.div ! classes ["match-links"] $ ""
                    --     HTML.div ! classes ["match-links"] $ ""
                    HTML.div
                      ! classes ["match-alternatives"]
                      $ do
                        forM_ (match & matchMatters & ol0) \(matterIdx :: Int, matter) -> do
                          let langClass =
                                matter & \case
                                  MatterPicture{} -> []
                                  MatterSyls{matterLangue} -> ["lang-model", "lang-" <> className matterLangue]
                                  MatterSound{matterLangue} -> ["lang-" <> className matterLangue]
                                  x -> errorShow x
                          if matterIdx == 0
                            then do
                              HTML.div
                                ! classes ["match-anchor", "match-anchor-numbered"]
                                $ do
                                  HTML.span $
                                    ["➀", "➁", "➂", "➃", "➄", "➅ ", "➆ ", "➇ ", "➈ ", "➉"]
                                      & (List.!? matchIdx)
                                      & fromMaybe "◯︎"
                            else do
                              HTML.div
                                ! classes ["match-anchor"]
                                $ do
                                  HTML.span "◯︎"
                          HTML.div
                            ! classes (["match-matter"] <> langClass)
                            $ do
                              case matter of
                                MatterSyls{matterSyls} -> do
                                  forM_ matterSyls \word -> do
                                    HTML.div ! classes ["sentence-horiz"] $ do
                                      forM_ word \syl -> do
                                        forM_ (syl & Pron.sylText & Text.unpack) \pronChar -> do
                                          let uniScript = pronChar & Char.unicodeBlock & fromMaybe (UnicodeBlockLatin UnicodeBlockLatin_Basic)
                                          HTML.span
                                            ! classes
                                              [ "script-" <> className uniScript
                                              ]
                                            $ do
                                              pronChar & HTML.toHtml
                                MatterSound{matterSyls} -> do
                                  forM_ matterSyls \word -> do
                                    HTML.div ! classes ["sentence-horiz"] $ do
                                      forM_ word \syl -> do
                                        let sylTextLength = syl & Pron.sylText & Text.length
                                        HTML.div
                                          ! classes
                                            [ "sentence-syllable"
                                            ]
                                          ! styles
                                            [ "grid-template-columns" :=
                                                "repeat("
                                                  <> (syl & Pron.sylText & Text.length & show)
                                                  <> ",auto)"
                                            ]
                                          $ do
                                            let sylSoundParts = syl & Pron.sylSound & Text.words & \l -> if null l then [""] else l
                                            let sylSoundsSpanRest = sylTextLength - List.length sylSoundParts + 1
                                            forM_ (sylSoundParts & List.zip (sylSoundsSpanRest : List.repeat 1)) \(sylSoundSpan, sylSoundPart) -> do
                                              HTML.div
                                                ! classes
                                                  [ "sentence-cell"
                                                  , "pronunciation"
                                                  , "cell-" <> case syl of
                                                      Pron.Syl{sylSilent = True} -> "silent"
                                                      Pron.Syl{sylIndex = i} -> if i & even then "even" else "odd"
                                                  , if syl & Pron.sylDependsOnAfter then "cell-depends-on-after" else ""
                                                  , if syl & Pron.sylDependsOnBefore then "cell-depends-on-before" else ""
                                                  , if syl & Pron.sylDependsOnMeaning then "cell-depends-on-meaning" else ""
                                                  , if syl & Pron.sylSplit then "cell-split" else ""
                                                  ]
                                                ! styles
                                                  [ "grid-column-end" := "span " <> show sylSoundSpan
                                                  ]
                                                $ do
                                                  sylSoundPart & HTML.toHtml
                                MatterPicture{..} -> do
                                  HTML.div
                                    ! classes ["matter-picture"]
                                    ! styles ["height" := "2cm"]
                                    $ do
                                      unless (null matterPicture) do
                                        HTML.img
                                          ! styles matterPictureCSS
                                          ! HA.title (matterPicture & toValue)
                                          ! HA.src ("file://" <> dataPath </> "images" </> matterPicture & toValue)
                                x -> errorShow ("unsupported Matter" :: Text, x)

pagePortrait m =
  m
    { pageOrientation = PageOrientationPortrait
    }
pageLandscape m =
  m
    { pageOrientation = PageOrientationLandscape
    }

difficultyCSS :: Difficulties -> HTML.CSS
difficultyCSS diffs =
  [ [ [ [".lang-" <> show lang <> " " <> ".script-" <> className uniScript] :=
          [ "width" := difficultyCharWidth & HTML.toCSS
          , "height" := difficultyCharHeight & HTML.toCSS
          , "font-family" := difficultyFontFamily & HTML.toCSS
          , "font-size" := difficultyFontSize & HTML.toCSS
          , "font-variant" := difficultyFontVariant & HTML.toCSS
          , "color" := difficultyColor & HTML.toCSS
          , "line-height" := difficultyLineHeight & maybe "" HTML.toCSS
          ]
      , [ ".lang-" <> show lang <> ".sentence"
        ]
          := ["column-gap" := difficultyWordSpacing & HTML.toCSS]
      ]
    | (uniScript, Difficulty{..}) <- blocks & toList
    ]
  | (lang, blocks) <- diffs & Map.toList
  ]
    & mconcat
    & fromList
    & mconcat