{-# OPTIONS_HADDOCK show-extensions #-}
-- |
-- Module : Phladiprelio.ConstraintsEncoded
-- Copyright : (c) OleksandrZhabenko 2020-2023
-- License : MIT
-- Stability : Experimental
-- Maintainer : oleksandr.zhabenko@yahoo.com
--
-- Provides a way to encode the needed constraint with possibly less symbols.
-- Uses arrays instead of vectors.
{-# LANGUAGE FlexibleInstances, FlexibleContexts, NoImplicitPrelude #-}
module Phladiprelio.ConstraintsEncoded (
-- * Data types
EncodedContraints(..)
, EncodedCnstrs
-- * Functions to work with them
-- ** Read functions
, readMaybeEC
, readMaybeECG
-- ** Process-encoding functions
, decodeConstraint1
, decodeLConstraints
-- ** Modifiers and getters
, getIEl
, setIEl
-- ** Predicates
, isE
, isP
, isF
, isQ
, isT
, isSA
, isSB
, isV
, isW
, isH
, isR
, isM
) where
import GHC.Base
import GHC.List
import GHC.Num ((-),abs)
import Text.Show (show)
import Text.Read (readMaybe)
import Data.Maybe
import GHC.Arr
import Phladiprelio.Constraints
import Data.SubG (InsertLeft(..))
data EncodedContraints a b = E a | P a b | Q a a a a a | T a a a a | SA a a b | SB a a b | F a a a | V a a a | W a a a | H a a a a | R a a a a | M a a a a deriving (Eq, Ord)
-- | Inspired by the: https://hackage.haskell.org/package/base-4.14.0.0/docs/Data-Maybe.html
-- Is provided here as a more general way to read the 'String' into a 'EncodedCnstrs' than more restricted
-- but safer 'readMaybeECG'. It is up to user to check whether the parameters are in the correct form, the function does
-- not do the full checking. For phonetic-languages applications, it is better to use 'readMaybeECG' function instead.
readMaybeEC :: Int -> String -> Maybe EncodedCnstrs
readMaybeEC n xs
| null xs = Nothing
| n >=0 && n <= 9 =
let h = head xs
ts = filter (\x -> x >= '0' && [x] <= show n) . tail $ xs in
case h of
'E' -> Just (E (fromMaybe 0 (readMaybe (take 1 . tail $ xs)::Maybe Int)))
'F' -> let (y,z) = (readMaybe (take 1 ts)::Maybe Int, readMaybe (take 1 . drop 1 $ ts)) in
case (y,z) of
(Nothing,_) -> Nothing
(_,Nothing) -> Nothing
~(Just x1, Just x2) -> Just (F undefined x1 x2)
'T' -> let (y,z,u) = (readMaybe (take 1 ts)::Maybe Int, readMaybe (take 1 . drop 1 $ ts)::Maybe Int, readMaybe (take 1 . drop 2 $ ts)::Maybe Int) in
case (y,z,u) of
(Nothing,_,_) -> Nothing
(_,Nothing,_) -> Nothing
(_,_,Nothing) -> Nothing
~(Just x1, Just x2, Just x3) -> Just (T undefined x1 x2 x3)
'A' -> let y = readMaybe (take 1 ts)::Maybe Int in
if isJust y then
let y0 = fromJust y
zs = filter (/= y0) . catMaybes . map (\t -> readMaybe [t]::Maybe Int) . drop 1 $ ts in
case zs of
[] -> Nothing
~x2 -> Just (SA undefined y0 (listArray (0,length x2 - 1) x2))
else Nothing
'B' -> let y = readMaybe (take 1 ts)::Maybe Int in
if isJust y then
let y0 = fromJust y
zs = filter (/= y0) . catMaybes . map (\t -> readMaybe [t]::Maybe Int) . drop 1 $ ts in
case zs of
[] -> Nothing
~x2 -> Just (SB undefined y0 (listArray (0,length x2 - 1) x2))
else Nothing
'Q' -> let (y,z,u,w) = (readMaybe (take 1 ts)::Maybe Int, readMaybe (take 1 . drop 1 $ ts)::Maybe Int, readMaybe (take 1 . drop 2 $ ts)::Maybe Int,
readMaybe (take 1 . drop 3 $ ts)::Maybe Int) in
case (y,z,u,w) of
(Nothing,_,_,_) -> Nothing
(_,Nothing,_,_) -> Nothing
(_,_,Nothing,_) -> Nothing
(_,_,_,Nothing) -> Nothing
~(Just x1, Just x2, Just x3, Just x4) -> Just (Q undefined x1 x2 x3 x4)
'P' -> if null ts then Just (E 0) else let l = length ts in Just . P n . listArray (0,l-1) . map (\x -> case (fromJust (readMaybe [x]::Maybe Int)) of {0 -> 9; n -> n - 1}) $ ts
'W' -> if length ts /= 2 then Just (E 0) else let [k,t] = map (\x -> case (fromJust (readMaybe [x]::Maybe Int)) of {0 -> 9; n -> n - 1}) $ ts in Just . W n k $ t
'V' -> if length ts /= 2 then Just (E 0) else let [k,t] = map (\x -> case (fromJust (readMaybe [x]::Maybe Int)) of {0 -> 9; n -> n - 1}) $ ts in Just . V n k $ t
'H' -> if length ts /= 3 then Just (E 0) else let [k,t,w] = map (\x -> case (fromJust (readMaybe [x]::Maybe Int)) of {0 -> 9; n -> n - 1}) $ ts in Just . H n k t $ w
'R' -> if length ts /= 3 then Just (E 0) else let [k,t,w] = map (\x -> case (fromJust (readMaybe [x]::Maybe Int)) of {0 -> 9; n -> n - 1}) $ ts in Just . R n k t $ w
'M' -> if length ts /= 3 then Just (E 0) else let [k,t,w] = map (\x -> case (fromJust (readMaybe [x]::Maybe Int)) of {0 -> 9; n -> n - 1}) $ ts in Just . M n k t $ w
_ -> Nothing
| otherwise = Nothing
-- | Is used inside 'readMaybeECG' to remove the 'undefined' inside the 'EncodedCnstrs'.
setWordsN :: Int -> Maybe EncodedCnstrs -> Maybe EncodedCnstrs
setWordsN _ Nothing = Nothing
setWordsN _ (Just (E x)) = Just (E x)
setWordsN n (Just (P _ v)) = Just (P n v)
setWordsN n (Just (T _ i j k)) = Just (T n i j k)
setWordsN n (Just (Q _ i j k l)) = Just (Q n i j k l)
setWordsN n (Just (SA _ i v)) = Just (SA n i v)
setWordsN n (Just (SB _ i v)) = Just (SB n i v)
setWordsN n (Just (F _ i j)) = Just (F n i j)
setWordsN n (Just (V _ i j)) = Just (V n i j)
setWordsN n (Just (W _ i j)) = Just (W n i j)
setWordsN n (Just (H _ i j k)) = Just (H n i j k)
setWordsN n (Just (R _ i j k)) = Just (R n i j k)
setWordsN n (Just (M _ i j k)) = Just (M n i j k)
-- | A safer variant of the 'readMaybeEC' more suitable for applications, e. g. for phonetic-languages series of packages.
readMaybeECG :: Int -> String -> Maybe EncodedCnstrs
readMaybeECG n xs
| n <= 9 && n >=0 = setWordsN n . readMaybeEC n $ xs
| otherwise = Nothing
type EncodedCnstrs = EncodedContraints Int (Array Int Int)
-- | Must be applied to the correct array of permutation indeces. Otherwise, it gives runtime error (exception). All the integers inside the
-- 'EncodedCnstrs' must be in the range [0..n] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'. Besides,
-- @n@ is (probably must be) not greater than 6.
decodeConstraint1 :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => EncodedCnstrs -> t (Array Int Int) -> t (Array Int Int)
decodeConstraint1 (E _) = id
decodeConstraint1 (P _ v) = fixedPointsS v
decodeConstraint1 (Q _ i j k l) = unsafeQuadruples i j k l
decodeConstraint1 (T _ i j k) = unsafeTriples i j k
decodeConstraint1 (SA _ i v) = unsafeSeveralA i v
decodeConstraint1 (SB _ i v) = unsafeSeveralB i v
decodeConstraint1 (F _ i j) = filterOrderIJ i j
decodeConstraint1 (V _ i j) = filterSignDistanceIJ i j (j - i)
decodeConstraint1 (W _ i j) = filterUnsignDistanceIJ i j (abs $ j - i)
decodeConstraint1 (H _ i j k) = filterSignDistanceIJK3 i j k (j - i) (k - j)
decodeConstraint1 (R _ i j k) = filterUnsignDistanceIJK3 i j k (abs (j - i)) (abs (k - j))
decodeConstraint1 (M _ i j k) = filterMixedDistanceIJK3 i j k (j - i) (abs (k - j))
-- | Must be applied to the correct array of permutation indeces. Otherwise, it gives runtime error (exception). All the integers inside the
-- 'EncodedCnstrs' must be in the range [0..n] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'. Besides,
-- @n@ is (probably must be) not greater than 6.
decodeLConstraints :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => [EncodedCnstrs] -> t (Array Int Int) -> t (Array Int Int)
decodeLConstraints (x:xs) = decodeLConstraints' ys . decodeConstraint1 y
where y = minimum (x:xs)
ys = filter (/= y) . g $ (x:xs)
g ((E _):zs) = g zs
g (z:zs) = z : g zs
g _ = []
decodeLConstraints' (z:zs) = decodeLConstraints' zs . decodeConstraint1 z
decodeLConstraints' _ = id
decodeLConstraints _ = id
isE :: EncodedCnstrs -> Bool
isE (E _) = True
isE _ = False
isP :: EncodedCnstrs -> Bool
isP (P _ _) = True
isP _ = False
isF :: EncodedCnstrs -> Bool
isF (F _ _ _) = True
isF _ = False
isT :: EncodedCnstrs -> Bool
isT (T _ _ _ _) = True
isT _ = False
isQ :: EncodedCnstrs -> Bool
isQ (Q _ _ _ _ _) = True
isQ _ = False
isSA :: EncodedCnstrs -> Bool
isSA (SA _ _ _) = True
isSA _ = False
isSB :: EncodedCnstrs -> Bool
isSB (SB _ _ _) = True
isSB _ = False
isV :: EncodedCnstrs -> Bool
isV (V _ _ _) = True
isV _ = False
isW :: EncodedCnstrs -> Bool
isW (W _ _ _) = True
isW _ = False
isH :: EncodedCnstrs -> Bool
isH (H _ _ _ _) = True
isH _ = False
isR :: EncodedCnstrs -> Bool
isR (R _ _ _ _) = True
isR _ = False
isM :: EncodedCnstrs -> Bool
isM (M _ _ _ _) = True
isM _ = False
{-| Works only with the correctly defined argument though it is not checked. Use with this caution.
-}
getIEl :: EncodedCnstrs -> Int
getIEl (E i) = i
getIEl (P _ arr) = unsafeAt arr 0
getIEl (Q _ i _ _ _) = i
getIEl (T _ i _ _) = i
getIEl (SA _ i _) = i
getIEl (SB _ i _) = i
getIEl (F _ i _) = i
getIEl (V _ i _) = i
getIEl (W _ i _) = i
getIEl (H _ i _ _) = i
getIEl (R _ i _ _) = i
getIEl (M _ i _ _) = i
{-| Works only with the correctly defined arguments though it is not checked. Use with this caution.
-}
setIEl :: Int -> EncodedCnstrs -> EncodedCnstrs
setIEl i (E _) = E i
setIEl i (P n arr) = P n (arr // [(0,i)])
setIEl i (Q n _ j k l) = Q n i j k l
setIEl i (T n _ j k) = T n i j k
setIEl i (SA n _ v) = SA n i v
setIEl i (SB n _ v) = SB n i v
setIEl i (F n _ j) = F n i j
setIEl i (V n _ j) = V n i j
setIEl i (W n _ j) = W n i j
setIEl i (H n _ j k) = H n i j k
setIEl i (R n _ j k) = R n i j k
setIEl i (M n _ j k) = M n i j k