{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}

{-|
Module for filtering sequences in Petri net reach/deadlock tasks.

This module provides functions to filter out sequences and solution sets
based on various criteria that make instances too simple or too complicated:

- Cyclic patterns: [t3, t2, t1, t4, t3, t2, t1, t4]
- Repetitive subsequences: [t4, t4, t4, t4] as prefix/suffix
- Grouped repeats: [t3, t3, t2, t2, t1, t1, t4, t4]
- Too many shortest solutions
- Insufficient transition coverage in solutions
- Insufficient number of transitions absent from all solutions
- Solutions are (not) all permutations of each other

The filtering only happens on/with minimal solution sequences for a task.
-}
module Modelling.PetriNet.Reach.Filter (
  -- * Pattern detection
  Sequential (..),
  isCyclicPatternWithAnyOf,
  hasRepetitiveSubsequence,
  hasSpaceballsPrefix,
  hasGroupedRepeats,
  hasInsufficientTransitionCoverage,
  longestSequentialPrefix,

  -- * Solution set validation
  shouldDiscardSolutions,

  -- * Configuration
  FilterConfig(..),
  defaultFilterConfig,
  noFiltering,
) where

import qualified Data.Set                         as Set

import Autolib.Reader                   (Reader)
import Autolib.ToDoc                    (ToDoc)
import Data.Data                        (Data)
import Data.Char                        (isDigit)
import Data.List                        (group, sort)
import Data.List.Extra                  (notNull, nubOrd)
import Data.Ratio                       (Ratio, (%))
import GHC.Generics                     (Generic)
import Modelling.PetriNet.Reach.Type    (Transition (Transition))

-- | Configuration for sequence filtering
data FilterConfig = FilterConfig {
  -- | Enable filtering of grouped repeats (e.g., @[t3,t3,t3,t2,t2,t2,t1,t1]@)
  FilterConfig -> Bool
rejectGroupedRepeats :: !Bool,
  -- | Threshold length for repetitive subsequences to reject
  -- (e.g., @[t4,t4,t4,t4]@ as prefix/suffix)
  --
  -- Sequences with repetitive subsequences of at least this length are filtered out.
  -- 'Nothing' means no filtering of such repetitive subsequences.
  FilterConfig -> Maybe Int
repetitiveSubsequenceThreshold :: !(Maybe Int),
  -- | Threshold length for Spaceballs PIN prefix pattern to reject
  -- (e.g., @[t1,t2,t3,t4,t5]@ as prefix)
  --
  -- Sequences with Spaceballs prefix patterns of at least this length are filtered out.
  -- 'Nothing' means no filtering of such Spaceballs PIN prefix patterns.
  FilterConfig -> Maybe Int
spaceballsPrefixThreshold :: !(Maybe Int),
  -- | Forbidden cycle lengths for cyclic patterns to reject
  -- (e.g., @[t3,t2,t1,t4,t3,t2,t1,t4]@; always full cycles checked)
  --
  -- Sequences with cyclic patterns having one of these cycle lengths are filtered out.
  -- The list should be sorted and contain only true divisors of the target sequence length.
  -- An empty list means no rejection filtering of such cyclic patterns.
  FilterConfig -> [Int]
forbiddenCycleLengths :: ![Int],
  -- | If nonempty, cycle lengths any of which is required for acceptance
  --
  -- Solution sets where no solution has a cyclic pattern with one of these cycle lengths are filtered out.
  -- The list should be sorted and contain only divisors of the target sequence length.
  -- An empty list means no acceptance requirement for cyclic patterns.
  FilterConfig -> [Int]
requireCycleLengthsAny :: ![Int],
  -- | Maximum number of shortest solution sequences in a solution set
  --
  -- Solution sets with more than this many sequences are filtered out.
  -- 'Nothing' means no limit on the number of solution sequences.
  FilterConfig -> Maybe Int
solutionSetLimit :: !(Maybe Int),
  -- | Whether all (shortest) solutions must be permutations of each other
  --
  -- * @True@ means filter out instances where solutions are NOT all permutations
  -- * @False@ means don't care about the permutation property
  FilterConfig -> Bool
requireSolutionsArePermutations :: !Bool,
  -- | Minimum number of transitions required to be absent from all solutions
  --
  -- At least this many transitions from the available transitions
  -- must appear in none of the solution sequences.
  -- A value of @0@ means no filtering based on absent transitions.
  FilterConfig -> Int
absentTransitionsRequirement :: !Int,
  -- | Minimum transition coverage required for each solution
  --
  -- Each solution must use at least this fraction of available transitions.
  -- For example, @4 % 5@ requires that each solution uses at least 80% of
  -- the available transitions. A value of @0@ means no minimum coverage requirement.
  FilterConfig -> Ratio Int
transitionCoverageRequirement :: !(Ratio Int)
  } deriving (Typeable FilterConfig
Typeable FilterConfig =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> FilterConfig -> c FilterConfig)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c FilterConfig)
-> (FilterConfig -> Constr)
-> (FilterConfig -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c FilterConfig))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c FilterConfig))
-> ((forall b. Data b => b -> b) -> FilterConfig -> FilterConfig)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> FilterConfig -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> FilterConfig -> r)
-> (forall u. (forall d. Data d => d -> u) -> FilterConfig -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> FilterConfig -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig)
-> Data FilterConfig
FilterConfig -> Constr
FilterConfig -> DataType
(forall b. Data b => b -> b) -> FilterConfig -> FilterConfig
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> FilterConfig -> u
forall u. (forall d. Data d => d -> u) -> FilterConfig -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FilterConfig -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FilterConfig -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FilterConfig
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FilterConfig -> c FilterConfig
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FilterConfig)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FilterConfig)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FilterConfig -> c FilterConfig
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FilterConfig -> c FilterConfig
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FilterConfig
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FilterConfig
$ctoConstr :: FilterConfig -> Constr
toConstr :: FilterConfig -> Constr
$cdataTypeOf :: FilterConfig -> DataType
dataTypeOf :: FilterConfig -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FilterConfig)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FilterConfig)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FilterConfig)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c FilterConfig)
$cgmapT :: (forall b. Data b => b -> b) -> FilterConfig -> FilterConfig
gmapT :: (forall b. Data b => b -> b) -> FilterConfig -> FilterConfig
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FilterConfig -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FilterConfig -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FilterConfig -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FilterConfig -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> FilterConfig -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> FilterConfig -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> FilterConfig -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> FilterConfig -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FilterConfig -> m FilterConfig
Data, FilterConfig -> FilterConfig -> Bool
(FilterConfig -> FilterConfig -> Bool)
-> (FilterConfig -> FilterConfig -> Bool) -> Eq FilterConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilterConfig -> FilterConfig -> Bool
== :: FilterConfig -> FilterConfig -> Bool
$c/= :: FilterConfig -> FilterConfig -> Bool
/= :: FilterConfig -> FilterConfig -> Bool
Eq, (forall x. FilterConfig -> Rep FilterConfig x)
-> (forall x. Rep FilterConfig x -> FilterConfig)
-> Generic FilterConfig
forall x. Rep FilterConfig x -> FilterConfig
forall x. FilterConfig -> Rep FilterConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FilterConfig -> Rep FilterConfig x
from :: forall x. FilterConfig -> Rep FilterConfig x
$cto :: forall x. Rep FilterConfig x -> FilterConfig
to :: forall x. Rep FilterConfig x -> FilterConfig
Generic, Eq FilterConfig
Eq FilterConfig =>
(FilterConfig -> FilterConfig -> Ordering)
-> (FilterConfig -> FilterConfig -> Bool)
-> (FilterConfig -> FilterConfig -> Bool)
-> (FilterConfig -> FilterConfig -> Bool)
-> (FilterConfig -> FilterConfig -> Bool)
-> (FilterConfig -> FilterConfig -> FilterConfig)
-> (FilterConfig -> FilterConfig -> FilterConfig)
-> Ord FilterConfig
FilterConfig -> FilterConfig -> Bool
FilterConfig -> FilterConfig -> Ordering
FilterConfig -> FilterConfig -> FilterConfig
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FilterConfig -> FilterConfig -> Ordering
compare :: FilterConfig -> FilterConfig -> Ordering
$c< :: FilterConfig -> FilterConfig -> Bool
< :: FilterConfig -> FilterConfig -> Bool
$c<= :: FilterConfig -> FilterConfig -> Bool
<= :: FilterConfig -> FilterConfig -> Bool
$c> :: FilterConfig -> FilterConfig -> Bool
> :: FilterConfig -> FilterConfig -> Bool
$c>= :: FilterConfig -> FilterConfig -> Bool
>= :: FilterConfig -> FilterConfig -> Bool
$cmax :: FilterConfig -> FilterConfig -> FilterConfig
max :: FilterConfig -> FilterConfig -> FilterConfig
$cmin :: FilterConfig -> FilterConfig -> FilterConfig
min :: FilterConfig -> FilterConfig -> FilterConfig
Ord, Parser [FilterConfig]
Parser FilterConfig
Int -> Parser FilterConfig
Parser FilterConfig
-> (Int -> Parser FilterConfig)
-> Parser FilterConfig
-> (Int -> Parser FilterConfig)
-> Parser [FilterConfig]
-> Reader FilterConfig
forall a.
Parser a
-> (Int -> Parser a)
-> Parser a
-> (Int -> Parser a)
-> Parser [a]
-> Reader a
$catomic_reader :: Parser FilterConfig
atomic_reader :: Parser FilterConfig
$catomic_readerPrec :: Int -> Parser FilterConfig
atomic_readerPrec :: Int -> Parser FilterConfig
$creader :: Parser FilterConfig
reader :: Parser FilterConfig
$creaderPrec :: Int -> Parser FilterConfig
readerPrec :: Int -> Parser FilterConfig
$creaderList :: Parser [FilterConfig]
readerList :: Parser [FilterConfig]
Reader, ReadPrec [FilterConfig]
ReadPrec FilterConfig
Int -> ReadS FilterConfig
ReadS [FilterConfig]
(Int -> ReadS FilterConfig)
-> ReadS [FilterConfig]
-> ReadPrec FilterConfig
-> ReadPrec [FilterConfig]
-> Read FilterConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS FilterConfig
readsPrec :: Int -> ReadS FilterConfig
$creadList :: ReadS [FilterConfig]
readList :: ReadS [FilterConfig]
$creadPrec :: ReadPrec FilterConfig
readPrec :: ReadPrec FilterConfig
$creadListPrec :: ReadPrec [FilterConfig]
readListPrec :: ReadPrec [FilterConfig]
Read, Int -> FilterConfig -> ShowS
[FilterConfig] -> ShowS
FilterConfig -> String
(Int -> FilterConfig -> ShowS)
-> (FilterConfig -> String)
-> ([FilterConfig] -> ShowS)
-> Show FilterConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilterConfig -> ShowS
showsPrec :: Int -> FilterConfig -> ShowS
$cshow :: FilterConfig -> String
show :: FilterConfig -> String
$cshowList :: [FilterConfig] -> ShowS
showList :: [FilterConfig] -> ShowS
Show, Int -> FilterConfig -> Doc
[FilterConfig] -> Doc
(Int -> FilterConfig -> Doc)
-> ([FilterConfig] -> Doc) -> ToDoc FilterConfig
forall a. (Int -> a -> Doc) -> ([a] -> Doc) -> ToDoc a
$ctoDocPrec :: Int -> FilterConfig -> Doc
toDocPrec :: Int -> FilterConfig -> Doc
$ctoDocList :: [FilterConfig] -> Doc
toDocList :: [FilterConfig] -> Doc
ToDoc)

noFiltering :: FilterConfig
noFiltering :: FilterConfig
noFiltering = FilterConfig {
  rejectGroupedRepeats :: Bool
rejectGroupedRepeats = Bool
False,
  repetitiveSubsequenceThreshold :: Maybe Int
repetitiveSubsequenceThreshold = Maybe Int
forall a. Maybe a
Nothing,
  spaceballsPrefixThreshold :: Maybe Int
spaceballsPrefixThreshold = Maybe Int
forall a. Maybe a
Nothing,
  forbiddenCycleLengths :: [Int]
forbiddenCycleLengths = [],
  requireCycleLengthsAny :: [Int]
requireCycleLengthsAny = [],
  solutionSetLimit :: Maybe Int
solutionSetLimit = Maybe Int
forall a. Maybe a
Nothing,
  requireSolutionsArePermutations :: Bool
requireSolutionsArePermutations = Bool
False,
  absentTransitionsRequirement :: Int
absentTransitionsRequirement = Int
0,
  transitionCoverageRequirement :: Ratio Int
transitionCoverageRequirement = Ratio Int
0
  }

-- | Default filter configuration that enables all filters
defaultFilterConfig :: FilterConfig
defaultFilterConfig :: FilterConfig
defaultFilterConfig = FilterConfig {
  rejectGroupedRepeats :: Bool
rejectGroupedRepeats = Bool
True,
  repetitiveSubsequenceThreshold :: Maybe Int
repetitiveSubsequenceThreshold = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3,
  spaceballsPrefixThreshold :: Maybe Int
spaceballsPrefixThreshold = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4,
  forbiddenCycleLengths :: [Int]
forbiddenCycleLengths = [Int
2, Int
3],
  requireCycleLengthsAny :: [Int]
requireCycleLengthsAny = [Int
5],
  solutionSetLimit :: Maybe Int
solutionSetLimit = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
15,
  requireSolutionsArePermutations :: Bool
requireSolutionsArePermutations = Bool
True,
  absentTransitionsRequirement :: Int
absentTransitionsRequirement = Int
1,
  transitionCoverageRequirement :: Ratio Int
transitionCoverageRequirement = Int
4 Int -> Int -> Ratio Int
forall a. Integral a => a -> a -> Ratio a
% Int
5
  }

class Sequential a where
  nextInSequence :: a -> Maybe a

instance Sequential Int where
  nextInSequence :: Int -> Maybe Int
nextInSequence = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
succ

instance Sequential Transition where
  nextInSequence :: Transition -> Maybe Transition
nextInSequence (Transition String
name) = String -> Transition
Transition (String -> Transition) -> Maybe String -> Maybe Transition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String
incrementTrailingNumber String
name

incrementTrailingNumber :: String -> Maybe String
incrementTrailingNumber :: String -> Maybe String
incrementTrailingNumber String
name
  | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
reversedDigits = Maybe String
forall a. Maybe a
Nothing
  | Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
reversedPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. Read a => String -> a
read (ShowS
forall a. [a] -> [a]
reverse String
reversedDigits) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 :: Int)
  where
    (String
reversedDigits, String
reversedPrefix) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
name

-- | Check if a sequence has insufficient transition coverage
hasInsufficientTransitionCoverage :: Ord a => Int -> [a] -> Ratio Int -> Bool
hasInsufficientTransitionCoverage :: forall a. Ord a => Int -> [a] -> Ratio Int -> Bool
hasInsufficientTransitionCoverage Int
totalTransitions [a]
transitionSequence Ratio Int
minCoverage
  = let usedCount :: Int
usedCount = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> [a]
forall a. Ord a => [a] -> [a]
nubOrd [a]
transitionSequence)
    in Int -> Ratio Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
usedCount Ratio Int -> Ratio Int -> Bool
forall a. Ord a => a -> a -> Bool
< Ratio Int
minCoverage Ratio Int -> Ratio Int -> Ratio Int
forall a. Num a => a -> a -> a
* Int -> Ratio Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totalTransitions

-- | Check if a sequence begins with a Spaceballs PIN pattern
hasSpaceballsPrefix :: (Eq a, Sequential a) => Int -> [a] -> Bool
hasSpaceballsPrefix :: forall a. (Eq a, Sequential a) => Int -> [a] -> Bool
hasSpaceballsPrefix Int
minLength = (Int
minLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool) -> ([a] -> Int) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> ([a] -> [a]) -> [a] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
minLength ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. (Eq a, Sequential a) => [a] -> [a]
longestSequentialPrefix

-- | Check if a sequence follows a cyclic pattern (e.g., @[t3,t2,t1,t4,t3,t2,t1,t4]@)
-- The pattern is considered cyclic if it can be represented as `take n (cycle pattern)`
-- where `length pattern` is one of the given cycle lengths
isCyclicPatternWithAnyOf :: Eq a => [Int] -> [a] -> Bool
isCyclicPatternWithAnyOf :: forall a. Eq a => [Int] -> [a] -> Bool
isCyclicPatternWithAnyOf [Int]
cycleLengths [a]
xs = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> [a] -> Int -> Bool
forall a. Eq a => Int -> [a] -> Int -> Bool
isCyclicWith ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) [a]
xs) [Int]
cycleLengths
  where
    isCyclicWith :: Eq a => Int -> [a] -> Int -> Bool
    isCyclicWith :: forall a. Eq a => Int -> [a] -> Int -> Bool
isCyclicWith Int
n [a]
seqToCheck Int
cycleLength =
      [a]
seqToCheck [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
cycle (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
cycleLength [a]
seqToCheck))

-- | Check if a sequence has repetitive subsequences as prefix or suffix
-- (e.g., [t4,t4,t4,t4] at the beginning or end)
hasRepetitiveSubsequence :: Eq a => Int -> [a] -> Bool
hasRepetitiveSubsequence :: forall a. Eq a => Int -> [a] -> Bool
hasRepetitiveSubsequence Int
minLength [a]
xs =
  [a] -> Bool
forall {a}. Eq a => [a] -> Bool
allEqual (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
minLength [a]
xs) Bool -> Bool -> Bool
|| [a] -> Bool
forall {a}. Eq a => [a] -> Bool
allEqual (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
minLength ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs))
  where
    allEqual :: [a] -> Bool
allEqual [] = Bool
True
    allEqual (a
y:[a]
ys) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y) [a]
ys

-- | Check if a sequence has grouped repeats (e.g., @[t3,t3,t3,t1,t1,t1,t4,t4]@)
-- This means each unique element appears in consecutive groups of size > 1
hasGroupedRepeats :: Eq a => [a] -> Bool
hasGroupedRepeats :: forall {a}. Eq a => [a] -> Bool
hasGroupedRepeats [a]
xs =
  [[a]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
groups Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2      -- At least 2 different groups
  Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) [Int]
groupSizes -- Group sizes are > 1
  where
    groups :: [[a]]
groups = [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group [a]
xs
    groupSizes :: [Int]
groupSizes = ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
groups

-- | Check if a set of solutions should be discarded according to the given configuration
--
-- Returns 'True' if the solution set should be discarded (filtered out),
-- 'False' if it should be kept.
shouldDiscardSolutions :: (Ord a, Sequential a) => FilterConfig -> Int -> [[a]] -> Bool
shouldDiscardSolutions :: forall a.
(Ord a, Sequential a) =>
FilterConfig -> Int -> [[a]] -> Bool
shouldDiscardSolutions FilterConfig{Bool
Int
[Int]
Maybe Int
Ratio Int
rejectGroupedRepeats :: FilterConfig -> Bool
repetitiveSubsequenceThreshold :: FilterConfig -> Maybe Int
spaceballsPrefixThreshold :: FilterConfig -> Maybe Int
forbiddenCycleLengths :: FilterConfig -> [Int]
requireCycleLengthsAny :: FilterConfig -> [Int]
solutionSetLimit :: FilterConfig -> Maybe Int
requireSolutionsArePermutations :: FilterConfig -> Bool
absentTransitionsRequirement :: FilterConfig -> Int
transitionCoverageRequirement :: FilterConfig -> Ratio Int
rejectGroupedRepeats :: Bool
repetitiveSubsequenceThreshold :: Maybe Int
spaceballsPrefixThreshold :: Maybe Int
forbiddenCycleLengths :: [Int]
requireCycleLengthsAny :: [Int]
solutionSetLimit :: Maybe Int
requireSolutionsArePermutations :: Bool
absentTransitionsRequirement :: Int
transitionCoverageRequirement :: Ratio Int
..} Int
numTransitions [[a]]
solutions =
  Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Int
n -> [[a]] -> Bool
forall a. [a] -> Bool
notNull (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
drop Int
n [[a]]
solutions)) Maybe Int
solutionSetLimit
  Bool -> Bool -> Bool
|| Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [[a]]
solutions) (([a] -> Bool) -> Bool) -> (Int -> [a] -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> Bool
forall a. (Eq a, Sequential a) => Int -> [a] -> Bool
hasSpaceballsPrefix) Maybe Int
spaceballsPrefixThreshold
  Bool -> Bool -> Bool
|| [Int] -> Bool
forall a. [a] -> Bool
notNull [Int]
forbiddenCycleLengths Bool -> Bool -> Bool
&& ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Int] -> [a] -> Bool
forall a. Eq a => [Int] -> [a] -> Bool
isCyclicPatternWithAnyOf [Int]
forbiddenCycleLengths) [[a]]
solutions
  Bool -> Bool -> Bool
|| [Int] -> Bool
forall a. [a] -> Bool
notNull [Int]
requireCycleLengthsAny Bool -> Bool -> Bool
&& Bool -> Bool
not (([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Int] -> [a] -> Bool
forall a. Eq a => [Int] -> [a] -> Bool
isCyclicPatternWithAnyOf [Int]
requireCycleLengthsAny) [[a]]
solutions)
  Bool -> Bool -> Bool
|| Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [[a]]
solutions) (([a] -> Bool) -> Bool) -> (Int -> [a] -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> Bool
forall a. Eq a => Int -> [a] -> Bool
hasRepetitiveSubsequence) Maybe Int
repetitiveSubsequenceThreshold
  Bool -> Bool -> Bool
|| Bool
rejectGroupedRepeats Bool -> Bool -> Bool
&& ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [a] -> Bool
forall {a}. Eq a => [a] -> Bool
hasGroupedRepeats [[a]]
solutions
  Bool -> Bool -> Bool
|| Ratio Int
transitionCoverageRequirement Ratio Int -> Ratio Int -> Bool
forall a. Ord a => a -> a -> Bool
> Ratio Int
0 Bool -> Bool -> Bool
&& ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> [a] -> Ratio Int -> Bool
forall a. Ord a => Int -> [a] -> Ratio Int -> Bool
hasInsufficientTransitionCoverage Int
numTransitions ([a] -> Ratio Int -> Bool) -> Ratio Int -> [a] -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
`flip` Ratio Int
transitionCoverageRequirement) [[a]]
solutions
  Bool -> Bool -> Bool
|| Int
absentTransitionsRequirement Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int -> [[a]] -> Int
forall a. Ord a => Int -> [[a]] -> Int
countAbsentTransitions Int
numTransitions [[a]]
solutions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
absentTransitionsRequirement
  Bool -> Bool -> Bool
|| Bool
requireSolutionsArePermutations Bool -> Bool -> Bool
&& Bool -> Bool
not ([[a]] -> Bool
forall a. Ord a => [[a]] -> Bool
areAllPermutationsOfEachOther [[a]]
solutions)

-- | Count the number of transitions that appear in none of the solutions
countAbsentTransitions :: Ord a => Int -> [[a]] -> Int
countAbsentTransitions :: forall a. Ord a => Int -> [[a]] -> Int
countAbsentTransitions Int
totalTransitions [[a]]
solutions =
  let usedTransitions :: Set a
usedTransitions = [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (([a] -> Set a) -> [[a]] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [[a]]
solutions)
  in Int
totalTransitions Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set a -> Int
forall a. Set a -> Int
Set.size Set a
usedTransitions

-- | Check if all solutions are permutations of each other
areAllPermutationsOfEachOther :: Ord a => [[a]] -> Bool
areAllPermutationsOfEachOther :: forall a. Ord a => [[a]] -> Bool
areAllPermutationsOfEachOther [] = Bool
True
areAllPermutationsOfEachOther ([a]
firstSolution:[[a]]
restSolutions) =
  let sortedFirst :: [a]
sortedFirst = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
firstSolution
  in ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[a]
solution -> [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
solution [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
sortedFirst) [[a]]
restSolutions

longestSequentialPrefix :: (Eq a, Sequential a) => [a] -> [a]
longestSequentialPrefix :: forall a. (Eq a, Sequential a) => [a] -> [a]
longestSequentialPrefix [] = []
longestSequentialPrefix (a
firstElement:[a]
remainingElements) =
  a
firstElement a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> [a]
forall {t}. (Sequential t, Eq t) => t -> [t] -> [t]
collectSequentialElements a
firstElement [a]
remainingElements
  where
    collectSequentialElements :: t -> [t] -> [t]
collectSequentialElements t
currentElement (t
nextElement:[t]
tailElements)
      | Just t
expectedElement <- t -> Maybe t
forall a. Sequential a => a -> Maybe a
nextInSequence t
currentElement
      , t
expectedElement t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
nextElement
      = t
nextElement t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
collectSequentialElements t
nextElement [t]
tailElements
    collectSequentialElements t
_ [t]
_ = []