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