<commit_before>{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Applicative
import Control.Exception
import Control.Monad
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Ord
import qualified Data.HashMap.Strict as HMS
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as DT
import qualified Data.Text.IO as DTI
import System.Environment
import System.FilePath
import System.IO.Error

import Cmn.KiloDeck
import GB1

prepPinyin :: DT.Text -> DT.Text
prepPinyin = DT.pack . f . DT.unpack
  where
    f [] = []
    f ('*':x) = f x
    f ('(':x) = f . drop 1 $ dropWhile (/= ')') x
    f ('[':x) = f . drop 1 $ dropWhile (/= ']') x
    f (';':_) = ""
    f (' ':_) = error "Pinyin cannot contain ' '!"
    f ('/':_) = error "Pinyin cannot contain '/'!"
    f ('\\':_) = error "Pinyin cannot contain '\\'!"
    f (c:x) = c : f x

prepGloss :: DT.Text -> DT.Text
prepGloss g =
    if partOfSpeech `elem`
        [ "ADJ", "ADV", "AUXV", "CONJ", "MEAS", "NOUN"
        , "NUM", "PREP", "PRON", "PRT", "VERB"
        ]
      then partOfSpeech `DT.append` rest
      else error $ "Unknown part-of-speech: " ++ show partOfSpeech
  where
    (p1, rest) = DT.breakOn ":" g
    fixP "ADP" = "PREP"
    fixP "DET" = "PRON"
    fixP x = x
    partOfSpeech = fixP p1

kiloPrepPinyin :: KiloDeck -> KiloDeck
kiloPrepPinyin = map (onKLPinyin prepPinyin)

prefNum :: Int -> DT.Text
prefNum n = DT.pack ('#' : show n ++ ":")

kiloPrepPinyinUniq :: KiloDeck -> KiloDeck
kiloPrepPinyinUniq = snd . foldl' f (Map.empty, [])
  where
    f (!seen, !kDeck) kLine =
        ( Map.insertWith (+) pinyin (1 :: Int) seen
        , kDeck ++ [kLine']
        )
      where
        pinyin = kLPinyin kLine
        kLine' = if DT.null pinyin then kLine else
            case Map.lookup pinyin seen of
              Just n -> kLine {
                kLPinyin = prefNum (n + 1) `DT.append` pinyin}
              _ -> kLine

kiloPrepGlossUniq :: KiloDeck -> KiloDeck
kiloPrepGlossUniq = snd . foldl' f (Map.empty, [])
  where
    f (!seen, !kDeck) kLine =
        ( Map.insertWith (+) gloss (1 :: Int) seen
        , kDeck ++ [kLine']
        )
      where
        gloss = prepGloss $ kLGloss kLine
        kLine' = kLine {
            kLGloss = if ":" `DT.isSuffixOf` gloss then gloss else
              case Map.lookup gloss seen of
                Just n -> prefNum (n + 1) `DT.append` gloss
                _ -> gloss
        }

kiloKillNums :: KiloLine -> KiloLine
kiloKillNums (KiloLine wd py gloss) =
    KiloLine wd (killNum py) (killNum gloss)

kiloPrep :: KiloDeck -> KiloDeck
kiloPrep =
    kiloPrepGlossUniq . kiloPrepPinyinUniq . kiloPrepPinyin .
    map kiloKillNums

growDeck :: Dict -> Int -> KiloDeck -> KiloDeck
growDeck _ 0 deck = deck
growDeck dict growSize deck = deck ++ deckNext
  where
    deckWordSet = Set.fromList $ map kLWord deck
    dictToDeck l = KiloLine (dlWord l) "" (dlPartOfSpeech l `DT.append` ":")
    deckNext = take growSize . map dictToDeck $
        filter (not . (`Set.member` deckWordSet) . dlWord) dict

intToDeckName :: Int -> FilePath
intToDeckName n = "mando-gloss-" ++ show n ++ "k.txt"

seqWhileJust :: [IO (Maybe a)] -> IO [a]
seqWhileJust [] = return []
seqWhileJust (x:xs) = do
    rMb <- x
    case rMb of
      Nothing -> return []
      Just r -> (r:) <$> seqWhileJust xs

loadDeckIfExists :: FilePath -> IO (Maybe KiloDeck)
loadDeckIfExists f = (Just <$> loadKiloDeck f) `catch` handleExists
  where
    handleExists e
      | isDoesNotExistError e = return Nothing
      | otherwise = throwIO e

loadDecks :: FilePath -> IO KiloDeck
loadDecks dir = concat <$>
    seqWhileJust (map (loadDeckIfExists . (dir </>) . intToDeckName) [1..])

writeDeck :: FilePath -> KiloDeck -> IO ()
writeDeck f = DTI.writeFile f . DT.unlines . map showKiloLine

writeDecks :: FilePath -> KiloDeck -> IO ()
writeDecks dir = zipWithM_
    (\n -> writeDeck (dir </> intToDeckName n)) [1..] . chunksOf 1000

sortDeck :: Dict -> KiloDeck -> KiloDeck
sortDeck dict =
    map snd . sortBy (flip $ comparing fst) .
    map (\x -> (fromJust $ HMS.lookup (kLWord x) wdToPos, x))
  where
    wdToPos = HMS.fromList $ map (\l -> (dlWord l, dlOccurs l)) dict

main :: IO ()
main = do
    let deckDir = "/home/danl/p/l/melang/data/cmn/kilo-deck"
        dictF = "/home/danl/p/l/melang/data/cmn/dict"
    args <- getArgs
    growSize <- return $ case args of
      [] -> 0
      [n] -> read n
      _ -> error $ "Unknown grow-size: " ++ show args
    dict <- readDict dictF
    deck <- kiloPrep . sortDeck dict . growDeck dict growSize <$>
        loadDecks deckDir
    mapM_ (DTI.putStrLn . showKiloLine) deck
    writeDecks deckDir deck<commit_msg>deepseq instead of printing<commit_after>{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Applicative
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Ord
import qualified Data.HashMap.Strict as HMS
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as DT
import qualified Data.Text.IO as DTI
import System.Environment
import System.FilePath
import System.IO.Error

import Cmn.KiloDeck
import GB1

prepPinyin :: DT.Text -> DT.Text
prepPinyin = DT.pack . f . DT.unpack
  where
    f [] = []
    f ('*':x) = f x
    f ('(':x) = f . drop 1 $ dropWhile (/= ')') x
    f ('[':x) = f . drop 1 $ dropWhile (/= ']') x
    f (';':_) = ""
    f (' ':_) = error "Pinyin cannot contain ' '!"
    f ('/':_) = error "Pinyin cannot contain '/'!"
    f ('\\':_) = error "Pinyin cannot contain '\\'!"
    f (c:x) = c : f x

prepGloss :: DT.Text -> DT.Text
prepGloss g =
    if partOfSpeech `elem`
        [ "ADJ", "ADV", "AUXV", "CONJ", "MEAS", "NOUN"
        , "NUM", "PREP", "PRON", "PRT", "VERB"
        ]
      then partOfSpeech `DT.append` rest
      else error $ "Unknown part-of-speech: " ++ show partOfSpeech
  where
    (p1, rest) = DT.breakOn ":" g
    fixP "ADP" = "PREP"
    fixP "DET" = "PRON"
    fixP x = x
    partOfSpeech = fixP p1

kiloPrepPinyin :: KiloDeck -> KiloDeck
kiloPrepPinyin = map (onKLPinyin prepPinyin)

prefNum :: Int -> DT.Text
prefNum n = DT.pack ('#' : show n ++ ":")

kiloPrepPinyinUniq :: KiloDeck -> KiloDeck
kiloPrepPinyinUniq = snd . foldl' f (Map.empty, [])
  where
    f (!seen, !kDeck) kLine =
        ( Map.insertWith (+) pinyin (1 :: Int) seen
        , kDeck ++ [kLine']
        )
      where
        pinyin = kLPinyin kLine
        kLine' = if DT.null pinyin then kLine else
            case Map.lookup pinyin seen of
              Just n -> kLine {
                kLPinyin = prefNum (n + 1) `DT.append` pinyin}
              _ -> kLine

kiloPrepGlossUniq :: KiloDeck -> KiloDeck
kiloPrepGlossUniq = snd . foldl' f (Map.empty, [])
  where
    f (!seen, !kDeck) kLine =
        ( Map.insertWith (+) gloss (1 :: Int) seen
        , kDeck ++ [kLine']
        )
      where
        gloss = prepGloss $ kLGloss kLine
        kLine' = kLine {
            kLGloss = if ":" `DT.isSuffixOf` gloss then gloss else
              case Map.lookup gloss seen of
                Just n -> prefNum (n + 1) `DT.append` gloss
                _ -> gloss
        }

kiloKillNums :: KiloLine -> KiloLine
kiloKillNums (KiloLine wd py gloss) =
    KiloLine wd (killNum py) (killNum gloss)

kiloPrep :: KiloDeck -> KiloDeck
kiloPrep =
    kiloPrepGlossUniq . kiloPrepPinyinUniq . kiloPrepPinyin .
    map kiloKillNums

growDeck :: Dict -> Int -> KiloDeck -> KiloDeck
growDeck _ 0 deck = deck
growDeck dict growSize deck = deck ++ deckNext
  where
    deckWordSet = Set.fromList $ map kLWord deck
    dictToDeck l = KiloLine (dlWord l) "" (dlPartOfSpeech l `DT.append` ":")
    deckNext = take growSize . map dictToDeck $
        filter (not . (`Set.member` deckWordSet) . dlWord) dict

intToDeckName :: Int -> FilePath
intToDeckName n = "mando-gloss-" ++ show n ++ "k.txt"

seqWhileJust :: [IO (Maybe a)] -> IO [a]
seqWhileJust [] = return []
seqWhileJust (x:xs) = do
    rMb <- x
    case rMb of
      Nothing -> return []
      Just r -> (r:) <$> seqWhileJust xs

loadDeckIfExists :: FilePath -> IO (Maybe KiloDeck)
loadDeckIfExists f = (Just <$> loadKiloDeck f) `catch` handleExists
  where
    handleExists e
      | isDoesNotExistError e = return Nothing
      | otherwise = throwIO e

loadDecks :: FilePath -> IO KiloDeck
loadDecks dir = concat <$>
    seqWhileJust (map (loadDeckIfExists . (dir </>) . intToDeckName) [1..])

writeDeck :: FilePath -> KiloDeck -> IO ()
writeDeck f = DTI.writeFile f . DT.unlines . map showKiloLine

writeDecks :: FilePath -> KiloDeck -> IO ()
writeDecks dir = zipWithM_
    (\n -> writeDeck (dir </> intToDeckName n)) [1..] . chunksOf 1000

sortDeck :: Dict -> KiloDeck -> KiloDeck
sortDeck dict =
    map snd . sortBy (flip $ comparing fst) .
    map (\x -> (fromJust $ HMS.lookup (kLWord x) wdToPos, x))
  where
    wdToPos = HMS.fromList $ map (\l -> (dlWord l, dlOccurs l)) dict

main :: IO ()
main = do
    let deckDir = "/home/danl/p/l/melang/data/cmn/kilo-deck"
        dictF = "/home/danl/p/l/melang/data/cmn/dict"
    args <- getArgs
    growSize <- return $ case args of
      [] -> 0
      [n] -> read n
      _ -> error $ "Unknown grow-size: " ++ show args
    dict <- readDict dictF
    deck <- kiloPrep . sortDeck dict . growDeck dict growSize <$>
        loadDecks deckDir
    writeDecks deckDir $!! deck
{'fraction_non_alphanumeric': 0.13431578947368422, 'fraction_numerical': 0.0035789473684210526, 'mean_word_length': 2.50978943479867, 'pattern_counts': {'":': 8, '<': 25, '<?xml version=': 0, '>': 81, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4859103', 'n_tokens_mistral': 3579, 'n_tokens_neox': 3462, 'n_words': 984}