Base.hs

{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Phonetic.Languages.Simplified.Lists.UniquenessPeriodsG.Base
-- Copyright   :  (c) OleksandrZhabenko 2020
-- License     :  MIT
-- Stability   :  Experimental
-- Maintainer  :  olexandr543@yahoo.com
--
-- Generalization of the uniqueness-periods and uniqueness-periods-general
-- packages functionality. Uses less dependencies.
--

{-# LANGUAGE BangPatterns #-}

module Phonetic.Languages.Simplified.Lists.UniquenessPeriodsG.Base (
  -- * List functions
  uniquenessPeriodsG
  , diverse2GL
)where

import GHC.Int
import Data.List
import Data.Maybe (mapMaybe)

-- | A lists variant of the diverse2 metrics from the @phonetic-languages-properties@ package.
diverse2GL :: Foldable t => String -> t Char -> Int16
diverse2GL whspss = sum . uniquenessPeriodsG whspss
{-# INLINE diverse2GL #-}
 
-- | A generalization of the uniquenessPeriods function of the @uniqueness-periods@ package.
uniquenessPeriodsG :: Foldable t => String -> t Char -> [Int16]
uniquenessPeriodsG whspss ws
 | null ws = []
 | otherwise = mapMaybe (helpG sum whspss) . unfoldr f $ ks
     where !ks = indexedL '\00' ws
           !vs = mapMaybe g ks
           g x
            | (`elem` whspss) . snd $ x = Just (fst x)
            | otherwise = Nothing
           {-# INLINE g #-}
           f !x = if null x then Nothing else let !idX0 = snd . head $ x in Just . (\vws (v2,v3) -> ((helpUPV3 vws [] .
                    map fst $ v2,snd . head $ v2),v3)) vs . partition (\(_,xs) -> xs == idX0) $ x                    

-- | The first and the third list arguments of numbers (if not empty) must be sorted in the ascending order.
helpUPV3 :: [Int16] -> [Int16] -> [Int16] -> [Int16]
helpUPV3 (z:zs) !acc (x:y:xs)
 | compare ((x - z) * (y - z)) 0 == LT = helpUPV3 zs ((y - x):acc) (y:xs)
 | compare y z == GT = helpUPV3 zs acc (x:y:xs)
 | otherwise = helpUPV3 (z:zs) acc (y:xs)
helpUPV3 _ !acc _ = acc

indexedL :: Foldable t => b -> t b -> [(Int16, b)]
indexedL y = foldr f v
  where v = [(1::Int16,y)]
        f x ((j,z):ys) = (j-1,x):(j,z):ys

helpG :: (Eq a) => ([b] -> b) -> [a] -> ([b], a) -> Maybe b
helpG h xs (ts, x)
  | null ts = Nothing
  | x `elem` xs = Nothing
  | otherwise = Just (h ts)
{-# INLINE helpG #-}