{-# 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
 , readMaybeECG
  -- ** Process-encoding functions
  , decodeConstraint1
  , decodeLConstraints
  , isConstraint1
  -- ** Modifiers and getters
  , getIEl
  , setIEl
  -- ** Predicates
  , isE
  , isP
  , isF
  , isQ
  , isT
  , isSA
  , isSB
  , isV
  , isW
  , isH
  , isR
  , isM
  -- * Algebraic general conversion
  , validOrdStr
  , generalConversion
  , filterGeneralConv
) where

import GHC.Base
import GHC.List
import GHC.Num ((+),(-),abs)
import Text.Show (show, Show(..))
import Text.Read (readMaybe)
import Data.Maybe
import Data.List (nub, words, groupBy)
import GHC.Arr
import Data.Char (isDigit, isLetter)
import Phladiprelio.Constraints
import Data.SubG (InsertLeft(..))
import Data.Tuple (fst)

data EncodedContraints a b = E 
                           | 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, Show)

validOrdStr0 
  :: String 
  -> Int -- ^ Number of seen so far \'(\' parentheses
  -> Int -- ^ Number of seen so far \')\' parentheses
  -> Bool
validOrdStr0 xs@('E':ys) n m = validOrdStr0 ys n m
validOrdStr0 xs@(' ':y:t:ys) n m
  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m
  | y `elem` "-(E" = validOrdStr0 (y:t:ys) n m
  | otherwise = False  
validOrdStr0 xs@('(':y:t:ys) n m
  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) (n + 1) m
  | y `elem` "-(E" = validOrdStr0 (y:t:ys) (n + 1) m
  | otherwise = False  
validOrdStr0 xs@(')':y:t:ys) n m
  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n (m + 1)
  | y `elem` "-()E" = validOrdStr0 (y:t:ys) n (m + 1)
  | otherwise = False  
validOrdStr0 xs@('-':y:t:ys) n m
  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m 
  | y `elem` "-)" || isDigit y = False
  | otherwise = validOrdStr0 (y:t:ys) n m 
validOrdStr0 xs@(x:y:t:ys) n m 
  | x `elem` "ABFHMPQRTVW" = if isDigit y then validOrdStr0 (dropWhile isDigit (t:ys)) n m else False
  | otherwise = validOrdStr0 (y:t:ys) n (m + 1) 
validOrdStr0 xs@(x:')':ys) n m 
  | isDigit x || x == ')' = validOrdStr0 ys n (if x == ')' then m + 2 else m + 1) 
  | otherwise = False
validOrdStr0 xs@(x:y:ys) n m 
  | x `elem` "(ABFHMQRTVW" = False
  | y `elem` " -(ABFHMPQRTVW" = False
  | x == 'P' && not (isDigit y) = False
  | x == ')' && y `notElem` ")E" = False
  | x == 'P' && n == m = True
  | x == ')' && y == ')' = n == (m + 2)
  | x == ')' && y == 'E' = n == (m + 1)
  | (x `elem` "E -") && y == 'E' = n == m 
  | x == 'E' && y == ')' = n == (m + 1)
  | otherwise = False
validOrdStr0 xs@(x:ys) n m 
  | isDigit x || (x `elem` ")E") = if x == ')' then n == (m + 1) else n == m 
  | otherwise = False
validOrdStr0 _ n m  = n == m

-- | An extended predicate to check whether the 'String' is a probably correct representation of the
-- constraints algebraic expression for 'generalConversion' evaluation.
validOrdStr :: String -> Bool
validOrdStr xs = validOrdStr0 xs 0 0 
{-# INLINE validOrdStr #-}

stage1Parsing :: String -> [String]
stage1Parsing =  groupBy (\x y -> x == '(' && y == '(' || isLetter x && isDigit y || x == ')' && y == ')')
{-# INLINE stage1Parsing #-}

convertToBools 
  :: Int 
  -> Array Int Int 
  -> [String] 
  -> String -- ^ The result is a 'String' that Haskell can evaluate to 'Bool' (some logical expression).
convertToBools n arr xss@("-":yss) = "not " `mappend` (convertToBools n arr yss)
convertToBools n arr xss@(" ":yss) = " || " `mappend` (convertToBools n arr yss)
convertToBools n arr xss@(xs:yss@(ys:tss))
  | any (== '(') xs = xs `mappend` " " `mappend` convertToBools n arr yss
  | any (== ')') xs = xs `mappend` (if ys == " " then "" else " && ") `mappend` convertToBools n arr yss
  | xs `elem` ["True","False"] = xs `mappend` (case ys of 
                                                 ')':_ -> " " 
                                                 " "   -> " "
                                                 _     -> " && ") `mappend` convertToBools n arr yss 
  | otherwise = let cnstrs = fromMaybe E . readMaybeECG n $ xs in 
                      show (isConstraint1 True arr cnstrs) 
                      `mappend` (case ys of 
                                   ')':_ -> " " 
                                   " "   -> " "
                                   _     -> " && ") `mappend` convertToBools n arr yss 
convertToBools n arr xss@(xs:yss) 
  | any (== ')') xs = xs 
  | xs `elem` ["True","False"] = xs
  | otherwise = (show . isConstraint1 True arr . fromMaybe E . readMaybeECG n $ xs) -- `mappend` "!!!!!"
convertToBools n arr _ = ""

noParenString :: [String] -> Bool 
noParenString xss@(xs:ys:ts:yss) 
  | xs == "not" = 
      case ys of 
        "True" -> if ts == "&&" then False 
                                else noParenString yss 
        "False" -> if ts == "&&" then noParenString yss 
                                 else True 
  | otherwise = 
      case xs of
        "True" -> if ys == "&&" then noParenString (ts:yss)
                                else True 
        "False" -> if ys == "&&" then False 
                                 else noParenString (ts:yss)
noParenString xss@("not":ys:yss) = if ys == "True" then False else True 
noParenString xss@(xs:yss) 
  | xs == "True" = True 
  | otherwise = False 
noParenString _ = True

oneChange :: Int -> Array Int Int -> [String] -> [String]
oneChange m arr xss 
  | null wss = [show . noParenString . words . convertToBools m arr $ xss]
  | otherwise = ((\(jss, m, qss) -> jss `mappend` [show . noParenString . words . convertToBools m arr $ qss]) . 
                  foldr (\xs uss@(tss, n, rss) -> if xs == "(" && n == 0 
                                                      then (tss, 1, rss) 
                                                      else if any (== '(') xs && n == 0
                                                               then (drop 1 xs:tss, n, rss)
                                                               else case n of 
                                                                      0 -> (tss, 0, xs:rss)
                                                                      1 -> (xs:tss, 1, rss)) ([], 0, []) $ yss) `mappend` kss
  where (yss,wss) = break (any (== ')')) xss
        kss = case wss of
                ws:vss -> if length ws == 1 then vss else drop 1 ws : vss
                _      -> wss

generalConversion :: Int -> String -> Array Int Int -> Bool
generalConversion m xs arr
  | validOrdStr xs =  (\ks -> if ks == "True" || ks == "E" then True else False) . 
      head . head . dropWhile ((/= 1) . length)  . drop 1 . iterate (oneChange m arr) . stage1Parsing $ xs 
  | otherwise = False
{-# INLINE generalConversion #-}

-- | Can be thought of as 'filter' ('generalConversion' ... ) @<arrays>@ but is somewhat more efficient.
filterGeneralConv :: Int -> String -> [Array Int Int] -> [Array Int Int]
filterGeneralConv m cnstrns xs 
  | validOrdStr cnstrns = 
    filter (\arr -> (\ks -> if ks == "True" || ks == "E" then True else False) . head . head . dropWhile ((/= 1) . length) . drop 1 . iterate (oneChange m arr) . stage1Parsing $ cnstrns) xs
  | otherwise = []
{-# INLINE filterGeneralConv #-}

-- | 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'. 
-- It is up to user to check whether the parameters are in the correct form, the function does
-- not do the full checking.
readMaybeECG :: Int -> String -> Maybe EncodedCnstrs
readMaybeECG 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
       _   -> f n h ts
 | otherwise = Nothing
         where f n c ts 
                 | c `elem` "HFMRQTVW" = let ys = nub . catMaybes . map (\t -> readMaybe [t]::Maybe Int) $ ts
                                             res 
                                               | length ys /= g c = Nothing
                                               | c == 'Q' = let [y,z,u,w] = map (\rr -> if rr  == 0 then 9 else rr - 1) ys in Just (Q n y z u w)
                                               | c `elem` "FVW" = let [y,z] = map (\rr -> if rr  == 0 then 9 else rr - 1) ys in Just ((case c of {'F' -> F; 'V'-> V; ~ww -> W}) n y z)
                                               | otherwise = let [y,z,u] = map (\rr -> if rr  == 0 then 9 else rr - 1) ys in Just ((case c of {'T' -> T; 'H' -> H; 'M' -> M; ~rr -> R}) n y z u) in res
                 | c `elem` "AB" = let y = readMaybe (take 1 ts)::Maybe Int in
                                     if isJust y then
                                         let y0 = fromJust y
                                             zs = map (\rr -> if rr  == 0 then 9 else rr - 1) . filter (/= y0) . nub . catMaybes . map (\t -> readMaybe [t]::Maybe Int) . drop 1 $ ts in
                                               case zs of
                                                 [] -> Nothing
                                                 ~x2 -> Just ((if c == 'A' then SA else SB) n (if y0 == 0 then 9 else y0 - 1) (listArray (0,length x2 - 1) x2))
                                     else Nothing 
                 | c == 'P' = if null ts then Just E else Just . P n . listArray (0,length ts - 1) . map (\r -> case (fromJust (readMaybe [r]::Maybe Int)) of {0 -> 9; n -> n-1}) $ ts
                 | otherwise = Nothing
               g c 
                 | c `elem` "FVW" = 2
                 | c == 'Q' = 4
                 | otherwise = 3


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-1] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'. 
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 (abs $ j - i)
decodeConstraint1 (W _ i j) = filterUnsignDistanceIJ i j (abs $ j - i)
decodeConstraint1 (H _ i j k) = filterSignDistanceIJK3 i j k (abs $ j - i) (abs $ 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 (abs $ 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-1] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'.
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

isConstraint1 :: Bool -> Array Int Int -> EncodedCnstrs -> Bool
isConstraint1 bool arr E = bool
isConstraint1 True arr (F _ i j) = unsafeOrderIJ i j arr 
isConstraint1 True arr (T _ i j k) = isTripleOrdered i j k arr 
isConstraint1 True arr (Q _ i j k l) = isQuadrupleOrdered i j k l arr 
isConstraint1 True arr (SA _ i arr2) = isSeveralAOrdered i arr2 arr 
isConstraint1 True arr (SB _ i arr2) = isSeveralBOrdered i arr2 arr 
isConstraint1 True arr (P _ arr2) = isFixedPoint arr2 arr 
isConstraint1 True arr (H _ i j k) = isSignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr 
isConstraint1 True arr (M _ i j k) = isMixedDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr 
isConstraint1 True arr (R _ i j k) = isUnsignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr 
isConstraint1 True arr (V _ i j) = unsafeSignDistanceIJ i j (abs $ j - i) arr 
isConstraint1 True arr (W _ i j) = unsafeUnsignDistanceIJ i j (abs $ j - i) arr 
isConstraint1 False arr (F _ i j) = unsafeOrderIJ j i arr 
isConstraint1 False arr (T _ i j k) = notTripleOrdered i j k arr 
isConstraint1 False arr (Q _ i j k l) = notQuadrupleOrdered i j k l arr 
isConstraint1 False arr (SA _ i arr2) = notSeveralAOrdered i arr2 arr 
isConstraint1 False arr (SB _ i arr2) = notSeveralBOrdered i arr2 arr 
isConstraint1 False arr (P _ arr2) = notFixedPoint arr2 arr 
isConstraint1 False arr (H _ i j k) = notSignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr 
isConstraint1 False arr (M _ i j k) = notMixedDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr 
isConstraint1 False arr (R _ i j k) = notUnsignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr 
isConstraint1 False arr (V _ i j) = unsafeSignDistanceIJ j i (abs $ j - i) arr 
isConstraint1 False arr (W _ i j) = not . unsafeUnsignDistanceIJ i j (abs $ j - i) $ arr 

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 = -1
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 _ E = E
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