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