{-# OPTIONS_GHC -threaded -rtsopts #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns, FlexibleContexts #-}
-- |
-- Module : Phonetic.Languages.General.GetTextualInfo
-- Copyright : (c) OleksandrZhabenko 2020-2021
-- License : MIT
-- Stability : Experimental
-- Maintainer : olexandr543@yahoo.com
--
-- Library module that contains functions used by the propertiesTextG3
-- executable.
-- Is rewritten from the Phonetic.Languages.GetTextualInfo module from the
-- @phonetic-languages-simplified-examples-array@ package.
module Phonetic.Languages.General.GetTextualInfo (
generalProc
, linesFromArgs1
, linesFromArgsG
, getData3
, process1Line
) where
import Data.SubG hiding (takeWhile,dropWhile)
import System.IO
import Control.Concurrent
import Control.Exception
import Control.Parallel.Strategies
import Data.Maybe (fromMaybe)
import Data.List (sort)
import Text.Read (readMaybe)
import GHC.Arr
import Data.Phonetic.Languages.Base
import Data.Phonetic.Languages.PrepareText
import Numeric (showFFloat)
import Phonetic.Languages.Filters
import Data.Char (isAlpha)
import Data.Statistics.RulesIntervalsPlus
import Data.MinMax.Preconditions
import Phonetic.Languages.Array.General.PropertiesSyllablesG2
import Phonetic.Languages.Simplified.StrictVG.Base
import Phonetic.Languages.Permutations.Arr
import Phonetic.Languages.Simplified.DataG.Base
import Phonetic.Languages.Simplified.Array.General.FuncRep2RelatedG2
import Languages.UniquenessPeriods.Array.Constraints.Encoded
import Phonetic.Languages.General.SimpleConstraints
import Phonetic.Languages.General.Common
import Data.Phonetic.Languages.Base
import Data.Phonetic.Languages.Syllables
generalProc
:: GWritingSystemPRPLX
-> [(Char,Char)]
-> CharPhoneticClassification
-> SegmentRulesG
-> (Double -> String -> ([[[PRS]]] -> [[Double]]))
-> [([[[PRS]]] -> [[Double]])]
-> Concatenations
-> String
-> String
-> String
-> Bool
-> [String]
-> [String]
-> Coeffs2
-> FilePath
-> String
-> Int
-> Int
-> String
-> IO ()
generalProc wrs ks arr gs h rs ysss xs js vs lstW multiples2 lInes coeffs file gzS printLine toOneLine choice
| null lInes = do
contents <- readFile file
let !flines = fLines ysss xs js vs toOneLine contents
getData3 wrs ks arr gs js vs h rs lstW coeffs (getIntervalsNS lstW gzS flines) printLine choice multiples2 flines
| otherwise = do
contents <- readFile file
let !flines = fLines ysss xs js vs toOneLine . unlines . linesFromArgsG lInes . fLines ysss xs js vs 0 $ contents
getData3 wrs ks arr gs js vs h rs lstW coeffs (getIntervalsNS lstW gzS flines) printLine choice multiples2 flines
linesFromArgs1
:: Int
-> String
-> [String]
-> [String]
linesFromArgs1 n xs yss =
let (!ys,!zs) = (\(x,z) -> (x, drop 1 z)) . break (== ':') $ xs
!ts = sort . map (min n . abs) $ [fromMaybe 1 (readMaybe ys::Maybe Int), fromMaybe n (readMaybe zs::Maybe Int)] in
drop (head ts - 1) . take (last ts) $ yss
linesFromArgsG :: [String] -> [String] -> [String]
linesFromArgsG xss yss = let n = length yss in concatMap (\ts -> linesFromArgs1 n ts yss) xss
getData3
:: GWritingSystemPRPLX
-> [(Char,Char)]
-> CharPhoneticClassification
-> SegmentRulesG
-> String
-> String
-> (Double -> String -> ([[[PRS]]] -> [[Double]]))
-> [([[[PRS]]] -> [[Double]])]
-> Bool
-> Coeffs2
-> Int
-> Int
-> String
-> [String]
-> [String]
-> IO ()
getData3 wrs ks arr gs js vs h rs lstW coeffs gz printLine choice multiples3 zss = let !permsV4 = genPermutationsArrL in putStrLn (replicate (length multiples3 + 1) '\t' `mappend` show gz) >> mapM_ (process1Line wrs ks arr gs js vs h rs lstW coeffs gz printLine choice multiples3 permsV4) zss
process1Line
:: GWritingSystemPRPLX
-> [(Char,Char)]
-> CharPhoneticClassification
-> SegmentRulesG
-> String
-> String
-> (Double -> String -> ([[[PRS]]] -> [[Double]]))
-> [([[[PRS]]] -> [[Double]])]
-> Bool
-> Coeffs2
-> Int
-> Int
-> String
-> [String]
-> Array Int [Array Int Int]
-> String
-> IO ()
process1Line wrs ks arr gs js vs h qs lstW coeffs gz printLine choice multiples4 !permsV50 v
| null multiples4 = bracket (do {
myThread <- forkIO (do
let !v2 = words v
!l2 = length v2 - 2
if l2 >= (if lstW then 1 else 0) then do
let !permsV5 = decodeConstraint1 (fromMaybe (E 1) . readMaybeECG (l2 + 1) . showB (l2 + 2) $ lstW) .
unsafeAt permsV50 $ l2 -- wrs ks arr gs js vs id h coeffs rs choice
((!minE,!maxE),!data2) = runEval (parTuple2 rpar rpar (minMax11C . map (toTransPropertiesF' (chooseMax wrs ks arr gs js vs id h coeffs qs choice )) .
uniquenessVariants2GNBL ' ' id id id permsV5 $ v2, toTransPropertiesF' (chooseMax wrs ks arr gs js vs id h coeffs qs choice) . unwords . subG (' ':js `mappend` vs) $ v))
(!wordsN,!intervalN) = (l2 + 2, intervalNRealFrac minE maxE gz data2)
!ratio = if maxE == 0.0 then 0.0 else 2.0 * data2 / (minE + maxE)
hPutStr stdout . showFFloat (precChoice choice) minE $ "\t"
hPutStr stdout . showFFloat (precChoice choice) data2 $ "\t"
hPutStr stdout . showFFloat (precChoice choice) maxE $ "\t"
hPutStr stdout . showFFloat (Just 4) (data2 / minE) $ "\t"
hPutStr stdout . showFFloat (Just 4) (maxE / minE) $ "\t"
hPutStr stdout . showFFloat (Just 4) (maxE / data2) $ "\t"
hPutStr stdout . showFFloat (Just 8) ratio $ "\t"
hPutStr stdout ('\t':show (wordsN::Int))
hPutStr stdout ('\t':show (intervalN::Int))
hPutStrLn stdout (if printLine == 1 then '\t':v else "")
else putStrLn (replicate (length multiples4) '\t' ++ if printLine == 1 then '\t':v else ""))
; return myThread }) (killThread) (\_ -> putStr "")
| otherwise = bracket (do {
myThread <- forkIO (do
let !v2 = words v
!l2 = length v2 - 2
if l2 >= (if lstW then 1 else 0) then do
let !permsV5 = decodeConstraint1 (fromMaybe (E 1) . readMaybeECG (l2 + 1) . showB (l2 + 2) $ lstW) .
unsafeAt permsV50 $ l2 -- wrs ks arr gs js vs id h coeffs rs choice
rs = parMap rpar (\choiceMMs -> (minMax11C .
map (toTransPropertiesF' (chooseMax wrs ks arr gs js vs id h coeffs qs choiceMMs)) .
uniquenessVariants2GNBL ' ' id id id permsV5 $ v2,
toTransPropertiesF' (chooseMax wrs ks arr gs js vs id h coeffs qs choiceMMs) . unwords .
subG (' ':js `mappend` vs) $ v,gz)) multiples4
(!wordsN,!intervalNs) = (l2 + 2, map (\((!x,!y),!z,!t) -> intervalNRealFrac x y t z) rs)
in do
hPutStr stdout (show (wordsN::Int))
mapM_ (\i -> hPutStr stdout ('\t':show (i::Int))) intervalNs
hPutStrLn stdout (if printLine == 1 then '\t':v else "")
else putStrLn (replicate (length multiples4) '\t' ++ if printLine == 1 then '\t':v else ""))
; return myThread }) (killThread) (\_ -> putStr "")