{-# OPTIONS_GHC -threaded -rtsopts #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns #-}
-- |
-- Module : Phonetic.Languages.Simplified.DeEnCoding
-- Copyright : (c) OleksandrZhabenko 2020-2022
-- License : MIT
-- Stability : Experimental
-- Maintainer : olexandr543@yahoo.com
--
-- Functions to encode and decode 'String' -> \['Int8'\] used in the Simple/Main.hs code.
-- Is taken from the @phonetic-languages-simplified-lists-examples@ package.
module Phonetic.Languages.Simplified.DeEnCoding where
import Data.Heap (Heap)
import qualified Data.Heap as Heap
import GHC.Int
import Data.Foldable (foldl')
import Data.List (sortBy,sort,partition)
import System.IO
import Data.Maybe (fromJust)
import Numeric
import Phonetic.Languages.Emphasis
import Melodics.Ukrainian.ArrInt8 (FlowSound)
import Languages.Phonetic.Ukrainian.Syllable.ArrInt8
--default (Int, Double)
encodeToInt :: Ord a => [[a]] -> Int
encodeToInt yss
| null ks = -1
| otherwise = fst . head $ ks
where ks = readHex (showHex (foldl' (\x y -> x * 16 + y) 0 . map (\(j,_) -> fromEnum j) . sortBy (\x y -> compare (snd x) (snd y)) . trans2 $ yss) $ "")
{-# INLINABLE encodeToInt #-}
-- | Is taken mostly from the Phonetic.Languages.Simplified.Lists.UniquenessPeriodsG module from the @phonetic-languages-simplified-common@ package.
indexedL :: Foldable t => b -> t b -> [(Int8, b)]
indexedL y zs = foldr f v zs
where !v = [(toEnum (length zs + 1),y)]
f x ((j,z):ys) = (j-1,x):(j,z):ys
{-# INLINE indexedL #-}
trans2 :: [[a]] -> [(Int8, [a])]
trans2 = init . indexedL []
{-# INLINE trans2 #-}
trans232 :: [[a]] -> [(Int, [a])]
trans232 zs = init . foldr f v $ zs
where !v = [(length zs + 1,[])]
f x ((j,z):ys) = (j-1,x):(j,z):ys
{-# INLINE trans232 #-}
int2l :: Int -> [Int8]
int2l n
| n < 16 = [toEnum n]
| otherwise = int2l n1 `mappend` [l]
where (!n1,!l0) = quotRem n 16
!l = toEnum l0
{-# INLINABLE int2l #-}
-- | So for the strings consisting of no more than 10 words:
-- > decodeToStr (int2l . encodeToInt . words $ xs) xs == unwords . words $ xs
--
decodeToStr :: [Int8] -> String -> String
decodeToStr ys = unwords . map snd . sortBy (\x y -> compare (fst x) (fst y)) . zip ys . sort . words
{-# INLINE decodeToStr #-}
-- | For the 'ReadyForConstructionUkr' that corresponds to the 'String' consisting of no more than 10 words.
--
decodeToReadyFCUkr :: [Int8] -> ReadyForConstructionUkr -> ReadyForConstructionUkr
decodeToReadyFCUkr ys (Str ts) = Str . unwords . map snd . sortBy (\x y -> compare (fst x) (fst y)) . zip ys . sort . words $ ts
decodeToReadyFCUkr ys (FSL tsss) = FSL . map snd . sortBy (\x y -> compare (fst x) (fst y)) . zip ys . sort $ tsss
{-# INLINE decodeToReadyFCUkr #-}
-- | Every 'String' consists of words with whitespace symbols in between.
toHeap :: [String] -> Heap Int
toHeap yss@(xs:xss)
| null xss = Heap.singleton . encodeToInt . words $ xs
| otherwise = Heap.fromList . map (encodeToInt . words) $ yss
toHeap _ = Heap.empty
{-# INLINE toHeap #-}
-- | Every 'ReadyForConstructionUkr' corresponds to the 'String' that consists of words with whitespace symbols in between.
-- The list must be consistent -- either 'FSL'-constructed or 'Str'-constructed.
toHeapR :: [ReadyForConstructionUkr] -> Heap Int
toHeapR yss@(xs@(Str ts):xss)
| null xss = Heap.singleton . encodeToInt . words $ ts
| otherwise = Heap.fromList . map (encodeToInt . words . fromJust . fromReadyFCUkrS) $ yss
toHeapR yss@(xs@(FSL tsss):xss)
| null xss = Heap.singleton . encodeToInt $ tsss
| otherwise = Heap.fromList . map (encodeToInt . fromJust . fromReadyFCUkrF) $ yss
toHeapR _ = Heap.empty
{-# INLINE toHeapR #-}
fromHeap :: String -> Heap Int -> [String]
fromHeap ys heap
| Heap.null heap = []
| otherwise = map (flip decodeToStr ys . int2l) . Heap.toUnsortedList $ heap
{-# INLINE fromHeap #-}
fromHeapReadyFCUkr :: ReadyForConstructionUkr -> Heap Int -> [ReadyForConstructionUkr]
fromHeapReadyFCUkr ys heap
| Heap.null heap = []
| otherwise = map (flip decodeToReadyFCUkr ys . int2l) . Heap.toUnsortedList $ heap
{-# INLINE fromHeapReadyFCUkr #-}
intersectInterResults :: [String] -> [String] -> [String]
intersectInterResults zss
| null zss = const []
| otherwise = fromHeap (head zss) . Heap.intersect (toHeap zss) . toHeap
{-# INLINE intersectInterResults #-}
-- | It seems like it works, but it isn't. (??). The main reason is the hardness with defining convF to work properly.
intersectInterReadyFCUkr :: (String -> [[FlowSound]]) -> [ReadyForConstructionUkr] -> [ReadyForConstructionUkr] -> [ReadyForConstructionUkr]
intersectInterReadyFCUkr convF zss tss
| null zss = []
| null tss = []
| (isStr . head $ tss) && (isStr . head $ zss) = fromHeapReadyFCUkr (head zss) . Heap.intersect (toHeapR zss) . toHeapR $ tss
| (isFSL . head $ tss) && (isFSL . head $ zss) = fromHeapReadyFCUkr (head zss) . Heap.intersect (toHeapR zss) . toHeapR $ tss
| isStr . head $ tss = fromHeapReadyFCUkr (head zss) . Heap.intersect (toHeapR zss) . toHeapR . map (FSL . convF . fromJust . fromReadyFCUkrS) $ tss
| otherwise = fromHeapReadyFCUkr (head tss) . Heap.intersect (toHeapR . map (FSL . convF . fromJust . fromReadyFCUkrS) $ zss) . toHeapR $ tss
{-# INLINE intersectInterReadyFCUkr #-}
intersectInterReadyFCUkr2 :: String -> [ReadyForConstructionUkr] -> [ReadyForConstructionUkr] -> [ReadyForConstructionUkr]
intersectInterReadyFCUkr2 ts = intersectInterReadyFCUkr (convFI ts)
{-# INLINE intersectInterReadyFCUkr2 #-}
-- | Auxiliary printing function to define the line ending in some cases. Is taken from the
-- Languages.UniquenessPeriods.Vector.General.DebugG module from the @phonetic-languages-general@ package
newLineEnding :: String
newLineEnding
| nativeNewline == LF = "\n"
| otherwise = "\r\n"
foldlI :: String -> [[ReadyForConstructionUkr]] -> [ReadyForConstructionUkr]
foldlI ts jss@((!xs):ys:xss)
| null pss = foldlI' ts qss
| null qss = foldlI' ts pss
| otherwise = intersectInterReadyFCUkr2 ts (foldlI' ts pss) (foldlI' ts qss)
where (pss,qss) = partition (< [FSL []]) jss
foldlI' ts rss@(rs:ps:yss) = foldlI' ts (intersectInterReadyFCUkr2 ts rs ps : yss)
foldlI' ts ((!xs):_) = xs
foldlI' _ _ = []
foldlI _ ((!xs):_) = xs
foldlI _ _ = []