diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -108,4 +108,15 @@ ## 0.12.0.0 -- 2022-09-13 -* Twelfth version. Moved the common functionality for coeffs to the phonetic-languages-basis package. Added new functionality to use diverse2GGL function. +* Twelfth version. Moved the common functionality for coeffs to the phonetic-languages-basis package. Added new functionality to use diverse2GGL function. + +## 0.13.0.0 -- 2023-03-02 + +* Thirteenth version. Switched to the NoImplicitPrelude extension. Some code deduplication. Updated + the dependencies boundaries to use the new functionality. + +## 0.13.1.0 -- 2023-03-15 + +* Thirteenth version revised A. Updated the dependecies boundaries so that to support the new +code deduplication for different implementations of PhLADiPreLiO. + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2021-2022 Oleksandr Zhabenko +Copyright (c) 2021-2023 Oleksandr Zhabenko Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/Phladiprelio/General/EmphasisG.hs b/Phladiprelio/General/EmphasisG.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/General/EmphasisG.hs @@ -0,0 +1,245 @@ +{-# OPTIONS_HADDOCK -show-extensions #-} +{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} + +-- | +-- Module : Phladiprelio.General.General.EmphasisG +-- Copyright : (c) Oleksandr Zhabenko 2020-2023 +-- License : MIT +-- Stability : Experimental +-- Maintainer : oleksandr.zhabenko@yahoo.com +-- +-- Some functionality for SaaW mode of operation for PhLADiPreLiO. +-- + +module Phladiprelio.General.EmphasisG where + +import GHC.Base +import GHC.Num ((+),(-)) +import GHC.Real (fromIntegral) +import Text.Show (Show (..)) +import Data.Tuple (fst,snd) +import GHC.List +import Data.List (words) +import Phladiprelio.General.Base +import Phladiprelio.General.Syllables +import GHC.Int +import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) +import Data.Char (toUpper) +import GHC.Arr +import Data.List (scanl',intersperse) +import CaseBi.Arr (getBFst',getBFstL',getBFstLSorted') +import Data.Lists.FLines (newLineEnding) +import Data.Traversable (traverse) +import Control.Applicative +import System.IO (stderr,hPutStr,getLine) + +data SyllWeightsG = SyG { + point :: ![PRS] + , order :: !Int8 -- Is intended to begin at -128 up to 127 (maximum 256 entries). + , weight :: !Double +} + +showFSG :: FlowSoundG -> String +showFSG = map charS +{-# INLINE showFSG #-} + +type FlowSoundG = [PRS] + +instance Show SyllWeightsG where + show (SyG ps i w) = showFSG ps `mappend` (' ':show i) `mappend` (' ':show w) `mappend` newLineEnding + +weightSyllablesIO :: [FlowSoundG] -> IO [SyllWeightsG] +weightSyllablesIO = traverse (\(i,xs) -> (\d1 -> (SyG xs i d1)) <$> weightSyllAIO False xs) . zip ([-128..127]::[Int8]) + +weightStringIO + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String + -> IO ([[FlowSoundG]],[SyllWeightsG],[[[Int8]]]) +weightStringIO wrs ks arr hs us vs xs = weightSyllablesIO fss >>= \zs -> pure (tsss, zs, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss) + where tsss = createSyllablesPL wrs ks arr hs us vs xs + fss = [ ts | tss <- tsss , ts <- tss ] + +weightStringNIO + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> Int + -> String + -> IO ([[FlowSoundG]],[[SyllWeightsG]],[[[Int8]]]) +weightStringNIO wrs ks arr hs us vs n xs = traverse (\_-> weightSyllablesIO fss) [1..n] >>= \zss -> pure (tsss, zss, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss) + where tsss = createSyllablesPL wrs ks arr hs us vs xs + fss = [ ts | tss <- tsss , ts <- tss ] + +weights2SyllableDurationsDArr :: [SyllWeightsG] -> Array Int (Int8,Double) +weights2SyllableDurationsDArr xs = listArray (0,l-1) . map (\(SyG _ i w) -> (i,w)) $ xs + where l = length xs + +weights2SyllableDurationsD :: [SyllWeightsG] -> [[[Int8]]] -> [[Double]] +weights2SyllableDurationsD xs = map (map (k (getBFst' (4.0, weights2SyllableDurationsDArr xs)))) + where k f = foldl' (\y x -> f x + y) 0 +{-# INLINE weights2SyllableDurationsD #-} + +helper1F :: [Int8] -> [[[Int8]]] +helper1F (x:y:ys) = map (:[]) [x..y-1]:helper1F (y:ys) +helper1F _ = [] + +weightSyllAIO :: Bool -> FlowSoundG -> IO Double +weightSyllAIO upper xs + | null xs = pure 4.0 + | otherwise = + (\d -> fromMaybe 4.0 (readMaybe d::Maybe Double)) <$> (hPutStr stderr ("? " `mappend` ((if upper then map toUpper else id) . showFSG $ xs) `mappend` " ") *> getLine) -- Well, definitely it should not be 'stderr' here, but 'stdout' gives some strange behaviour, probably related to optimizations or some strange 'Handle' behaviour. (?) + + +data ReadyForConstructionPL = StrG String | FSLG [[[Int8]]] deriving (Eq,Ord) + +showR :: ReadyForConstructionPL -> String +showR (StrG xs) = xs +showR (FSLG tsss) = show tsss + +isStr :: ReadyForConstructionPL -> Bool +isStr (StrG _) = True +isStr _ = False + +isFSL :: ReadyForConstructionPL -> Bool +isFSL (FSLG _) = True +isFSL _ = False + +fromReadyFCPLS :: ReadyForConstructionPL -> Maybe String +fromReadyFCPLS (StrG xs) = Just xs +fromReadyFCPLS _ = Nothing + +fromReadyFCPLF :: ReadyForConstructionPL -> Maybe [[[Int8]]] +fromReadyFCPLF (FSLG xsss) = Just xsss +fromReadyFCPLF _ = Nothing + +helper2F :: [b] -> [a] -> [c] -> [[d]] -> [([b],[a],[c])] +helper2F vs xs ys tss = let (us,ks,rs) = unzip3 . zip3 vs xs $ ys in + helper2F' us ks rs tss + where helper2F' us@(_:_) ks@(_:_) rs@(_:_) tss@(ts:wss) = + let l = length ts + (wws,vvs) = splitAt l us + (qs,ps) = splitAt l ks + (ns,ms) = splitAt l rs + in (wws,qs,ns):helper2F' vvs ps ms wss + helper2F' _ _ _ _ = [] + +convF1 + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String + -> [[FlowSoundG]] +convF1 wrs ks arr hs us vs xs + | null xs = [] + | otherwise = [ tss | tss <- createSyllablesPL wrs ks arr hs us vs xs ] + +convF3 + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String + -> [([String],[[Int8]],[FlowSoundG])] +convF3 wrs ks arr hs us vs xs + | null xs = [([],[],[])] + | otherwise = helper2F (concatMap (map showFSG) tsss) (map (:[]) ([-128..127]::[Int8])) [ ts | tss <- qss, ts <- tss ] qss + where tsss = createSyllablesPL wrs ks arr hs us vs xs + qss = [ tss | tss <- tsss ] + +convF3W + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String + -> [(String,[[Int8]])] +convF3W wrs ks arr hs us vs xs + | null xs = [([],[])] + | otherwise = zipWith (\(_,ys,_) ts -> (ts,ys)) (convF3 wrs ks arr hs us vs xs) . words $ xs + +convFI + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String + -> String + -> [[[Int8]]] +convFI wrs ks arr hs us vs ts = map f . words + where !f = getBFstL' [] (convF3W wrs ks arr hs us vs ts) + +convFSL + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String + -> ReadyForConstructionPL + -> String +convFSL wrs ps arr hs us vs ts r@(StrG xs) = concat . concat . intersperse [" "] . map (\(ks,_,_)-> ks) . convF3 wrs ps arr hs us vs $ xs + where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 wrs ps arr hs us vs $ ts +convFSL wrs ps arr hs us vs ts r@(FSLG tsss) = concat . concat . intersperse [" "] . map (map (getBFstLSorted' " " ks) ) $ tsss + where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 wrs ps arr hs us vs $ ts + ks = zip (concat . fst $ js) (concat . snd $ js) + +weightsString3IO + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> Bool + -> String + -> IO ([[FlowSoundG]],[[[[Int8]]] -> [[Double]]],ReadyForConstructionPL) +weightsString3IO wrs ps arr hs us vs bool bs + | bool = do + (syllDs1,sylws,fsls0) <- weightStringIO wrs ps arr hs us vs bs + let syllableDurationsD2s = [weights2SyllableDurationsD sylws] + return (syllDs1,syllableDurationsD2s,FSLG fsls0) + | otherwise = return ([],[],FSLG []) + +weightsString3NIO + :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> Int + -> Bool + -> String + -> IO ([[FlowSoundG]],[[[[Int8]]] -> [[Double]]],ReadyForConstructionPL) +weightsString3NIO wrs ps arr hs us vs n bool bs + | bool = (\(syllDs1,sylws,fsls0) -> (syllDs1,map weights2SyllableDurationsD sylws,FSLG fsls0)) <$> weightStringNIO wrs ps arr hs us vs n bs + | otherwise = pure ([],[],FSLG []) + diff --git a/Phladiprelio/General/PropertiesFuncRepG2.hs b/Phladiprelio/General/PropertiesFuncRepG2.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/General/PropertiesFuncRepG2.hs @@ -0,0 +1,247 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Phladiprelio.General.PropertiesFuncRepG2 +-- Copyright : (c) Oleksandr Zhabenko 2020-2023 +-- License : MIT +-- Stability : Experimental +-- Maintainer : oleksandr.zhabenko@yahoo.com +-- +-- Generalization of the functionality of the DobutokO.Poetry.Norms +-- and DobutokO.Poetry.Norms.Extended modules +-- from the @dobutokO-poetry@ package and the recent module Phladiprelio.General.PropertiesFuncRepG2 +-- from the @phonetic-languages-simplified-properties-array@. If you import the module with the last one +-- module, please, use the qualified import, because of common names. +-- +-- Instead of vectors, uses arrays. + +{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} + +module Phladiprelio.General.PropertiesFuncRepG2 ( + -- * Functions with 'Int16' + procDiverse2I + -- * Functions with 'Double' + , procB2FG + , procB2F + , procB2FF + , procB2InvFG + , procB2InvF + , procB2InvFF + , procRhythm23F + , procDiverse2F + -- * Working with rhythmicity + , procRhythmicity23F +) where + +import GHC.Base +import GHC.Int +import GHC.List +import GHC.Enum (fromEnum) +import GHC.Num ((+),(-),(*)) +import GHC.Float ((**),int2Double) +import GHC.Real ((/)) +import Phladiprelio.General.PropertiesSyllablesG2 +import Phladiprelio.UniquenessPeriodsG +import Phladiprelio.Rhythmicity.Simple +import Phladiprelio.Rhythmicity.Factor +import Phladiprelio.Basis +import Phladiprelio.General.Base +import Phladiprelio.General.Syllables hiding (D) +import Data.Maybe (fromMaybe,mapMaybe) +import Phladiprelio.General.EmphasisG +import Phladiprelio.Coeffs + +procDiverse2I + :: (Ord c) => GWritingSystemPRPLX + -> String -- ^ Actually is the \' \':us ++ vs in the following functions where in the definition is us and vs 'String's. See the + -- source code of the module. + -> (Int16 -> c) + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Int16 c +procDiverse2I wrs zs g sels = + D (\x -> case x of + StrG xs -> diverse2GGL sels zs . concatMap string1 . stringToXG wrs $ xs + FSLG tsss -> 1) g +{-# INLINE procDiverse2I #-} + +procDiverse2F + :: (Ord c) => GWritingSystemPRPLX + -> String -- ^ Actually is the \' \':us ++ vs in the following functions where in the definition is us and vs 'String's. See the + -- source code of the module. + -> (Double -> c) + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Double c +procDiverse2F wrs zs g sels = + D (\x ->case x of + StrG xs -> int2Double . fromEnum . diverse2GGL sels zs . concatMap string1 . stringToXG wrs $ xs + FSLG _ -> 1.0) g +{-# INLINE procDiverse2F #-} + +-------------------------------------------------------------------------------------------- + +eval23Coeffs :: Coeffs2 -> [Double] -> Double +eval23Coeffs (CF2 x y) = evalRhythmicity23K (fromMaybe 1.0 x) (fromMaybe 1.0 y) +eval23Coeffs CF0 = evalRhythmicity23 +{-# INLINE eval23Coeffs #-} + +eval23CoeffsF :: Factors -> Double -> Coeffs2 -> [Double] -> Double +eval23CoeffsF ff k (CF2 x y) = evalRhythmicity23KF ff k (fromMaybe 1.0 x) (fromMaybe 1.0 y) +eval23CoeffsF ff k CF0 = evalRhythmicity23F ff k +{-# INLINE eval23CoeffsF #-} + +------------------------------------------------------------------------------------------- + +procB2FG + :: (Ord c) => GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> ([Double] -> Double) + -> (Double -> c) + -> MappingFunctionPL + -> Coeffs2 + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Double c +procB2FG wrs ks arr gs us vs h1 h g coeffs sels = + D (\t -> case t of + StrG xs -> let ys = concatMap string1 . stringToXG wrs $ xs in + ((int2Double . fromEnum . diverse2GGL sels zs $ ys)*(h1 . mconcat . (fromMaybe (const [[-5.0]]) (fromPhoPaaW g)) . map (divSylls . reSyllableCntnts ks gs . + groupSnds . str2PRSs arr) . words1 . mapMaybe (f us vs) $ ys)) + FSLG tsss -> h1 . mconcat . (fromMaybe (const [[-6.0]]) (fromSaaW g)) $ tsss) h + where zs = ' ':us `mappend` vs +{-# INLINE procB2FG #-} + +procB2F + :: (Ord c) => GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> (Double -> c) + -> MappingFunctionPL + -> Coeffs2 + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Double c +procB2F wrs ks arr gs us vs h g coeffs = procB2FG wrs ks arr gs us vs (eval23Coeffs coeffs) h g coeffs +{-# INLINE procB2F #-} + +procB2FF + :: (Ord c) => Factors + -> GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> Double + -> (Double -> c) + -> MappingFunctionPL + -> Coeffs2 + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Double c +procB2FF ff wrs ks arr gs us vs k h g coeffs = procB2FG wrs ks arr gs us vs (eval23CoeffsF ff k coeffs) h g coeffs +{-# INLINE procB2FF #-} + +procB2InvFG + :: (Ord c) => GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> ([Double] -> Double) + -> (Double -> c) + -> MappingFunctionPL + -> Coeffs2 + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Double c +procB2InvFG wrs ks arr gs us vs h1 h g coeffs sels = + D (\t -> case t of + StrG xs -> + let !ys = concatMap string1 . stringToXG wrs $ xs + !z = diverse2GGL sels zs ys in if z == 0 then (h1 . mconcat . (fromMaybe (const [[-5.0]]) (fromPhoPaaW g)) . map (divSylls . reSyllableCntnts ks gs . groupSnds . + str2PRSs arr) . words1 . mapMaybe (f us vs) $ ys) ** 2.0 + else ((h1 . mconcat . (fromMaybe (const [[-5.0]]) (fromPhoPaaW g)) . map (divSylls . reSyllableCntnts ks gs . groupSnds . str2PRSs arr) . words1 . + mapMaybe (f us vs) $ ys) / (int2Double . fromEnum $ z)) + FSLG tsss -> h1 . mconcat . (fromMaybe (const [[-6.0]]) (fromSaaW g)) $ tsss) h + where zs = ' ':us `mappend` vs +{-# INLINE procB2InvFG #-} + +procB2InvF + :: (Ord c) => GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> (Double -> c) + -> MappingFunctionPL + -> Coeffs2 + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Double c +procB2InvF wrs ks arr gs us vs h g coeffs= procB2InvFG wrs ks arr gs us vs (eval23Coeffs coeffs) h g coeffs +{-# INLINE procB2InvF #-} + +procB2InvFF + :: (Ord c) => Factors + -> GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> Double + -> (Double -> c) + -> MappingFunctionPL + -> Coeffs2 + -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. + -> FuncRep2 ReadyForConstructionPL Double c +procB2InvFF ff wrs ks arr gs us vs k h g coeffs = procB2InvFG wrs ks arr gs us vs (eval23CoeffsF ff k coeffs) h g coeffs +{-# INLINE procB2InvFF #-} + +--------------------------------------------------------------------- + +procRhythm23F + :: (Ord c) => (Double -> c) + -> String + -> (String -> Coeffs2 -> ReadyForConstructionPL -> Double) + -> Coeffs2 + -> FuncRep2 ReadyForConstructionPL Double c +procRhythm23F h choice g coeffs = D (g choice coeffs) h +{-# INLINE procRhythm23F #-} + +procRhythmicity23F + :: (Ord c) => Factors + -> Double + -> (Double -> c) + -> (Double -> String -> MappingFunctionPL) + -> String + -> Coeffs2 + -> GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ The starting 'String' which defines the line to be constructed + -> FuncRep2 ReadyForConstructionPL Double c +procRhythmicity23F ff k g h choice coeffs wrs ks arr hs us vs bbs = D (rhythmicity ff k choice h coeffs bbs wrs ks arr hs us vs) g +{-# INLINE procRhythmicity23F #-} + +------------------------------------------------------------- + +f us vs x + | x `elem` us = Nothing + | x `notElem` vs = Just x + | otherwise = Just ' ' +{-# INLINE f #-} + +words1 xs = if null ts then [] else w : words1 s'' -- Practically this is an optimized version for this case 'words' function from Prelude. + where ts = dropWhile (== ' ') xs + (w, s'') = break (== ' ') ts +{-# NOINLINE words1 #-} + + diff --git a/Phladiprelio/General/PropertiesSyllablesG2.hs b/Phladiprelio/General/PropertiesSyllablesG2.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/General/PropertiesSyllablesG2.hs @@ -0,0 +1,298 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Phladiprelio.General.PropertiesSyllablesG2 +-- Copyright : (c) Oleksandr Zhabenko 2020-2023 +-- License : MIT +-- Stability : Experimental +-- Maintainer : oleksandr.zhabenko@yahoo.com +-- +-- Generalization and extension of the functionality of the DobutokO.Poetry.Norms +-- and DobutokO.Poetry.Norms.Extended modules +-- from the @dobutokO-poetry@ package and more recent package @phonetic-languages-simplified-properties-array@. +-- Uses syllables information. +-- Instead of the vector-related, uses arrays. +-- If you use the functionality of the Phladiprelio.Ukrainian.PropertiesSyllablesG2 module, +-- then import it qualified (or this module) because they have many common data. Is provided as a standalone one +-- to reduce dependencies list in general case. + +{-# LANGUAGE BangPatterns, MultiWayIf, NoImplicitPrelude #-} + +module Phladiprelio.General.PropertiesSyllablesG2 ( + -- * Mapping function data type + MappingFunctionPL(..) + , isPhoPaaW + , isSaaW + , fromPhoPaaW + , fromSaaW + -- * Rhythmicity properties (semi-empirical) + -- ** Simple one + , rhythmicity0i + , rhythmicity0Fi + -- ** With weight coefficients + , rhythmicityKi + , rhythmicityKFi + -- * General + , rhythmicityG + , rhythmicity +) where + +import GHC.Base +import GHC.List +import Phladiprelio.Rhythmicity.Simple +import Phladiprelio.Rhythmicity.Factor +import Phladiprelio.Rhythmicity.TwoFourth +import Phladiprelio.Rhythmicity.PolyRhythm +import Phladiprelio.General.Base +import Phladiprelio.General.Syllables +import Data.Maybe (isNothing,fromMaybe,fromJust) +import Text.Read (readMaybe) +import Phladiprelio.General.EmphasisG +import GHC.Int (Int8) +import Phladiprelio.Coeffs +import qualified Logical.OrdConstraints as L + + +eval23 = evalRhythmicity23 . mconcat +{-# INLINE eval23 #-} + +eval23K k2 k3 = evalRhythmicity23K k2 k3 . mconcat +{-# INLINE eval23K #-} + +eval23F ff k = evalRhythmicity23F ff k . mconcat +{-# INLINE eval23F #-} + +eval23KF ff k k2 k3 = evalRhythmicity23KF ff k k2 k3 . mconcat +{-# INLINE eval23KF #-} + +-------------------------------------------------------------------------------------------- + +data MappingFunctionPL = PhoPaaW ([[[PRS]]] -> [[Double]]) | SaaW ([[[Int8]]] -> [[Double]]) + +isPhoPaaW :: MappingFunctionPL -> Bool +isPhoPaaW (PhoPaaW _) = True +isPhoPaaW _ = False + +isSaaW :: MappingFunctionPL -> Bool +isSaaW (SaaW _) = True +isSaaW _ = False + +fromPhoPaaW :: MappingFunctionPL -> Maybe ([[[PRS]]] -> [[Double]]) +fromPhoPaaW (PhoPaaW f) = Just f +fromPhoPaaW _ = Nothing + +fromSaaW :: MappingFunctionPL -> Maybe ([[[Int8]]] -> [[Double]]) +fromSaaW (SaaW f) = Just f +fromSaaW _ = Nothing + +rhythmicityG + :: MappingFunctionPL-- ^ A function that specifies the syllables durations, analogue of the + -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. + -> ([[Double]] -> Double) -- ^ Usually some kind of flattening of the double list into a single value. + -> String -- ^ The starting 'String' which creates the order for the 'FSLG' representation + -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> ReadyForConstructionPL + -> Double +rhythmicityG f g bbs wrs ks arr hs us vs xs@(FSLG tsss) + | null tsss = -1.0 + | isSaaW f = g . (fromJust (fromSaaW f)) $ tsss + | otherwise = -3.0 +rhythmicityG f g bbs wrs ks arr hs us vs xs@(StrG ys) + | null ys = -2.0 + | isPhoPaaW f = g . (fromJust (fromPhoPaaW f)) . createSyllablesPL wrs ks arr hs us vs $ ys + | otherwise = g . (fromJust (fromSaaW f)) . convFI wrs ks arr hs us vs bbs $ ys +{-# INLINE rhythmicityG #-} + +------------------------------------------------------- + +rhythmicity0i + :: MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the + -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. + -> String + -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> ReadyForConstructionPL + -> Double +rhythmicity0i f = rhythmicityG f eval23 +{-# INLINE rhythmicity0i #-} + +------------------------------------------------------- + +rhythmicityKi + :: MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the + -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. + -> Double + -> Double + -> String + -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> ReadyForConstructionPL + -> Double +rhythmicityKi f k2 k3 = rhythmicityG f (eval23K k2 k3) +{-# INLINE rhythmicityKi #-} + +-------------------------------------------------------- + +rhythmicity0Fi + :: Factors + -> MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the + -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. + -> Double + -> String + -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> ReadyForConstructionPL + -> Double +rhythmicity0Fi ff f k = rhythmicityG f (eval23F ff k) +{-# INLINE rhythmicity0Fi #-} + +-------------------------------------------------------- + +rhythmicityKFi + :: Factors + -> MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the + -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. + -> Double + -> Double + -> Double + -> String + -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. + -> ReadyForConstructionPL + -> Double +rhythmicityKFi ff f k k2 k3 = rhythmicityG f (eval23KF ff k k2 k3) +{-# INLINE rhythmicityKFi #-} + +-------------------------------------------------------- + +-- | It is intended to provide different functions :: 'Double' -> 'String' -> ([[['PRS']]] -> [['Double']]). +-- The \"z\"-line uses \'F\' functions. +rhythmicity + :: Factors + -> Double + -> String -- ^ The \"f\"-line uses \'F\' functions since the version 0.13.0.0. + -> (Double -> String -> MappingFunctionPL) -- ^ The function that is needed in the 'procRhythmicity23F' function. + -- Specifies a way how the syllables represented in the phonetic language approach transforms into their durations and + -- depends on two parameters. + -> Coeffs2 + -> String + -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. + -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon + -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. + -> SegmentRulesG + -> String + -> String + -> ReadyForConstructionPL + -> Double +rhythmicity ff k choice@(c1:c2@(c3:c4@(c5:cs))) h CF0 + | c1 == '0' && c2 `elem` ["2f","3f","4f"] = rhythmicity0Fi ff f k + | c1 == '0' && c2 `elem` ["2y","3y","4y"] = rhythmicity0i f + | c1 `elem` "wx" = case c3 of + '0' -> w0F (Ch 1 1 4) (Rhythm 1 1 2) + '1' -> w0F (Ch 1 0 4) (Rhythm 2 1 1) + '2' -> w0F (Ch 0 1 4) (Rhythm 1 2 1) + '3' -> w0F (Ch 0 0 4) (Rhythm 1 1 2) + _ -> w0F (Ch 0 0 4) (Rhythm 1 1 2) + | L.ordCs2HPred1 [L.O "cMN", L.C "AF"] c1 = let just_probe = readRhythmicity choice in + case just_probe of + Just (P1 ch rh _) -> rhythmicityG f (rhythmicityABC 1.0 2.0 0.125 ch rh . mconcat) + Just (P2 ch rh r _) -> rhythmicityG f ((helperF5 c1) 1.0 r ch rh . mconcat) + _ -> rhythmicity0i f + | L.ordCs2HPred1 [L.O "z", L.C "begvIZ"] c1 && c3 >= '0' && c3 <= '7' = let u0F rs = rhythmicityG f ((helperF6 c1) 1.0 4 (PolyCh rs 5) (PolyRhythm (if c3 < '4' then [1,2,1,1] else [2,1,1,1])) . mconcat) in u0F + (case c3 of + '0' -> [True,True,True] + '1' -> [True,True,False] + '2' -> [True,False,True] + '3' -> [True,False,False] + '4' -> [False,False,True] + '5' -> [False,True,False] + '6' -> [False,True,True] + '7' -> [False,False,False]) + | otherwise = rhythmicity0i f + where f = h k choice + w0F ch rh = rhythmicityG f ((if c1 == 'w' then rhythmicityABC else rhythmicityABC0) 1.0 2.0 0.125 ch rh . mconcat) + {-# INLINE w0F #-} +rhythmicity ff k choice@(c1:c2@(c3:c4@(c5:cs))) h (CF2 x y) + | c1 == '0' && c2 `elem` ["2f","3f","4f"] = rhythmicityKFi ff f k (fromMaybe 1.0 x) (fromMaybe 1.0 y) + | c1 == '0' && c2 `elem` ["2y","3y","4y"] = rhythmicityKi f (fromMaybe 1.0 x) (fromMaybe 1.0 y) + | c1 `elem` "wx" = if + | c3 == '0' && (c5 >= '1' && c5 <= '4') -> w0F (Ch 1 1 4) (Rhythm 1 1 2) + | c3 == '1' && (c5 >= '1' && c5 <= '4') -> w0F (Ch 1 0 4) (Rhythm 2 1 1) + | c3 == '2' && (c5 >= '1' && c5 <= '4') -> w0F (Ch 0 1 4) (Rhythm 1 2 1) + | c3 == '3' && (c5 >= '1' && c5 <= '4') -> w0F (Ch 0 0 4) (Rhythm 1 1 2) + | otherwise -> w0F (Ch 1 0 4) (Rhythm 1 1 2) + | L.ordCs2HPred1 [L.O "cz",L.C "begvAFIZ"] c1 = rhythmicity ff k choice h CF0 + | otherwise = rhythmicityKi f (fromMaybe 1.0 x) (fromMaybe 1.0 y) + where f = h k choice + w0F ch rh = rhythmicityG f ((if c1 == 'w' then rhythmicityABC else rhythmicityABC0) 1.0 (fromMaybe 2.0 x) (fromMaybe 0.125 y) ch rh . mconcat) + {-# INLINE w0F #-} +rhythmicity ff k choice@(c1:c2@(c3:cs)) h CF0 + | choice == "0f" = rhythmicity0Fi ff f k + | otherwise = rhythmicity0i f + where f = h k choice +rhythmicity ff k choice@(c1:c2@(c3:cs)) h (CF2 x y) + | choice == "0f" = rhythmicityKFi ff f k (fromMaybe 1.0 x) (fromMaybe 1.0 y) + | otherwise = rhythmicityKi f (fromMaybe 1.0 x) (fromMaybe 1.0 y) + where f = h k choice +rhythmicity ff k choice h _ = rhythmicity0i (h k choice) + +helperF5 c + | c == 'A' = rhythmicityPolyWeightedLEF2 + | c == 'D' = rhythmicityPolyWeightedLF2 + | c == 'E' = rhythmicityPolyWeightedLEF3 + | c == 'F' = rhythmicityPolyWeightedLF3 + | c == 'B' = rhythmicityPolyWeightedEF2 + | c == 'C' = rhythmicityPolyWeightedF2 + | c == 'M' = rhythmicityPolyWeightedEF3 + | c == 'N' = rhythmicityPolyWeightedF3 + | otherwise = rhythmicityPoly + +helperF6 c + | c == 's' || c == 'u' = rhythmicityPoly + | c == 't' || c == 'v' = rhythmicityPoly0 + | c == 'S' || c == 'U' = rhythmicityPolyWeightedF2 + | c == 'T' || c == 'V' = rhythmicityPolyWeightedF20 + | c == 'Y' || c == 'W' = rhythmicityPolyWeightedF3 + | c == 'X' || c == 'Z' = rhythmicityPolyWeightedF30 + | c == 'O' || c == 'Q' = rhythmicityPolyWeightedEF2 + | c == 'P' || c == 'R' = rhythmicityPolyWeightedEF20 + | c == 'I' || c == 'K' = rhythmicityPolyWeightedEF3 + | c == 'J' || c == 'L' = rhythmicityPolyWeightedEF30 + | c == 'o' || c == 'q' = rhythmicityPolyWeightedLF2 + | c == 'p' || c == 'r' = rhythmicityPolyWeightedLF20 + | c == 'k' || c == 'm' = rhythmicityPolyWeightedLF3 + | c == 'l' || c == 'n' = rhythmicityPolyWeightedLF30 + | c == 'g' || c == 'i' = rhythmicityPolyWeightedLEF2 + | c == 'h' || c == 'j' = rhythmicityPolyWeightedLEF20 + | c == 'b' || c == 'e' = rhythmicityPolyWeightedLEF3 + | c == 'd' || c == 'z' = rhythmicityPolyWeightedLEF30 + | otherwise = rhythmicityPoly + + diff --git a/Phonetic/Languages/Array/General/PropertiesFuncRepG2.hs b/Phonetic/Languages/Array/General/PropertiesFuncRepG2.hs deleted file mode 100644 --- a/Phonetic/Languages/Array/General/PropertiesFuncRepG2.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# OPTIONS_HADDOCK show-extensions #-} - --- | --- Module : Phonetic.Languages.Array.General.PropertiesFuncRepG2 --- Copyright : (c) OleksandrZhabenko 2020-2022 --- License : MIT --- Stability : Experimental --- Maintainer : olexandr543@yahoo.com --- --- Generalization of the functionality of the DobutokO.Poetry.Norms --- and DobutokO.Poetry.Norms.Extended modules --- from the @dobutokO-poetry@ package and the recent module Phonetic.Languages.Array.General.PropertiesFuncRepG2 --- from the @phonetic-languages-simplified-properties-array@. If you import the module with the last one --- module, please, use the qualified import, because of common names. --- --- Instead of vectors, uses arrays. - -{-# LANGUAGE CPP, BangPatterns #-} - -module Phonetic.Languages.Array.General.PropertiesFuncRepG2 ( - -- * Functions with 'Int16' - procDiverse2I - -- * Functions with 'Double' - , procB2FG - , procB2F - , procB2FF - , procB2InvFG - , procB2InvF - , procB2InvFF - , procRhythm23F - , procDiverse2F - -- * Working with rhythmicity - , procRhythmicity23F -) where - -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__>=710 -/* code that applies only to GHC 7.10.* and higher versions */ -import GHC.Base (mconcat) -#endif -#endif -import GHC.Int -import Phonetic.Languages.Array.General.PropertiesSyllablesG2 -import Phonetic.Languages.UniquenessPeriodsG -import Languages.Rhythmicity -import Languages.Rhythmicity.Factor -import Phonetic.Languages.Basis -import GHC.Float (int2Double) -import Data.Phonetic.Languages.Base -import Data.Phonetic.Languages.Syllables hiding (D) -import Data.Maybe (fromMaybe,mapMaybe) -import Data.Monoid (mappend) -import Phonetic.Languages.EmphasisG -import Phonetic.Languages.Coeffs - -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__==708 -/* code that applies only to GHC 7.8.* */ -mconcat = concat -#endif -#endif - -procDiverse2I - :: (Ord c) => GWritingSystemPRPLX - -> String -- ^ Actually is the \' \':us ++ vs in the following functions where in the definition is us and vs 'String's. See the - -- source code of the module. - -> (Int16 -> c) - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Int16 c -procDiverse2I wrs zs g sels = - D (\x -> case x of - StrG xs -> diverse2GGL sels zs . concatMap string1 . stringToXG wrs $ xs - FSLG tsss -> 1) g -{-# INLINE procDiverse2I #-} - -procDiverse2F - :: (Ord c) => GWritingSystemPRPLX - -> String -- ^ Actually is the \' \':us ++ vs in the following functions where in the definition is us and vs 'String's. See the - -- source code of the module. - -> (Double -> c) - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Double c -procDiverse2F wrs zs g sels = - D (\x ->case x of - StrG xs -> int2Double . fromEnum . diverse2GGL sels zs . concatMap string1 . stringToXG wrs $ xs - FSLG _ -> 1.0) g -{-# INLINE procDiverse2F #-} - --------------------------------------------------------------------------------------------- - -eval23Coeffs :: Coeffs2 -> [Double] -> Double -eval23Coeffs (CF2 x y) = evalRhythmicity23K (fromMaybe 1.0 x) (fromMaybe 1.0 y) -eval23Coeffs CF0 = evalRhythmicity23 -{-# INLINE eval23Coeffs #-} - -eval23CoeffsF :: Double -> Coeffs2 -> [Double] -> Double -eval23CoeffsF k (CF2 x y) = evalRhythmicity23KF k (fromMaybe 1.0 x) (fromMaybe 1.0 y) -eval23CoeffsF k CF0 = evalRhythmicity23F k -{-# INLINE eval23CoeffsF #-} - -------------------------------------------------------------------------------------------- - -procB2FG - :: (Ord c) => GWritingSystemPRPLX - -> [(Char,Char)] - -> CharPhoneticClassification - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> ([Double] -> Double) - -> (Double -> c) - -> MappingFunctionPL - -> Coeffs2 - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Double c -procB2FG wrs ks arr gs us vs h1 h g coeffs sels = - D (\t -> case t of - StrG xs -> let ys = concatMap string1 . stringToXG wrs $ xs in - ((int2Double . fromEnum . diverse2GGL sels zs $ ys)*(h1 . mconcat . (fromMaybe (const [[-5.0]]) (fromPhoPaaW g)) . map (divSylls . reSyllableCntnts ks gs . - groupSnds . str2PRSs arr) . words1 . mapMaybe (f us vs) $ ys)) - FSLG tsss -> h1 . mconcat . (fromMaybe (const [[-6.0]]) (fromSaaW g)) $ tsss) h - where zs = ' ':us `mappend` vs -{-# INLINE procB2FG #-} - -procB2F - :: (Ord c) => GWritingSystemPRPLX - -> [(Char,Char)] - -> CharPhoneticClassification - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> (Double -> c) - -> MappingFunctionPL - -> Coeffs2 - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Double c -procB2F wrs ks arr gs us vs h g coeffs = procB2FG wrs ks arr gs us vs (eval23Coeffs coeffs) h g coeffs -{-# INLINE procB2F #-} - -procB2FF - :: (Ord c) => GWritingSystemPRPLX - -> [(Char,Char)] - -> CharPhoneticClassification - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> Double - -> (Double -> c) - -> MappingFunctionPL - -> Coeffs2 - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Double c -procB2FF wrs ks arr gs us vs k h g coeffs = procB2FG wrs ks arr gs us vs (eval23CoeffsF k coeffs) h g coeffs -{-# INLINE procB2FF #-} - -procB2InvFG - :: (Ord c) => GWritingSystemPRPLX - -> [(Char,Char)] - -> CharPhoneticClassification - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> ([Double] -> Double) - -> (Double -> c) - -> MappingFunctionPL - -> Coeffs2 - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Double c -procB2InvFG wrs ks arr gs us vs h1 h g coeffs sels = - D (\t -> case t of - StrG xs -> - let !ys = concatMap string1 . stringToXG wrs $ xs - !z = diverse2GGL sels zs ys in if z == 0 then (h1 . mconcat . (fromMaybe (const [[-5.0]]) (fromPhoPaaW g)) . map (divSylls . reSyllableCntnts ks gs . groupSnds . - str2PRSs arr) . words1 . mapMaybe (f us vs) $ ys) ** 2.0 - else ((h1 . mconcat . (fromMaybe (const [[-5.0]]) (fromPhoPaaW g)) . map (divSylls . reSyllableCntnts ks gs . groupSnds . str2PRSs arr) . words1 . - mapMaybe (f us vs) $ ys) / (int2Double . fromEnum $ z)) - FSLG tsss -> h1 . mconcat . (fromMaybe (const [[-6.0]]) (fromSaaW g)) $ tsss) h - where zs = ' ':us `mappend` vs -{-# INLINE procB2InvFG #-} - -procB2InvF - :: (Ord c) => GWritingSystemPRPLX - -> [(Char,Char)] - -> CharPhoneticClassification - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> (Double -> c) - -> MappingFunctionPL - -> Coeffs2 - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Double c -procB2InvF wrs ks arr gs us vs h g coeffs= procB2InvFG wrs ks arr gs us vs (eval23Coeffs coeffs) h g coeffs -{-# INLINE procB2InvF #-} - -procB2InvFF - :: (Ord c) => GWritingSystemPRPLX - -> [(Char,Char)] - -> CharPhoneticClassification - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> Double - -> (Double -> c) - -> MappingFunctionPL - -> Coeffs2 - -> String -- ^ Specifies the list of 'Char' that the function is sensitive to. - -> FuncRep2 ReadyForConstructionPL Double c -procB2InvFF wrs ks arr gs us vs k h g coeffs = procB2InvFG wrs ks arr gs us vs (eval23CoeffsF k coeffs) h g coeffs -{-# INLINE procB2InvFF #-} - ---------------------------------------------------------------------- - -procRhythm23F - :: (Ord c) => (Double -> c) - -> String - -> (String -> Coeffs2 -> ReadyForConstructionPL -> Double) - -> Coeffs2 - -> FuncRep2 ReadyForConstructionPL Double c -procRhythm23F h choice g coeffs = D (g choice coeffs) h -{-# INLINE procRhythm23F #-} - -procRhythmicity23F - :: (Ord c) => Double - -> (Double -> c) - -> (Double -> String -> MappingFunctionPL) - -> String - -> Coeffs2 - -> GWritingSystemPRPLX - -> [(Char,Char)] - -> CharPhoneticClassification - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ The starting 'String' which defines the line to be constructed - -> FuncRep2 ReadyForConstructionPL Double c -procRhythmicity23F k g h choice coeffs wrs ks arr hs us vs bbs = D (rhythmicity k choice h coeffs bbs wrs ks arr hs us vs) g -{-# INLINE procRhythmicity23F #-} - -------------------------------------------------------------- - -f us vs x - | x `elem` us = Nothing - | x `notElem` vs = Just x - | otherwise = Just ' ' -{-# INLINE f #-} - -words1 xs = if null ts then [] else w : words1 s'' -- Practically this is an optimized version for this case 'words' function from Prelude. - where ts = dropWhile (== ' ') xs - (w, s'') = break (== ' ') ts -{-# NOINLINE words1 #-} - - diff --git a/Phonetic/Languages/Array/General/PropertiesSyllablesG2.hs b/Phonetic/Languages/Array/General/PropertiesSyllablesG2.hs deleted file mode 100644 --- a/Phonetic/Languages/Array/General/PropertiesSyllablesG2.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# OPTIONS_HADDOCK show-extensions #-} - --- | --- Module : Phonetic.Languages.Array.General.PropertiesSyllablesG2 --- Copyright : (c) OleksandrZhabenko 2020-2022 --- License : MIT --- Stability : Experimental --- Maintainer : olexandr543@yahoo.com --- --- Generalization and extension of the functionality of the DobutokO.Poetry.Norms --- and DobutokO.Poetry.Norms.Extended modules --- from the @dobutokO-poetry@ package and more recent package @phonetic-languages-simplified-properties-array@. --- Uses syllables information. --- Instead of the vector-related, uses arrays. --- If you use the functionality of the Phonetic.Languages.Array.Ukrainian.PropertiesSyllablesG2 module, --- then import it qualified (or this module) because they have many common data. Is provided as a standalone one --- to reduce dependencies list in general case. - -{-# LANGUAGE CPP, BangPatterns, MultiWayIf #-} - -module Phonetic.Languages.Array.General.PropertiesSyllablesG2 ( - -- * Mapping function data type - MappingFunctionPL(..) - , isPhoPaaW - , isSaaW - , fromPhoPaaW - , fromSaaW - -- * Rhythmicity properties (semi-empirical) - -- ** Simple one - , rhythmicity0i - , rhythmicity0Fi - -- ** With weight coefficients - , rhythmicityKi - , rhythmicityKFi - -- * General - , rhythmicityG - , rhythmicity -) where - -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__>=710 -/* code that applies only to GHC 7.10.* and higher versions */ -import GHC.Base (mconcat) -#endif -#endif - -import Languages.Rhythmicity -import Languages.Rhythmicity.Factor -import Rhythmicity.TwoFourth -import Rhythmicity.PolyRhythm -import Data.Phonetic.Languages.Base -import Data.Phonetic.Languages.Syllables -import Data.Maybe (isNothing,fromMaybe,fromJust) -import Text.Read (readMaybe) -import Phonetic.Languages.EmphasisG -import GHC.Int (Int8) -import Phonetic.Languages.Coeffs - -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__==708 -/* code that applies only to GHC 7.8.* */ -mconcat = concat -#endif -#endif - -eval23 = evalRhythmicity23 . mconcat -{-# INLINE eval23 #-} - -eval23K k2 k3 = evalRhythmicity23K k2 k3 . mconcat -{-# INLINE eval23K #-} - -eval23F k = evalRhythmicity23F k . mconcat -{-# INLINE eval23F #-} - -eval23KF k k2 k3 = evalRhythmicity23KF k k2 k3 . mconcat -{-# INLINE eval23KF #-} - --------------------------------------------------------------------------------------------- - -data MappingFunctionPL = PhoPaaW ([[[PRS]]] -> [[Double]]) | SaaW ([[[Int8]]] -> [[Double]]) - -isPhoPaaW :: MappingFunctionPL -> Bool -isPhoPaaW (PhoPaaW _) = True -isPhoPaaW _ = False - -isSaaW :: MappingFunctionPL -> Bool -isSaaW (SaaW _) = True -isSaaW _ = False - -fromPhoPaaW :: MappingFunctionPL -> Maybe ([[[PRS]]] -> [[Double]]) -fromPhoPaaW (PhoPaaW f) = Just f -fromPhoPaaW _ = Nothing - -fromSaaW :: MappingFunctionPL -> Maybe ([[[Int8]]] -> [[Double]]) -fromSaaW (SaaW f) = Just f -fromSaaW _ = Nothing - -rhythmicityG - :: MappingFunctionPL-- ^ A function that specifies the syllables durations, analogue of the - -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. - -> ([[Double]] -> Double) -- ^ Usually some kind of flattening of the double list into a single value. - -> String -- ^ The starting 'String' which creates the order for the 'FSLG' representation - -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> ReadyForConstructionPL - -> Double -rhythmicityG f g bbs wrs ks arr hs us vs xs@(FSLG tsss) - | null tsss = -1.0 - | isSaaW f = g . (fromJust (fromSaaW f)) $ tsss - | otherwise = -3.0 -rhythmicityG f g bbs wrs ks arr hs us vs xs@(StrG ys) - | null ys = -2.0 - | isPhoPaaW f = g . (fromJust (fromPhoPaaW f)) . createSyllablesPL wrs ks arr hs us vs $ ys - | otherwise = g . (fromJust (fromSaaW f)) . convFI wrs ks arr hs us vs bbs $ ys -{-# INLINE rhythmicityG #-} - -------------------------------------------------------- - -rhythmicity0i - :: MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the - -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. - -> String - -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> ReadyForConstructionPL - -> Double -rhythmicity0i f = rhythmicityG f eval23 -{-# INLINE rhythmicity0i #-} - -------------------------------------------------------- - -rhythmicityKi - :: MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the - -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. - -> Double - -> Double - -> String - -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> ReadyForConstructionPL - -> Double -rhythmicityKi f k2 k3 = rhythmicityG f (eval23K k2 k3) -{-# INLINE rhythmicityKi #-} - --------------------------------------------------------- - -rhythmicity0Fi - :: MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the - -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. - -> Double - -> String - -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> ReadyForConstructionPL - -> Double -rhythmicity0Fi f k = rhythmicityG f (eval23F k) -{-# INLINE rhythmicity0Fi #-} - --------------------------------------------------------- - -rhythmicityKFi - :: MappingFunctionPL -- ^ A function that specifies the syllables durations, analogue of the - -- syllableDurationsD functions from the @ukrainian-phonetics-basics-array@ package. - -> Double - -> Double - -> Double - -> String - -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> ReadyForConstructionPL - -> Double -rhythmicityKFi f k k2 k3 = rhythmicityG f (eval23KF k k2 k3) -{-# INLINE rhythmicityKFi #-} - --------------------------------------------------------- - --- | It is intended to provide different functions :: 'Double' -> 'String' -> ([[['PRS']]] -> [['Double']]) for at least the --- following values: \"0z\", \"02z\", \"03z\", \"04z\", \"0y\", \"02y\", \"03y\" and the default one for other variants. --- The \"z\"-line uses \'F\' functions. -rhythmicity - :: Double - -> String -- ^ Is intended to be one of the following strings: \"02y\", \"02z\", \"03y\", \"03z\", \"04y\", \"04z\", - -- \"0y\", \"0z\", \"y\", \"y0\", \"y2\", \"y3\", \"y4\", \"yy\", \"yy2\", \"yy3\", \"z\", \"z2\", \"z3\", \"z4\", - -- \"zz\", \"zz2\", \"zz3\", \"zz4\" or some other one (that is the default one). Since the version 0.3.0.0 you - -- can also use \"w\" or \"x\"-based lines. Specifies the applied properties - -- to get the result. The \"z\"-line uses \'F\' functions. - -> (Double -> String -> MappingFunctionPL) -- ^ The function that is needed in the 'procRhythmicity23F' function. - -- Specifies a way how the syllables represented in the phonetic language approach transforms into their durations and - -- depends on two parameters. - -> Coeffs2 - -> String - -> GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String - -> String - -> ReadyForConstructionPL - -> Double -rhythmicity k choice h CF0 - | choice `elem` ["0z","02z","03z","04z"] = rhythmicity0Fi f k - | take 1 choice == "w" = case take 2 choice of - "w0" -> w0F (Ch 1 1 4) (Rhythm 1 1 2) - "w1" -> w0F (Ch 1 0 4) (Rhythm 2 1 1) - "w2" -> w0F (Ch 0 1 4) (Rhythm 1 2 1) - "w3" -> w0F (Ch 0 0 4) (Rhythm 1 1 2) - _ -> w0F (Ch 0 0 4) (Rhythm 1 1 2) - | take 1 choice == "x" = case take 2 choice of - "x0" -> x0F (Ch 1 1 4) (Rhythm 1 1 2) - "x1" -> x0F (Ch 1 0 4) (Rhythm 2 1 1) - "x2" -> x0F (Ch 0 1 4) (Rhythm 1 2 1) - "x3" -> x0F (Ch 0 0 4) (Rhythm 1 1 2) - _ -> x0F (Ch 0 0 4) (Rhythm 1 1 2) - | take 1 choice `elem` ["c","M","N"] || (take 1 choice >= "A" && take 1 choice <= "F") = let just_probe = readRhythmicity choice in - case just_probe of - Just (P1 ch rh _) -> rhythmicityG f (rhythmicityABC 1.0 2.0 0.125 ch rh . mconcat) - Just (P2 ch rh r _) -> rhythmicityG f ((helperF5 (take 1 choice)) 1.0 r ch rh . mconcat) - _ -> rhythmicity0i f - | (take 1 choice >= "b" && take 1 choice <= "v") || (take 1 choice >= "I" && take 1 choice <= "Z") = if - | (drop 1 . take 2 $ choice) >= "0" && (drop 1 . take 2 $ choice) <= "3" -> - let u0F rs = rhythmicityG f ((helperF6 (take 1 choice)) 1.0 4 (PolyCh rs 5) (PolyRhythm [1,2,1,1]) . mconcat) in - case drop 1 . take 2 $ choice of - "0" -> u0F [True,True,True] - "1" -> u0F [True,True,False] - "2" -> u0F [True,False,True] - _ -> u0F [True,False,False] - | (drop 1 . take 2 $ choice) >= "4" && (drop 1 . take 2 $ choice) <= "7" -> - let u0F rs = rhythmicityG f ((helperF6 (take 1 choice)) 1.0 4 (PolyCh rs 5) (PolyRhythm [2,1,1,1]) . mconcat) in - case drop 1 . take 2 $ choice of - "4" -> u0F [True,True,True] - "5" -> u0F [True,True,False] - "6" -> u0F [True,False,True] - ~"7" -> u0F [True,False,False] - | otherwise -> rhythmicity0i f - | otherwise = rhythmicity0i f - where f = h k choice - w0F ch rh = rhythmicityG f (rhythmicityABC 1.0 2.0 0.125 ch rh . mconcat) - x0F ch rh = rhythmicityG f (rhythmicityABC0 1.0 2.0 0.125 ch rh . mconcat) - {-# INLINE w0F #-} - {-# INLINE x0F #-} -rhythmicity k choice h (CF2 x y) - | choice `elem` ["0z","02z","03z","04z"] = rhythmicityKFi f k (fromMaybe 1.0 x) (fromMaybe 1.0 y) - | take 1 choice == "w" = if - | choice `elem` ["w01","w02","w03","w04"] -> w0F (Ch 1 1 4) (Rhythm 1 1 2) - | choice `elem` ["w11","w12","w13","w14"] -> w0F (Ch 1 0 4) (Rhythm 2 1 1) - | choice `elem` ["w21","w22","w23","w24"] -> w0F (Ch 0 1 4) (Rhythm 1 2 1) - | choice `elem` ["w31","w32","w33","w34"] -> w0F (Ch 0 0 4) (Rhythm 1 1 2) - | otherwise -> w0F (Ch 1 0 4) (Rhythm 1 1 2) - | take 1 choice == "x" = if - | choice `elem` ["x01","x02","x03","x04"] -> x0F (Ch 1 1 4) (Rhythm 1 1 2) - | choice `elem` ["x11","x12","x13","x14"] -> x0F (Ch 1 0 4) (Rhythm 2 1 1) - | choice `elem` ["x21","x22","x23","x24"] -> x0F (Ch 0 1 4) (Rhythm 1 2 1) - | choice `elem` ["x31","x32","x33","x34"] -> x0F (Ch 0 0 4) (Rhythm 1 1 2) - | otherwise -> x0F (Ch 1 0 4) (Rhythm 1 1 2) - | take 1 choice == "c" || (take 1 choice >= "A" && take 1 choice <= "Z" && take 1 choice `notElem` ["G","H"]) = rhythmicity k choice h CF0 - | take 1 choice >= "b" && take 1 choice <= "v" = rhythmicity k choice h CF0 - | otherwise = rhythmicityKi f (fromMaybe 1.0 x) (fromMaybe 1.0 y) - where f = h k choice - w0F ch rh = rhythmicityG f (rhythmicityABC 1.0 (fromMaybe 2.0 x) (fromMaybe 0.125 y) ch rh . mconcat) - x0F ch rh = rhythmicityG f (rhythmicityABC0 1.0 (fromMaybe 2.0 x) (fromMaybe 0.125 y) ch rh . mconcat) - {-# INLINE w0F #-} - {-# INLINE x0F #-} - -helperF5 xs - | xs == "A" = rhythmicityPolyWeightedLEF2 - | xs == "D" = rhythmicityPolyWeightedLF2 - | xs == "E" = rhythmicityPolyWeightedLEF3 - | xs == "F" = rhythmicityPolyWeightedLF3 - | xs == "B" = rhythmicityPolyWeightedEF2 - | xs == "C" = rhythmicityPolyWeightedF2 - | xs == "M" = rhythmicityPolyWeightedEF3 - | xs == "N" = rhythmicityPolyWeightedF3 - | otherwise = rhythmicityPoly - -helperF6 xs - | xs == "s" || xs == "u" = rhythmicityPoly - | xs == "t" || xs == "v" = rhythmicityPoly0 - | xs == "S" || xs == "U" = rhythmicityPolyWeightedF2 - | xs == "T" || xs == "V" = rhythmicityPolyWeightedF20 - | xs == "Y" || xs == "W" = rhythmicityPolyWeightedF3 - | xs == "X" || xs == "Z" = rhythmicityPolyWeightedF30 - | xs == "O" || xs == "Q" = rhythmicityPolyWeightedEF2 - | xs == "P" || xs == "R" = rhythmicityPolyWeightedEF20 - | xs == "I" || xs == "K" = rhythmicityPolyWeightedEF3 - | xs == "J" || xs == "L" = rhythmicityPolyWeightedEF30 - | xs == "o" || xs == "q" = rhythmicityPolyWeightedLF2 - | xs == "p" || xs == "r" = rhythmicityPolyWeightedLF20 - | xs == "k" || xs == "m" = rhythmicityPolyWeightedLF3 - | xs == "l" || xs == "n" = rhythmicityPolyWeightedLF30 - | xs == "g" || xs == "i" = rhythmicityPolyWeightedLEF2 - | xs == "h" || xs == "j" = rhythmicityPolyWeightedLEF20 - | xs == "b" || xs == "e" = rhythmicityPolyWeightedLEF3 - | xs == "d" || xs == "f" = rhythmicityPolyWeightedLEF30 - | otherwise = rhythmicityPoly - - diff --git a/Phonetic/Languages/EmphasisG.hs b/Phonetic/Languages/EmphasisG.hs deleted file mode 100644 --- a/Phonetic/Languages/EmphasisG.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - - - -module Phonetic.Languages.EmphasisG where - -import Data.Phonetic.Languages.Base -import Data.Phonetic.Languages.Syllables -import GHC.Int -import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) -import Data.Char (toUpper) -import GHC.Arr -import Data.List (scanl',intersperse) -import CaseBi.Arr -import Data.Foldable (foldl') -import CaseBi.Arr (getBFst',getBFstLSorted') -import Data.Lists.FLines (newLineEnding) -import Data.Traversable (traverse) -import Control.Applicative -import System.IO - -data SyllWeightsG = SyG { - point :: ![PRS] - , order :: !Int8 -- Is intended to begin at -128 up to 127 (maximum 256 entries). - , weight :: !Double -} - -showFSG :: FlowSoundG -> String -showFSG = map charS -{-# INLINE showFSG #-} - -type FlowSoundG = [PRS] - -instance Show SyllWeightsG where - show (SyG ps i w) = showFSG ps `mappend` (' ':show i) `mappend` (' ':show w) `mappend` newLineEnding - -weightSyllablesIO :: [FlowSoundG] -> IO [SyllWeightsG] -weightSyllablesIO = traverse (\(i,xs) -> (\d1 -> (SyG xs i d1)) <$> weightSyllAIO False xs) . zip ([-128..127]::[Int8]) - -weightStringIO - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String - -> IO ([[FlowSoundG]],[SyllWeightsG],[[[Int8]]]) -weightStringIO wrs ks arr hs us vs xs = weightSyllablesIO fss >>= \zs -> pure (tsss, zs, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss) - where tsss = createSyllablesPL wrs ks arr hs us vs xs - fss = [ ts | tss <- tsss , ts <- tss ] - -weightStringNIO - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> Int - -> String - -> IO ([[FlowSoundG]],[[SyllWeightsG]],[[[Int8]]]) -weightStringNIO wrs ks arr hs us vs n xs = traverse (\_-> weightSyllablesIO fss) [1..n] >>= \zss -> pure (tsss, zss, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss) - where tsss = createSyllablesPL wrs ks arr hs us vs xs - fss = [ ts | tss <- tsss , ts <- tss ] - -weights2SyllableDurationsDArr :: [SyllWeightsG] -> Array Int (Int8,Double) -weights2SyllableDurationsDArr xs = listArray (0,l-1) . map (\(SyG _ i w) -> (i,w)) $ xs - where l = length xs - -weights2SyllableDurationsD :: [SyllWeightsG] -> [[[Int8]]] -> [[Double]] -weights2SyllableDurationsD xs = map (map (k (getBFst' (4.0, weights2SyllableDurationsDArr xs)))) - where k f = foldl' (\y x -> f x + y) 0 -{-# INLINE weights2SyllableDurationsD #-} - -helper1F :: [Int8] -> [[[Int8]]] -helper1F (x:y:ys) = map (:[]) [x..y-1]:helper1F (y:ys) -helper1F _ = [] - -weightSyllAIO :: Bool -> FlowSoundG -> IO Double -weightSyllAIO upper xs - | null xs = pure 4.0 - | otherwise = - (\d -> fromMaybe 4.0 (readMaybe d::Maybe Double)) <$> (hPutStr stderr ("? " `mappend` ((if upper then map toUpper else id) . showFSG $ xs) `mappend` " ") *> getLine) -- Well, definitely it should not be 'stderr' here, but 'stdout' gives some strange behaviour, probably related to optimizations or some strange 'Handle' behaviour. (?) - - -data ReadyForConstructionPL = StrG String | FSLG [[[Int8]]] deriving (Eq,Ord) - -showR :: ReadyForConstructionPL -> String -showR (StrG xs) = xs -showR (FSLG tsss) = show tsss - -isStr :: ReadyForConstructionPL -> Bool -isStr (StrG _) = True -isStr _ = False - -isFSL :: ReadyForConstructionPL -> Bool -isFSL (FSLG _) = True -isFSL _ = False - -fromReadyFCPLS :: ReadyForConstructionPL -> Maybe String -fromReadyFCPLS (StrG xs) = Just xs -fromReadyFCPLS _ = Nothing - -fromReadyFCPLF :: ReadyForConstructionPL -> Maybe [[[Int8]]] -fromReadyFCPLF (FSLG xsss) = Just xsss -fromReadyFCPLF _ = Nothing - -helper2F :: [b] -> [a] -> [c] -> [[d]] -> [([b],[a],[c])] -helper2F vs xs ys tss = let (us,ks,rs) = unzip3 . zip3 vs xs $ ys in - helper2F' us ks rs tss - where helper2F' us@(_:_) ks@(_:_) rs@(_:_) tss@(ts:wss) = - let l = length ts - (wws,vvs) = splitAt l us - (qs,ps) = splitAt l ks - (ns,ms) = splitAt l rs - in (wws,qs,ns):helper2F' vvs ps ms wss - helper2F' _ _ _ _ = [] - -convF1 - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String - -> [[FlowSoundG]] -convF1 wrs ks arr hs us vs xs - | null xs = [] - | otherwise = [ tss | tss <- createSyllablesPL wrs ks arr hs us vs xs ] - -convF3 - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String - -> [([String],[[Int8]],[FlowSoundG])] -convF3 wrs ks arr hs us vs xs - | null xs = [([],[],[])] - | otherwise = helper2F (concatMap (map showFSG) tsss) (map (:[]) ([-128..127]::[Int8])) [ ts | tss <- qss, ts <- tss ] qss - where tsss = createSyllablesPL wrs ks arr hs us vs xs - qss = [ tss | tss <- tsss ] - -convF3W - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String - -> [(String,[[Int8]])] -convF3W wrs ks arr hs us vs xs - | null xs = [([],[])] - | otherwise = zipWith (\(_,ys,_) ts -> (ts,ys)) (convF3 wrs ks arr hs us vs xs) . words $ xs - -convFI - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String - -> String - -> [[[Int8]]] -convFI wrs ks arr hs us vs ts = map f . words - where !f = getBFstL' [] (convF3W wrs ks arr hs us vs ts) - -convFSL - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String - -> ReadyForConstructionPL - -> String -convFSL wrs ps arr hs us vs ts r@(StrG xs) = concat . concat . intersperse [" "] . map (\(ks,_,_)-> ks) . convF3 wrs ps arr hs us vs $ xs - where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 wrs ps arr hs us vs $ ts -convFSL wrs ps arr hs us vs ts r@(FSLG tsss) = concat . concat . intersperse [" "] . map (map (getBFstLSorted' " " ks) ) $ tsss - where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 wrs ps arr hs us vs $ ts - ks = zip (concat . fst $ js) (concat . snd $ js) - -weightsString3IO - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> Bool - -> String - -> IO ([[FlowSoundG]],[[[[Int8]]] -> [[Double]]],ReadyForConstructionPL) -weightsString3IO wrs ps arr hs us vs bool bs - | bool = do - (syllDs1,sylws,fsls0) <- weightStringIO wrs ps arr hs us vs bs - let syllableDurationsD2s = [weights2SyllableDurationsD sylws] - return (syllDs1,syllableDurationsD2s,FSLG fsls0) - | otherwise = return ([],[],FSLG []) - -weightsString3NIO - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text. - -> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon - -- (e. g. allophones). Must be sorted in the ascending order to be used correctly. - -> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly. - -> SegmentRulesG - -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package. - -> Int - -> Bool - -> String - -> IO ([[FlowSoundG]],[[[[Int8]]] -> [[Double]]],ReadyForConstructionPL) -weightsString3NIO wrs ps arr hs us vs n bool bs - | bool = (\(syllDs1,sylws,fsls0) -> (syllDs1,map weights2SyllableDurationsD sylws,FSLG fsls0)) <$> weightStringNIO wrs ps arr hs us vs n bs - | otherwise = pure ([],[],FSLG []) - diff --git a/phonetic-languages-simplified-generalized-properties-array.cabal b/phonetic-languages-simplified-generalized-properties-array.cabal --- a/phonetic-languages-simplified-generalized-properties-array.cabal +++ b/phonetic-languages-simplified-generalized-properties-array.cabal @@ -3,14 +3,14 @@ -- http://haskell.org/cabal/users-guide/ name: phonetic-languages-simplified-generalized-properties-array -version: 0.12.0.0 +version: 0.13.1.0 synopsis: Some 'properties' of the phonetic languages approach text. description: Generalizes the functionality of the https://hackage.haskell.org/package/phonetic-languages-simplified-properties-array homepage: https://hackage.haskell.org/package/phonetic-languages-simplified-generalized-properties-array license: MIT license-file: LICENSE author: Oleksandr Zhabenko -maintainer: olexandr543@yahoo.com +maintainer: oleksandr.zhabenko@yahoo.com copyright: Oleksandr Zhabenko category: Language, Math, Game build-type: Simple @@ -18,9 +18,9 @@ cabal-version: >=1.10 library - exposed-modules: Phonetic.Languages.Array.General.PropertiesFuncRepG2, Phonetic.Languages.Array.General.PropertiesSyllablesG2, Phonetic.Languages.EmphasisG + exposed-modules: Phladiprelio.General.PropertiesFuncRepG2, Phladiprelio.General.PropertiesSyllablesG2, Phladiprelio.General.EmphasisG -- other-modules: - other-extensions: CPP, BangPatterns, MultiWayIf - build-depends: base >=4.8 && <5, phonetic-languages-basis ==0.2.0.0, phonetic-languages-rhythmicity ==0.9.2.0, phonetic-languages-phonetics-basics ==0.9.1.0, lists-flines ==0.1.2.0, mmsyn2-array ==0.3.0.0 + other-extensions: BangPatterns, MultiWayIf, NoImplicitPrelude + build-depends: base >=4.13 && <5, phonetic-languages-basis ==0.3.0.0, phonetic-languages-rhythmicity ==0.11.0.2, phladiprelio-rhythmicity-shared ==0.1.0.0, phonetic-languages-phonetics-basics ==0.10.0.2, lists-flines ==0.1.3.0, mmsyn2-array ==0.3.1.1, logical-constraints ==0.1.3.0 -- hs-source-dirs: default-language: Haskell2010