src/Rosetta/Matching.hs

   1 {-# LANGUAGE OverloadedLists #-}
   2
   3 module Rosetta.Matching where
   4
   5 import Data.ByteString.Builder (Builder)
   6
   7 -- import Data.Char qualified as Char
   8 import Data.List qualified as List
   9 import Data.Map.Strict qualified as Map
  10
  11 -- import Data.Set qualified as Set
  12 import Data.Text qualified as Text
  13
  14 -- import Data.Text.Short qualified as ShortText
  15 import System.FilePath.Posix ((</>))
  16 import System.FilePath.Posix qualified as File
  17 import Text.Blaze
  18 import Text.Blaze.Html5 qualified as HTML
  19 import Text.Blaze.Html5.Attributes qualified as HA
  20 import Text.Blaze.Renderer.Utf8 qualified as Blaze
  21 import Prelude (div, even)
  22
  23 import Language
  24 import Language.Chinese (ChineseDict (..), ChineseDictEntries (..))
  25 import Language.Chinese qualified
  26 import Language.Chinese qualified as Chinese
  27 import Language.English qualified as English
  28 import Language.French qualified as French
  29 import Language.Pronunciation qualified as Pron
  30 import Paths_worksheets qualified as Self
  31 import Worksheets.Utils.Char as Char
  32 import Worksheets.Utils.HTML (Length, className, classes, cm, fr, styles)
  33 import Worksheets.Utils.HTML qualified as HTML
  34 import Worksheets.Utils.IPA qualified as IPA
  35 import Worksheets.Utils.Paper
  36 import Worksheets.Utils.Prelude
  37
  38 type Difficulties = Map Langue (Map UnicodeBlock Difficulty)
  39 data Difficulty = Difficulty
  40   { difficultyCharWidth :: Length
  41   , difficultyCharHeight :: Length
  42   , difficultyWordSpacing :: Length
  43   , difficultyFontSize :: Length
  44   , difficultyColor :: Text
  45   }
  46   deriving (Eq, Show, Generic)
  47 instance HasTypeDefault Difficulty where
  48   typeDefault =
  49     Difficulty
  50       { difficultyCharWidth = 1 & cm
  51       , difficultyCharHeight = 1 & cm
  52       , difficultyWordSpacing = 0.5 & cm
  53       , difficultyFontSize = 1 & cm
  54       , difficultyColor = "#000000"
  55       }
  56
  57 difficultyBig :: Char.UnicodeBlock -> Modifier Difficulty
  58 difficultyBig ub v = case ub of
  59   Char.UnicodeBlockLatin{} ->
  60     v
  61       { difficultyCharWidth = 1 & cm
  62       , difficultyCharHeight = 1 & cm
  63       , difficultyWordSpacing = 0.5 & cm
  64       , difficultyFontSize = 0.90 & cm
  65       }
  66   Char.UnicodeBlockCJK{} ->
  67     v
  68       { difficultyCharWidth = 1.50 & cm
  69       , difficultyCharHeight = 1.50 & cm
  70       , difficultyWordSpacing = 0.5 & cm
  71       , difficultyFontSize = 1.40 & cm
  72       }
  73   Char.UnicodeBlockHalfwidth_and_Fullwidth_Forms{} ->
  74     v
  75       { difficultyCharWidth = 1.50 & cm
  76       , difficultyCharHeight = 1.50 & cm
  77       , difficultyWordSpacing = 0.5 & cm
  78       , difficultyFontSize = 1.40 & cm
  79       }
  80   _ -> v
  81
  82 data Matter = Matter
  83   { matterText :: Pron.InputLexemes
  84   , matterLangue :: Langue
  85   }
  86   deriving (Eq, Show, Generic)
  87   deriving (HasTypeDefault) via (Generically Matter)
  88
  89 data Match = Match
  90   { matchMatters :: [Matter]
  91   , matchPicture :: File.FilePath
  92   , matchPictureCSS :: HTML.CSSBlock
  93   }
  94   deriving (Eq, Show, Generic)
  95
  96 instance HasTypeDefault Match where
  97   typeDefault =
  98     Match
  99       { matchPicture = ""
 100       , matchPictureCSS = mempty
 101       , matchMatters = []
 102       }
 103
 104 data Page = Page
 105   { pageMatches :: [Match]
 106   , pageMatchesNum :: Natural
 107   , pageSize :: PageSize
 108   , pageOrientation :: PageOrientation
 109   }
 110   deriving (Eq, Show, Generic)
 111 instance HasTypeDefault Page where
 112   typeDefault =
 113     Page
 114       { pageMatches = mempty
 115       , pageMatchesNum = 10
 116       , pageSize = typeDefault
 117       , pageOrientation = typeDefault
 118       }
 119
 120 data Pages = Pages
 121   { pagesList :: [Page]
 122   , pagesDifficulties :: Difficulties
 123   }
 124   deriving (Eq, Show, Generic)
 125 instance HasTypeDefault Pages where
 126   typeDefault =
 127     Pages
 128       { pagesList = []
 129       , pagesDifficulties =
 130           [ lang :=
 131               [ block := typeDefault
 132               | block <- Char.unicodeBlocks & toList
 133               ]
 134                 & Map.fromList
 135           | lang <- langues & toList
 136           ]
 137             & Map.fromList
 138       }
 139
 140 data Dicts = Dicts
 141   { dictsChinese :: Chinese.ChineseDict
 142   , dictsFrench :: Pron.Table
 143   , dictsEnglish :: Pron.Table
 144   }
 145
 146 pagesHTML :: Dicts -> Text -> Pages -> IO Builder
 147 pagesHTML Dicts{..} title Pages{..} = do
 148   -- FIXME: this absolute path is not portable out of my system
 149   dataPath <- Self.getDataDir <&> File.normalise
 150   return $ Blaze.renderMarkupBuilder do
 151     HTML.docTypeHtml do
 152       HTML.head do
 153         HTML.title $ title & HTML.toHtml
 154         forM_
 155           ( [ "styles/Paper.css"
 156             , "styles/Rosetta/Common.css"
 157             , "styles/Rosetta/Matching.css"
 158             ]
 159               & list
 160           )
 161           \cssFile ->
 162             HTML.link
 163               ! HA.rel "stylesheet"
 164               ! HA.type_ "text/css"
 165               ! HA.href (dataPath </> cssFile & toValue)
 166         -- styleCSS $ cssPrintPage pageOrientation pageSize
 167         HTML.styleCSS $ pagesDifficulties & difficultyCSS
 168       HTML.body do
 169         forM_ pagesList \page -> do
 170           "\n"
 171           forM_ (page & pageMatches & chunksOf (page & pageMatchesNum)) \pageMatch -> do
 172             HTML.section
 173             ! classes
 174               [ "rosetta-matching"
 175               , "A4"
 176               , "sheet"
 177               , page & pageOrientation & HTML.cssPageOrientation
 178               ]
 179             ! styles
 180               [ "size" :=
 181                   List.unwords
 182                     [ page & pageSize & HTML.cssPageSize
 183                     , page & pageOrientation & HTML.cssPageOrientation
 184                     ]
 185               ]
 186             $ do
 187               "\n"
 188               let matchColumns = pageMatch & foldMap (matchMatters >>> List.length >>> Max) & getMax
 189               let pageColumns = pageMatch & List.length
 190               HTML.div
 191                 ! classes ["matches"]
 192                 ! styles ["grid-template-columns" := "1fr" <> mconcat (List.replicate (max 0 (2 * (matchColumns - 1) + 1)) " 2em 1fr 2em 1fr")]
 193                 $ do
 194                   let pageMatchNum = pageMatch & List.length
 195                   forM_ (pageMatch & ol0) \(matchIdx :: Int, match) -> do
 196                     let commonStyles =
 197                           [ "grid-row-start" := show (pageColumns - matchIdx + 1)
 198                           , "grid-row-end" := show (pageColumns - matchIdx + 1)
 199                           ]
 200                     let
 201                       matchAnchor c =
 202                         HTML.div
 203                           ! classes ["match-anchor"]
 204                           ! styles commonStyles
 205                           $ do
 206                             HTML.span c
 207                       matchLinks = do
 208                         matchAnchor "▷"
 209                         HTML.div
 210                           ! classes ["match-links"]
 211                           ! styles commonStyles
 212                           $ ""
 213                         matchAnchor "◁"
 214                     "\n"
 215                     forM_ (match & matchMatters & ol1) \(matterIdx :: Natural, matter) -> do
 216                       when (matterIdx /= 1) do
 217                         matchLinks
 218                       let words :: [[Either Char Pron.Pron]] =
 219                             case matter & matterLangue of
 220                               LangueAnglais ->
 221                                 matter
 222                                   & matterText
 223                                   & Pron.unInputLexemes
 224                                   & Pron.runParser dictsEnglish
 225                                   & either errorShow id
 226                                   & Pron.words
 227                               LangueFrançais ->
 228                                 matter
 229                                   & matterText
 230                                   & Pron.unInputLexemes
 231                                   & Pron.runParser dictsFrench
 232                                   & either errorShow id
 233                                   & Pron.words
 234                               LangueMandarin ->
 235                                 matter
 236                                   & matterText
 237                                   & Pron.unInputLexemes
 238                                   & Chinese.pronunciation dictsChinese
 239                               _ -> errorShow ("matterLangue unsupported" :: Text, matter & matterLangue)
 240                       HTML.div
 241                         ! classes
 242                           [ "match-matter"
 243                           , "lang-" <> className (matter & matterLangue)
 244                           ]
 245                         ! styles commonStyles
 246                         $ do
 247                           forM_ (words & Pron.addIndexes) \word -> do
 248                             HTML.div ! classes ["sentence-horiz"] $ do
 249                               forM_ word \syl@Pron.Syl{..} -> do
 250                                 let sylTextLength = sylText & Text.length
 251                                 HTML.div
 252                                   ! classes
 253                                     [ "sentence-syllable"
 254                                     ]
 255                                   ! styles
 256                                     [ "grid-template-columns" :=
 257                                         "repeat("
 258                                           <> (sylText & Text.length & show)
 259                                           <> ",auto)"
 260                                     ]
 261                                   $ do
 262                                     let sylSoundParts = sylSound & Text.words & \l -> if null l then [""] else l
 263                                     let sylSoundsSpanRest = sylTextLength - List.length sylSoundParts + 1
 264                                     forM_ (sylSoundParts & List.zip (sylSoundsSpanRest : List.repeat 1)) \(sylSoundSpan, sylSoundPart) -> do
 265                                       HTML.div
 266                                         ! classes
 267                                           [ "sentence-cell"
 268                                           , "pronunciation"
 269                                           , "cell-" <> case syl of
 270                                               Pron.Syl{sylSilent = True} -> "silent"
 271                                               Pron.Syl{sylIndex = i} -> if i & even then "even" else "odd"
 272                                           , if sylDependsOnAfter then "cell-depends-on-after" else ""
 273                                           , if sylDependsOnBefore then "cell-depends-on-before" else ""
 274                                           , if sylDependsOnMeaning then "cell-depends-on-meaning" else ""
 275                                           , if sylSplit then "cell-split" else ""
 276                                           ]
 277                                         ! styles
 278                                           ( [ "grid-column-end" := "span " <> show sylSoundSpan
 279                                             ]
 280                                               <> commonStyles
 281                                           )
 282                                         $ do
 283                                           sylSoundPart & HTML.toHtml
 284                       matchLinks
 285                       HTML.div
 286                         ! classes
 287                           [ "match-matter"
 288                           , "lang-" <> className (matter & matterLangue)
 289                           ]
 290                         ! styles commonStyles
 291                         $ do
 292                           forM_ (words & Pron.addIndexes) \word -> do
 293                             HTML.div ! classes ["sentence-horiz"] $ do
 294                               forM_ word \syl -> do
 295                                 forM_ (syl & Pron.sylText & Text.unpack) \pronChar -> do
 296                                   let uniScript = pronChar & Char.unicodeBlock & fromMaybe (UnicodeBlockLatin UnicodeBlockLatin_Basic)
 297                                   HTML.span
 298                                     ! classes
 299                                       [ "sentence-cell"
 300                                       , "model"
 301                                       , "script-" <> className uniScript
 302                                       ]
 303                                     $ do
 304                                       HTML.span ! classes ["cell"] $ do
 305                                         pronChar & HTML.toHtml
 306
 307 pagePortrait m =
 308   m
 309     { pageOrientation = PageOrientationPortrait
 310     }
 311 pageLandscape m =
 312   m
 313     { pageOrientation = PageOrientationLandscape
 314     }
 315
 316 difficultyCSS :: Difficulties -> HTML.CSS
 317 difficultyCSS diffs =
 318   [ [ [ [".lang-" <> show lang <> " " <> ".script-" <> className uniScript] :=
 319           [ "width" := difficultyCharWidth & HTML.toCSS
 320           , "height" := difficultyCharHeight & HTML.toCSS
 321           , "font-size" := difficultyFontSize & HTML.toCSS
 322           , "color" := difficultyColor & HTML.toCSS
 323           ]
 324       , [ ".lang-" <> show lang <> ".sentence"
 325         ]
 326           := ["column-gap" := difficultyWordSpacing & HTML.toCSS]
 327       ]
 328     | (uniScript, Difficulty{..}) <- blocks & toList
 329     ]
 330   | (lang, blocks) <- diffs & Map.toList
 331   ]
 332     & mconcat
 333     & fromList
 334     & mconcat