{-# OPTIONS_GHC -threaded -rtsopts #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns #-}
-- |
-- Module : Phonetic.Languages.General.Simple
-- Copyright : (c) OleksandrZhabenko 2020-2021
-- License : MIT
-- Stability : Experimental
-- Maintainer : olexandr543@yahoo.com
--
-- The library functions for the lineVariantsG3 executable. Is rewritten from the Phonetic.Languages.Simple module from the
-- @phonetic-languages-simplified-examples-array@ package.
module Phonetic.Languages.General.Simple where
import Phonetic.Languages.General.Parsing
import Numeric
import Languages.UniquenessPeriods.Array.Constraints.Encoded (decodeLConstraints,readMaybeECG)
import GHC.Arr
import Phonetic.Languages.Simplified.DataG.Base
import Phonetic.Languages.Array.General.PropertiesSyllablesG2
import Phonetic.Languages.Filters (unsafeSwapVecIWithMaxI)
import Phonetic.Languages.Simplified.StrictVG.Base
import Data.Phonetic.Languages.Base
import Data.Phonetic.Languages.PrepareText
import Data.Char (isDigit,isAlpha)
import qualified Data.List as L (span,sort,zip4,isPrefixOf,nub)
import Phonetic.Languages.Simplified.Array.General.FuncRep2RelatedG2
import Phonetic.Languages.Permutations.Arr
import Data.SubG hiding (takeWhile,dropWhile)
import Data.Maybe
import Data.MinMax.Preconditions
import Text.Read (readMaybe)
import Phonetic.Languages.General.DeEnCoding
import Phonetic.Languages.General.SimpleConstraints
import Phonetic.Languages.General.Common
import Data.Phonetic.Languages.Syllables
forMultiplePropertiesF :: [String] -> [(String,[String])]
forMultiplePropertiesF (xs:xss)
| any isAlpha xs = (xs,yss):forMultiplePropertiesF zss
| otherwise = []
where l = length . takeWhile (all isDigit) $ xss
(yss,zss) = splitAt l xss
forMultiplePropertiesF _ = []
-- | Is used to do general processment.
generalProc2G
:: GWritingSystemPRPLX
-> [(Char,Char)]
-> CharPhoneticClassification
-> SegmentRulesG
-> String
-> String
-> (Double -> String -> ([[[PRS]]] -> [[Double]]))
-> [([[[PRS]]] -> [[Double]])]
-> Concatenations
-> String
-> FilePath
-> Bool
-> Bool
-> [String]
-> Coeffs2
-> [String]
-> Bool
-> IO ()
generalProc2G wrs ks arr gs js vs h qs ysss ws toFile1 interactive jstL0 args0 coeffs args lstW2
| variations args = do
let !zsss = transformToVariations args
print zsss
variantsG <- mapM (\xss -> generalProc2 wrs ks arr gs js vs h qs ysss ws interactive jstL0 args0 coeffs xss lstW2) zsss
interactivePrintResult id variantsG >>= \rs ->
case toFile1 of
"" -> return ()
~fileName -> appendFile fileName (rs `mappend` newLineEnding)
| otherwise = generalProc2 wrs ks arr gs js vs h qs ysss ws interactive jstL0 args0 coeffs args lstW2 >>= \rs ->
case toFile1 of
"" -> return ()
~fileName -> appendFile fileName (rs `mappend` newLineEnding)
-- |
generalProc2
:: GWritingSystemPRPLX
-> [(Char,Char)]
-> CharPhoneticClassification
-> SegmentRulesG
-> String
-> String
-> (Double -> String -> ([[[PRS]]] -> [[Double]]))
-> [([[[PRS]]] -> [[Double]])]
-> Concatenations
-> String
-> Bool
-> Bool
-> [String]
-> Coeffs2
-> [String]
-> Bool
-> IO String
generalProc2 wrs ks arr gs js vs h qs ysss ws interactive jstL0 args0 coeffs args lstW2 = do
let !argMss = take 5 . filter (not . null) . forMultiplePropertiesF . drop 1 . dropWhile (/= "+M") . takeWhile (/= "-M") $ args0
if null argMss then do
let (!numericArgs,!textualArgs) = L.span (all isDigit) $ args
!xs = concat . take 1 . fLines ysss ws js vs 0 . unwords . drop 1 $ textualArgs
!l = length . words $ xs
!argCs = catMaybes (fmap (readMaybeECG (l - 1)) . (showB l lstW2:) . drop 1 . dropWhile (/= "+A") .
takeWhile (/= "-A") $ args0)
!arg0 = fromMaybe 1 $ (readMaybe (concat . take 1 $ numericArgs)::Maybe Int)
!numberI = fromMaybe 1 $ (readMaybe (concat . drop 1 . take 2 $ numericArgs)::Maybe Int)
!choice = concat . take 1 $ textualArgs
!intervalNmbrs = (\zs -> if null zs then [numberI] else L.nub zs) . L.sort . filter (<= numberI) .
map (\t -> fromMaybe numberI $ (readMaybe t::Maybe Int)) . drop 2 $ numericArgs
if compare l 2 == LT then let !frep20 = chooseMax wrs ks arr gs js vs id h coeffs qs choice in let !wwss = (:[]) . toResultR frep20 $ xs in
if interactive then interactivePrintResult line wwss else print1el jstL0 choice wwss
else do
let !subs = subG (' ':js `mappend` vs) xs
if null argCs then let !perms = genPermutationsL l in do
temp <- generalProcMs wrs ks arr gs js vs h qs coeffs perms subs (intervalNmbrs, arg0, numberI, choice)
if interactive then interactivePrintResult line temp else print1el jstL0 choice temp
else do
correct <- printWarning xs
if correct == "n" then putStrLn (messageInfo 1) >> return "" -- for the multiple variations mode (with curly brackets and slash in the text) the program does not stop here, but the variation is made empty and is proposed further as a variant.
else let !perms = decodeLConstraints argCs . genPermutationsL $ l in do
temp <- generalProcMs wrs ks arr gs js vs h qs coeffs perms subs (intervalNmbrs, arg0, numberI, choice)
if interactive then interactivePrintResult line temp else print1el jstL0 choice temp
else do
let !choices = map fst argMss
!numericArgss = map snd argMss
!arg0s = map (\ts -> fromMaybe 1 $ (readMaybe (concat . take 1 $ ts)::Maybe Int)) numericArgss
!numberIs = map (\ts -> fromMaybe 1 $ (readMaybe (concat . drop 1 . take 2 $ ts)::Maybe Int)) numericArgss
!intervalNmbrss = map (\us -> let !numberI = fromMaybe 1 $ (readMaybe (concat . drop 1 . take 2 $ us)::Maybe Int) in
(\zs -> if null zs then [numberI] else L.nub zs) . L.sort . filter (<= numberI) .
map (\t -> fromMaybe numberI $ (readMaybe t::Maybe Int)) . drop 2 $ us) $ numericArgss
!argsZipped = L.zip4 intervalNmbrss arg0s numberIs choices
!xs = concat . take 1 . fLines ysss ws js vs 0 . unwords $ args
!l = length . words $ xs
!argCs = catMaybes (fmap (readMaybeECG (l - 1)) . (showB l lstW2:) . drop 1 . dropWhile (/= "+A") .
takeWhile (/= "-A") $ args0)
if compare l 2 == LT then let !frep20 = chooseMax wrs ks arr gs js vs id h coeffs qs (concat . take 1 $ choices) in
let !wwss = (:[]) . toResultR frep20 $ xs in
if interactive then interactivePrintResult line wwss
else print1el jstL0 (concat . take 1 $ choices) wwss
else do
let !subs = subG (' ':js `mappend` vs) xs
if null argCs then let !perms = genPermutationsL l in generalProcMMs wrs ks arr gs js vs h qs interactive coeffs argsZipped perms subs
else do
correct <- printWarning xs
if correct == "n" then putStrLn (messageInfo 1) >> return "" -- for the multiple variations mode (with curly brackets and slash in the text) the program does not stop here, but the variation is made empty and is proposed further as a variant.
else let !perms = decodeLConstraints argCs . genPermutationsL $ l in
generalProcMMs wrs ks arr gs js vs h qs interactive coeffs argsZipped perms subs
{-|
Function provides message information.
-}
messageInfo :: Int -> String
messageInfo n
| n == 1 = "You stopped the program, please, if needed, run it again with better arguments. "
| n == 2 = "Please, specify the variant which you would like to become the resulting string by its number. "
| n == 3 = "Please, check whether the line below corresponds and is consistent with the constraints you have specified between the +A and -A options. Check also whether you have specified the \"++B\" or \"++BL\" option(s). If it is inconsistent then enter further \"n\", press Enter and then run the program again with better arguments. " `mappend` newLineEnding `mappend` "If the line is consistent with your input between +A and -A then just press Enter to proceed further. " `mappend` newLineEnding
| n == 4 = "No data has been specified to control the computation process. "
| otherwise = "You have specified just one variant of the properties. "
-- |
interactivePrintResult :: (a -> String) -> [a] -> IO String
interactivePrintResult f xss
| null xss = putStrLn "" >> return ""
| otherwise = do
let !datas = map (\(idx,str) -> show idx `mappend` ('\t' : str)) . trans232 . map f $ xss
mapM_ putStrLn datas
putStrLn ""
putStrLn . messageInfo $ 2
number <- getLine
let !lineRes = concat . filter ((number `mappend` "\t")`L.isPrefixOf`) $ datas
!ts = drop 1 . dropWhile (/= '\t') $ lineRes
putStrLn ts >> return ts
printWarning :: String -> IO String
printWarning xs = do
putStrLn . messageInfo $ 3
putStrLn xs
getLine
generalProcMs
:: GWritingSystemPRPLX
-> [(Char,Char)]
-> CharPhoneticClassification
-> SegmentRulesG
-> String
-> String
-> (Double -> String -> ([[[PRS]]] -> [[Double]]))
-> [([[[PRS]]] -> [[Double]])]
-> Coeffs2
-> [Array Int Int]
-> [String]
-> ([Int],Int,Int,String)
-> IO [Result [] Char Double Double]
generalProcMs wrs ks arr gs js vs h qs coeffs perms subs (intervalNmbrs, arg0, numberI, choice) = do
if compare numberI 2 == LT then let !frep2 = chooseMax wrs ks arr gs js vs id h coeffs qs choice in return . fst . maximumGroupsClassificationR arg0 .
map (toResultR frep2) . uniquenessVariants2GNBL ' ' id id id perms $ subs
else do
let !variants1 = uniquenessVariants2GNBL ' ' id id id perms subs
!frep20 = chooseMax wrs ks arr gs js vs id h coeffs qs choice
(!minE,!maxE) = minMax11C . map (toPropertiesF' frep20) $ variants1
!frep2 = chooseMax wrs ks arr gs js vs (unsafeSwapVecIWithMaxI minE maxE numberI intervalNmbrs) h coeffs qs choice
return . fst . maximumGroupsClassificationR arg0 . map (toResultR frep2) $ variants1
-- |
generalProcMMs
:: GWritingSystemPRPLX
-> [(Char,Char)]
-> CharPhoneticClassification
-> SegmentRulesG
-> String
-> String
-> (Double -> String -> ([[[PRS]]] -> [[Double]]))
-> [([[[PRS]]] -> [[Double]])]
-> Bool
-> Coeffs2
-> [([Int],Int,Int,String)]
-> [Array Int Int]
-> [String]
-> IO String
generalProcMMs wrs ks arr gs js vs h qs interactiveMM coeffs rs perms subs =
case length rs of
0 -> putStrLn (messageInfo 4) >> return ""
1 -> putStrLn (messageInfo 5) >> do
temp <- generalProcMs wrs ks arr gs js vs h qs coeffs perms subs (head rs)
finalProc interactiveMM line temp
_ -> do
genVariants <- mapM (generalProcMs wrs ks arr gs js vs h qs coeffs perms subs) rs
finalProc interactiveMM id . foldlI . map (map line) $ genVariants
foldlI :: [[String]] -> [String]
foldlI (xs:ys:xss) = foldlI (intersectInterResults xs ys : xss)
foldlI (xs:_) = xs
foldlI _ = []
-- |
finalProc :: Bool -> (a -> String) -> [a] -> IO String
finalProc bool f xss = if bool then interactivePrintResult f xss else putStrLn ts >> return ts
where ts = concatMap (\t -> f t `mappend` newLineEnding) xss
-- |
print1el :: Bool -> String -> [Result [] Char Double Double] -> IO String
print1el jstlines choice y
| jstlines == True = putStrLn us >> return us
| otherwise = putStrLn zs >> return zs
where !ch = precChoice choice
!us = concatMap (\ys -> line ys `mappend` newLineEnding) y
!zs = concatMap (\ys -> line ys `mappend` newLineEnding `mappend` showFFloat ch (propertiesF ys) (newLineEnding `mappend` showFFloat ch (transPropertiesF ys) newLineEnding)) y