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