{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

{- | Candidate-pool scoring and boolean expansion: penalized scoring, diverse
top-K selection, AND/OR saturation, and structural/truth-vector dedup. The
per-node scoring scans run in parallel chunks.
-}
module DataFrame.DecisionTree.Pool (
    evalWithPenaltyVec,
    primaryColExpr,
    primaryColCV,
    takeDiverse,
    candidateParChunk,
    bestDiscreteCandidate,
    boolExprsVec,
    DedupMode (..),
    saturateCandidates,
    roundProducts,
    admitKeys,
    admitVecs,
    dedupCVByExpr,
    nubByExpr,
) where

import DataFrame.DecisionTree.CondVec (
    CondVec (..),
    combineAndVec,
    combineOrVec,
    countErrorsByVec,
 )
import DataFrame.DecisionTree.Types (
    CarePoint,
    SynthConfig (..),
    TreeConfig (..),
 )
import DataFrame.Internal.Expression (
    Expr,
    compareExpr,
    eSize,
    eqExpr,
    getColumns,
    normalize,
 )

import Control.Parallel.Strategies (parListChunk, rdeepseq, using)
import Data.Function (on)
import Data.List (minimumBy, sortBy)
import qualified Data.Map.Strict as M
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Vector.Unboxed as VU

{- | Penalized score of a candidate: care-point errors plus a complexity
penalty, tie-broken by expression size.
-}
evalWithPenaltyVec :: TreeConfig -> [CarePoint] -> CondVec -> (Int, Int)
evalWithPenaltyVec :: TreeConfig -> [CarePoint] -> CondVec -> (Int, Int)
evalWithPenaltyVec TreeConfig
cfg [CarePoint]
carePoints CondVec
cv = (Vector Bool -> [CarePoint] -> Int
countErrorsByVec (CondVec -> Vector Bool
cvVec CondVec
cv) [CarePoint]
carePoints Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
penalty, Int
sz)
  where
    sz :: Int
sz = Expr Bool -> Int
forall a. Expr a -> Int
eSize (CondVec -> Expr Bool
cvExpr CondVec
cv)
    penalty :: Int
penalty = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (SynthConfig -> Double
complexityPenalty (TreeConfig -> SynthConfig
synthConfig TreeConfig
cfg) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz)

{- | First referenced column of a condition (a sentinel for literal-only ones),
used by 'takeDiverse' to enforce per-column diversity.
-}
primaryColExpr :: Expr Bool -> T.Text
primaryColExpr :: Expr Bool -> Text
primaryColExpr Expr Bool
e = case Expr Bool -> [Text]
forall a. Expr a -> [Text]
getColumns Expr Bool
e of
    [] -> Text
"<noncol>"
    (Text
c : [Text]
_) -> Text
c

primaryColCV :: CondVec -> T.Text
primaryColCV :: CondVec -> Text
primaryColCV = Expr Bool -> Text
primaryColExpr (Expr Bool -> Text) -> (CondVec -> Expr Bool) -> CondVec -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CondVec -> Expr Bool
cvExpr

{- | Keep the first @k@ of an already-sorted list, admitting at most @quota@ per
primary column (@Nothing@ disables the per-column cap).
-}
takeDiverse :: Int -> Maybe Int -> (a -> T.Text) -> [a] -> [a]
takeDiverse :: forall a. Int -> Maybe Int -> (a -> Text) -> [a] -> [a]
takeDiverse Int
k Maybe Int
Nothing a -> Text
_ = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
k
takeDiverse Int
k (Just Int
quota) a -> Text
primary = Map Text Int -> Int -> [a] -> [a]
go Map Text Int
forall k a. Map k a
M.empty Int
0
  where
    go :: Map Text Int -> Int -> [a] -> [a]
go !Map Text Int
_ !Int
_ [] = []
    go !Map Text Int
seen !Int
n (a
x : [a]
xs)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
k = []
        | Int -> Text -> Map Text Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 Text
col Map Text Int
seen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
quota = Map Text Int -> Int -> [a] -> [a]
go Map Text Int
seen Int
n [a]
xs
        | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Map Text Int -> Int -> [a] -> [a]
go ((Int -> Int -> Int) -> Text -> Int -> Map Text Int -> Map Text Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Text
col Int
1 Map Text Int
seen) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
xs
      where
        !col :: Text
col = a -> Text
primary a
x

{- | Chunk size for the parallel per-node candidate scans; tuned by an -N
sweep, not correctness-affecting.
-}
candidateParChunk :: Int
candidateParChunk :: Int
candidateParChunk = Int
64

{- | Decorate candidates with their penalty in parallel chunks, forcing only
the @(Int, Int)@ key so the order (hence later sorts/minima) is preserved.
-}
decorate :: (CondVec -> (Int, Int)) -> [CondVec] -> [((Int, Int), CondVec)]
decorate :: (CondVec -> (Int, Int)) -> [CondVec] -> [((Int, Int), CondVec)]
decorate CondVec -> (Int, Int)
penaltyCV [CondVec]
xs = [(Int, Int)] -> [CondVec] -> [((Int, Int), CondVec)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((CondVec -> (Int, Int)) -> [CondVec] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map CondVec -> (Int, Int)
penaltyCV [CondVec]
xs [(Int, Int)] -> Strategy [(Int, Int)] -> [(Int, Int)]
forall a. a -> Strategy a -> a
`using` Int -> Strategy (Int, Int) -> Strategy [(Int, Int)]
forall a. Int -> Strategy a -> Strategy [a]
parListChunk Int
candidateParChunk Strategy (Int, Int)
forall a. NFData a => Strategy a
rdeepseq) [CondVec]
xs

-- | The diverse top-@expressionPairs@ valid candidates by penalty.
sortedTopK :: TreeConfig -> (CondVec -> (Int, Int)) -> [CondVec] -> [CondVec]
sortedTopK :: TreeConfig -> (CondVec -> (Int, Int)) -> [CondVec] -> [CondVec]
sortedTopK TreeConfig
cfg CondVec -> (Int, Int)
penaltyCV [CondVec]
validCondVecs =
    (((Int, Int), CondVec) -> CondVec)
-> [((Int, Int), CondVec)] -> [CondVec]
forall a b. (a -> b) -> [a] -> [b]
map
        ((Int, Int), CondVec) -> CondVec
forall a b. (a, b) -> b
snd
        ( Int
-> Maybe Int
-> (((Int, Int), CondVec) -> Text)
-> [((Int, Int), CondVec)]
-> [((Int, Int), CondVec)]
forall a. Int -> Maybe Int -> (a -> Text) -> [a] -> [a]
takeDiverse
            (TreeConfig -> Int
expressionPairs TreeConfig
cfg)
            (SynthConfig -> Maybe Int
perColumnQuota (TreeConfig -> SynthConfig
synthConfig TreeConfig
cfg))
            (CondVec -> Text
primaryColCV (CondVec -> Text)
-> (((Int, Int), CondVec) -> CondVec)
-> ((Int, Int), CondVec)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int), CondVec) -> CondVec
forall a b. (a, b) -> b
snd)
            [((Int, Int), CondVec)]
sorted
        )
  where
    sorted :: [((Int, Int), CondVec)]
sorted = (((Int, Int), CondVec) -> ((Int, Int), CondVec) -> Ordering)
-> [((Int, Int), CondVec)] -> [((Int, Int), CondVec)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Int) -> (Int, Int) -> Ordering)
-> (((Int, Int), CondVec) -> (Int, Int))
-> ((Int, Int), CondVec)
-> ((Int, Int), CondVec)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Int, Int), CondVec) -> (Int, Int)
forall a b. (a, b) -> a
fst) ((CondVec -> (Int, Int)) -> [CondVec] -> [((Int, Int), CondVec)]
decorate CondVec -> (Int, Int)
penaltyCV [CondVec]
validCondVecs)

-- | Lowest-penalty candidate after boolean saturation of the diverse top-K.
bestDiscreteCandidate ::
    TreeConfig -> (CondVec -> (Int, Int)) -> [CondVec] -> Maybe CondVec
bestDiscreteCandidate :: TreeConfig -> (CondVec -> (Int, Int)) -> [CondVec] -> Maybe CondVec
bestDiscreteCandidate TreeConfig
_ CondVec -> (Int, Int)
_ [] = Maybe CondVec
forall a. Maybe a
Nothing
bestDiscreteCandidate TreeConfig
cfg CondVec -> (Int, Int)
penaltyCV [CondVec]
validCondVecs =
    case DedupMode -> Int -> [CondVec] -> [CondVec]
saturateCandidates
        DedupMode
Structural
        (SynthConfig -> Int
boolExpansion (TreeConfig -> SynthConfig
synthConfig TreeConfig
cfg))
        (TreeConfig -> (CondVec -> (Int, Int)) -> [CondVec] -> [CondVec]
sortedTopK TreeConfig
cfg CondVec -> (Int, Int)
penaltyCV [CondVec]
validCondVecs) of
        [] -> Maybe CondVec
forall a. Maybe a
Nothing
        [CondVec]
xs -> CondVec -> Maybe CondVec
forall a. a -> Maybe a
Just (((Int, Int), CondVec) -> CondVec
forall a b. (a, b) -> b
snd ((((Int, Int), CondVec) -> ((Int, Int), CondVec) -> Ordering)
-> [((Int, Int), CondVec)] -> ((Int, Int), CondVec)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Int, Int) -> (Int, Int) -> Ordering)
-> (((Int, Int), CondVec) -> (Int, Int))
-> ((Int, Int), CondVec)
-> ((Int, Int), CondVec)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Int, Int), CondVec) -> (Int, Int)
forall a b. (a, b) -> a
fst) ((CondVec -> (Int, Int)) -> [CondVec] -> [((Int, Int), CondVec)]
decorate CondVec -> (Int, Int)
penaltyCV [CondVec]
xs)))

{- | AND/OR expansion of cached conditions to depth @maxDepth@ (each
combination is a single vector op, not an interpret).
-}
boolExprsVec :: [CondVec] -> [CondVec] -> Int -> Int -> [CondVec]
boolExprsVec :: [CondVec] -> [CondVec] -> Int -> Int -> [CondVec]
boolExprsVec [CondVec]
baseExprs [CondVec]
prevExprs Int
depth Int
maxDepth
    | Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
        [CondVec]
baseExprs [CondVec] -> [CondVec] -> [CondVec]
forall a. [a] -> [a] -> [a]
++ [CondVec] -> [CondVec] -> Int -> Int -> [CondVec]
boolExprsVec [CondVec]
baseExprs [CondVec]
prevExprs (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
maxDepth
    | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxDepth = []
    | Bool
otherwise = [CondVec]
combined [CondVec] -> [CondVec] -> [CondVec]
forall a. [a] -> [a] -> [a]
++ [CondVec] -> [CondVec] -> Int -> Int -> [CondVec]
boolExprsVec [CondVec]
baseExprs [CondVec]
combined (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
maxDepth
  where
    combined :: [CondVec]
combined = [CondVec] -> [CondVec] -> [CondVec]
roundProducts [CondVec]
prevExprs [CondVec]
baseExprs

data DedupMode = Structural | TruthVector
    deriving (DedupMode -> DedupMode -> Bool
(DedupMode -> DedupMode -> Bool)
-> (DedupMode -> DedupMode -> Bool) -> Eq DedupMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DedupMode -> DedupMode -> Bool
== :: DedupMode -> DedupMode -> Bool
$c/= :: DedupMode -> DedupMode -> Bool
/= :: DedupMode -> DedupMode -> Bool
Eq, Int -> DedupMode -> ShowS
[DedupMode] -> ShowS
DedupMode -> String
(Int -> DedupMode -> ShowS)
-> (DedupMode -> String)
-> ([DedupMode] -> ShowS)
-> Show DedupMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DedupMode -> ShowS
showsPrec :: Int -> DedupMode -> ShowS
$cshow :: DedupMode -> String
show :: DedupMode -> String
$cshowList :: [DedupMode] -> ShowS
showList :: [DedupMode] -> ShowS
Show)

{- | Saturate the pool with AND/OR combinations, deduplicating structurally
(byte-identical, first occurrence kept) or by truth vector (opt-in).
-}
saturateCandidates :: DedupMode -> Int -> [CondVec] -> [CondVec]
saturateCandidates :: DedupMode -> Int -> [CondVec] -> [CondVec]
saturateCandidates DedupMode
Structural Int
maxDepth [CondVec]
base = [CondVec]
base' [CondVec] -> [CondVec] -> [CondVec]
forall a. [a] -> [a] -> [a]
++ Int -> [CondVec] -> Set String -> [CondVec]
go Int
1 [CondVec]
base' Set String
seen0
  where
    ([CondVec]
base', Set String
seen0) = Set String -> [CondVec] -> ([CondVec], Set String)
admitKeys Set String
forall a. Set a
Set.empty [CondVec]
base
    go :: Int -> [CondVec] -> Set String -> [CondVec]
go !Int
depth [CondVec]
frontier Set String
seen
        | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxDepth Bool -> Bool -> Bool
|| [CondVec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CondVec]
frontier = []
        | Bool
otherwise =
            let ([CondVec]
admitted, Set String
seen') = Set String -> [CondVec] -> ([CondVec], Set String)
admitKeys Set String
seen ([CondVec] -> [CondVec] -> [CondVec]
roundProducts [CondVec]
frontier [CondVec]
base)
             in [CondVec]
admitted [CondVec] -> [CondVec] -> [CondVec]
forall a. [a] -> [a] -> [a]
++ Int -> [CondVec] -> Set String -> [CondVec]
go (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [CondVec]
admitted Set String
seen'
saturateCandidates DedupMode
TruthVector Int
maxDepth [CondVec]
base = Map (Vector Bool) CondVec -> [CondVec]
forall k a. Map k a -> [a]
M.elems (Int
-> [CondVec]
-> Map (Vector Bool) CondVec
-> Map (Vector Bool) CondVec
go Int
1 [CondVec]
frontier0 Map (Vector Bool) CondVec
reps0)
  where
    (Map (Vector Bool) CondVec
reps0, [CondVec]
frontier0) = Map (Vector Bool) CondVec
-> [CondVec] -> (Map (Vector Bool) CondVec, [CondVec])
admitVecs Map (Vector Bool) CondVec
forall k a. Map k a
M.empty [CondVec]
base
    go :: Int
-> [CondVec]
-> Map (Vector Bool) CondVec
-> Map (Vector Bool) CondVec
go !Int
depth [CondVec]
frontier Map (Vector Bool) CondVec
reps
        | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxDepth Bool -> Bool -> Bool
|| [CondVec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CondVec]
frontier = Map (Vector Bool) CondVec
reps
        | Bool
otherwise =
            let (Map (Vector Bool) CondVec
reps', [CondVec]
admitted) = Map (Vector Bool) CondVec
-> [CondVec] -> (Map (Vector Bool) CondVec, [CondVec])
admitVecs Map (Vector Bool) CondVec
reps ([CondVec] -> [CondVec] -> [CondVec]
roundProducts [CondVec]
frontier [CondVec]
base)
             in Int
-> [CondVec]
-> Map (Vector Bool) CondVec
-> Map (Vector Bool) CondVec
go (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [CondVec]
admitted Map (Vector Bool) CondVec
reps'

{- | One combination round: @frontier × base@ via AND then OR, skipping
self-pairs (mirrors 'boolExprsVec' for byte-identical structural output).
-}
roundProducts :: [CondVec] -> [CondVec] -> [CondVec]
roundProducts :: [CondVec] -> [CondVec] -> [CondVec]
roundProducts [CondVec]
frontier [CondVec]
base =
    [ CondVec
c
    | CondVec
e1 <- [CondVec]
frontier
    , CondVec
e2 <- [CondVec]
base
    , Bool -> Bool
not (Expr Bool -> Expr Bool -> Bool
forall a. Columnable a => Expr a -> Expr a -> Bool
eqExpr (CondVec -> Expr Bool
cvExpr CondVec
e1) (CondVec -> Expr Bool
cvExpr CondVec
e2))
    , CondVec
c <- [CondVec -> CondVec -> CondVec
combineAndVec CondVec
e1 CondVec
e2, CondVec -> CondVec -> CondVec
combineOrVec CondVec
e1 CondVec
e2]
    ]

-- | Admit candidates with a not-yet-seen normalized form, preserving order.
admitKeys :: Set.Set String -> [CondVec] -> ([CondVec], Set.Set String)
admitKeys :: Set String -> [CondVec] -> ([CondVec], Set String)
admitKeys = [CondVec] -> Set String -> [CondVec] -> ([CondVec], Set String)
go []
  where
    go :: [CondVec] -> Set String -> [CondVec] -> ([CondVec], Set String)
go [CondVec]
acc Set String
seen [] = ([CondVec] -> [CondVec]
forall a. [a] -> [a]
reverse [CondVec]
acc, Set String
seen)
    go [CondVec]
acc !Set String
seen (CondVec
c : [CondVec]
cs)
        | CondVec -> String
structuralKey CondVec
c String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
seen = [CondVec] -> Set String -> [CondVec] -> ([CondVec], Set String)
go [CondVec]
acc Set String
seen [CondVec]
cs
        | Bool
otherwise = [CondVec] -> Set String -> [CondVec] -> ([CondVec], Set String)
go (CondVec
c CondVec -> [CondVec] -> [CondVec]
forall a. a -> [a] -> [a]
: [CondVec]
acc) (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert (CondVec -> String
structuralKey CondVec
c) Set String
seen) [CondVec]
cs

structuralKey :: CondVec -> String
structuralKey :: CondVec -> String
structuralKey = Expr Bool -> String
forall a. Show a => a -> String
show (Expr Bool -> String)
-> (CondVec -> Expr Bool) -> CondVec -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Bool -> Expr Bool
forall a. (Show a, Typeable a) => Expr a -> Expr a
normalize (Expr Bool -> Expr Bool)
-> (CondVec -> Expr Bool) -> CondVec -> Expr Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CondVec -> Expr Bool
cvExpr

{- | Admit candidates by distinct truth vector, keeping the smallest-expression
representative per vector.
-}
admitVecs ::
    M.Map (VU.Vector Bool) CondVec ->
    [CondVec] ->
    (M.Map (VU.Vector Bool) CondVec, [CondVec])
admitVecs :: Map (Vector Bool) CondVec
-> [CondVec] -> (Map (Vector Bool) CondVec, [CondVec])
admitVecs = [CondVec]
-> Map (Vector Bool) CondVec
-> [CondVec]
-> (Map (Vector Bool) CondVec, [CondVec])
go []
  where
    go :: [CondVec]
-> Map (Vector Bool) CondVec
-> [CondVec]
-> (Map (Vector Bool) CondVec, [CondVec])
go [CondVec]
acc Map (Vector Bool) CondVec
reps [] = (Map (Vector Bool) CondVec
reps, [CondVec] -> [CondVec]
forall a. [a] -> [a]
reverse [CondVec]
acc)
    go [CondVec]
acc !Map (Vector Bool) CondVec
reps (CondVec
c : [CondVec]
cs) = case Vector Bool -> Map (Vector Bool) CondVec -> Maybe CondVec
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (CondVec -> Vector Bool
cvVec CondVec
c) Map (Vector Bool) CondVec
reps of
        Maybe CondVec
Nothing -> [CondVec]
-> Map (Vector Bool) CondVec
-> [CondVec]
-> (Map (Vector Bool) CondVec, [CondVec])
go (CondVec
c CondVec -> [CondVec] -> [CondVec]
forall a. a -> [a] -> [a]
: [CondVec]
acc) (Vector Bool
-> CondVec
-> Map (Vector Bool) CondVec
-> Map (Vector Bool) CondVec
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (CondVec -> Vector Bool
cvVec CondVec
c) CondVec
c Map (Vector Bool) CondVec
reps) [CondVec]
cs
        Just CondVec
r -> [CondVec]
-> Map (Vector Bool) CondVec
-> [CondVec]
-> (Map (Vector Bool) CondVec, [CondVec])
go [CondVec]
acc (Vector Bool
-> CondVec
-> Map (Vector Bool) CondVec
-> Map (Vector Bool) CondVec
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (CondVec -> Vector Bool
cvVec CondVec
c) (CondVec -> CondVec -> CondVec
smaller CondVec
r CondVec
c) Map (Vector Bool) CondVec
reps) [CondVec]
cs

smaller :: CondVec -> CondVec -> CondVec
smaller :: CondVec -> CondVec -> CondVec
smaller CondVec
a CondVec
b = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Expr Bool -> Int
forall a. Expr a -> Int
eSize (CondVec -> Expr Bool
cvExpr CondVec
a)) (Expr Bool -> Int
forall a. Expr a -> Int
eSize (CondVec -> Expr Bool
cvExpr CondVec
b)) of
    Ordering
LT -> CondVec
a
    Ordering
GT -> CondVec
b
    Ordering
EQ -> if Expr Bool -> Expr Bool -> Ordering
forall a. Expr a -> Expr a -> Ordering
compareExpr (CondVec -> Expr Bool
cvExpr CondVec
a) (CondVec -> Expr Bool
cvExpr CondVec
b) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT then CondVec
a else CondVec
b

-- | Deduplicate 'CondVec's by normalized 'cvExpr', keeping the first.
dedupCVByExpr :: [CondVec] -> [CondVec]
dedupCVByExpr :: [CondVec] -> [CondVec]
dedupCVByExpr = Set String -> [CondVec] -> [CondVec]
go Set String
forall a. Set a
Set.empty
  where
    go :: Set String -> [CondVec] -> [CondVec]
go Set String
_ [] = []
    go Set String
seen (CondVec
cv : [CondVec]
cvs)
        | CondVec -> String
structuralKey CondVec
cv String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
seen = Set String -> [CondVec] -> [CondVec]
go Set String
seen [CondVec]
cvs
        | Bool
otherwise = CondVec
cv CondVec -> [CondVec] -> [CondVec]
forall a. a -> [a] -> [a]
: Set String -> [CondVec] -> [CondVec]
go (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert (CondVec -> String
structuralKey CondVec
cv) Set String
seen) [CondVec]
cvs

-- | Deduplicate expressions by normalized form, keeping the first.
nubByExpr :: [Expr Bool] -> [Expr Bool]
nubByExpr :: [Expr Bool] -> [Expr Bool]
nubByExpr = Set String -> [Expr Bool] -> [Expr Bool]
forall {a}.
(Show a, Typeable a) =>
Set String -> [Expr a] -> [Expr a]
go Set String
forall a. Set a
Set.empty
  where
    go :: Set String -> [Expr a] -> [Expr a]
go Set String
_ [] = []
    go Set String
seen (Expr a
e : [Expr a]
es)
        | String
k String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
seen = Set String -> [Expr a] -> [Expr a]
go Set String
seen [Expr a]
es
        | Bool
otherwise = Expr a
e Expr a -> [Expr a] -> [Expr a]
forall a. a -> [a] -> [a]
: Set String -> [Expr a] -> [Expr a]
go (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
k Set String
seen) [Expr a]
es
      where
        k :: String
k = Expr a -> String
forall a. Show a => a -> String
show (Expr a -> Expr a
forall a. (Show a, Typeable a) => Expr a -> Expr a
normalize Expr a
e)