{-# LANGUAGE
      CPP,
      DerivingVia,
      MultiParamTypeClasses,
      OverloadedStrings,
      RankNTypes,
      StandaloneDeriving,
      TupleSections
  #-}

-- | Decision diagrams, parametric in the mapping type for the decisions.
--
-- This is inspired by binary decision diagrams (as described in detail in
-- Knuth's The Art of Computer Programming, volume 4A); these are the specific
-- case where m is `BoolMapping` and v is `Bool`. Our algorithms are mostly
-- straightforward generalisations of those considered there.
--

-- TODO
--  * Format types of functions better
--  * Decisions go upwards in order currently; should they go
--    downwards, to coincide with lexicographical orderings on maps
--    and hence maybe make smaller decision diagrams?
--    We can use Down if necessary to amend this
--  * Increase test coverage
--  * Examples:
--     - finding optima
--     - finding random elements
--    (as examples of the more general functions, already coded, I hope)
--  * Separate out "Base" stuff into other modules?
--  * Documentation
--
-- MAYBE TO DO
--  * Composition algorithm?
--  * Optimisation by reordering
module Data.Mapping.Decision where

#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
#else
import Control.Applicative (liftA2)
#endif
import Control.Monad ((<=<))
import Data.Algebra.Boolean (Boolean(..))
import Data.Bifunctor (first)
import Data.Bijection (Bij)
import qualified Data.Bijection as B
import Data.Bits (complement)
import Data.Bool (bool)
import Data.Foldable (toList)
import Data.Foldable.WithIndex (FoldableWithIndex(..))
import Data.Functor.Identity (Identity(..))
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import Data.Ord (comparing)
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Q
import Data.Set (Set)
import qualified Data.Set as S
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Map.Merge.Strict as M
import Data.Mapping.Util (insertIfAbsent)
import Formatting ((%))
import qualified Formatting as F

import Data.Mapping


-- | A node of a decision diagram: which value do we scrutinise, and what do we
-- do with it?
data Node k m a = Node {
  forall {k} (k :: k) (m :: * -> *) a. Node k m a -> a
nodeDecision :: !a,
  forall {k} (k :: k) (m :: * -> *) a. Node k m a -> m Int
nodeBranch :: !(m Int)
}

deriving instance (Eq a, Eq (m Int)) => Eq (Node k m a)

deriving instance (Ord a, Ord (m Int)) => Ord (Node k m a)


-- | A decision diagram (with no preferred starting point), containing
-- leaves (representing final values of the decision process) indexed
-- from -1 downwards, and nodes (representing the need to scrutinise a
-- value) indexed from 0 upwards
data Base k m a v = Base {
  forall {k} (k :: k) (m :: * -> *) a v. Base k m a v -> Seq v
leaves :: Seq v,
  forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Seq (Node k m a)
nodes :: Seq (Node k m a)
}

baseLength :: Base k m a v -> Int
baseLength :: forall {k} (k :: k) (m :: * -> *) a v. Base k m a v -> Int
baseLength (Base Seq v
l Seq (Node k m a)
m) = forall a. Seq a -> Int
Q.length Seq v
l forall a. Num a => a -> a -> a
+ forall a. Seq a -> Int
Q.length Seq (Node k m a)
m

-- | A decision diagram with a starting point
data Decision k m a v = Decision {
  forall {k} (k :: k) (m :: * -> *) a v.
Decision k m a v -> Base k m a v
base :: !(Base k m a v),
  forall {k} (k :: k) (m :: * -> *) a v. Decision k m a v -> Int
start :: !Int
}

decisionLength :: Decision k m a v -> Int
decisionLength :: forall {k} (k :: k) (m :: * -> *) a v. Decision k m a v -> Int
decisionLength = forall {k} (k :: k) (m :: * -> *) a v. Base k m a v -> Int
baseLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (k :: k) (m :: * -> *) a v.
Decision k m a v -> Base k m a v
base

-- | A value for every node of a base
data BaseMap v = BaseMap {
  forall v. BaseMap v -> Seq v
onLeaves :: Seq v,
  forall v. BaseMap v -> Seq v
onNodes :: Seq v
}

-- | Index a BaseMap
bindex :: BaseMap v -> Int -> v
bindex :: forall v. BaseMap v -> Int -> v
bindex (BaseMap Seq v
l Seq v
m) Int
x
  | Int
x forall a. Ord a => a -> a -> Bool
< Int
0     = forall a. Seq a -> Int -> a
Q.index Seq v
l forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
x
  | Bool
otherwise = forall a. Seq a -> Int -> a
Q.index Seq v
m Int
x


-- | Close a set under an operation
closure :: (Int -> IntSet) -> IntSet -> IntSet
closure :: (Int -> IntSet) -> IntSet -> IntSet
closure Int -> IntSet
f = let
  inner :: IntSet -> IntSet -> IntSet
inner IntSet
old IntSet
new = case IntSet -> Maybe (Int, IntSet)
IS.minView IntSet
new of
    Maybe (Int, IntSet)
Nothing -> IntSet
old
    Just (Int
x, IntSet
new') -> let
      old' :: IntSet
old' = Int -> IntSet -> IntSet
IS.insert Int
x IntSet
old
      in IntSet -> IntSet -> IntSet
inner IntSet
old' (IntSet
new' IntSet -> IntSet -> IntSet
`IS.union` (Int -> IntSet
f Int
x IntSet -> IntSet -> IntSet
`IS.difference` IntSet
old'))
  in IntSet -> IntSet -> IntSet
inner IntSet
IS.empty


-- | A general kind of recursive function on a Base
baseRecurse :: (Ord c,
                Mapping k m)
            => (v -> c)
               -- ^ What to do on a value
            -> (a -> m c -> c)
               -- ^ What do do on a node
            -> Base k m a v
               -- ^ Input base
            -> BaseMap c
baseRecurse :: forall c k (m :: * -> *) v a.
(Ord c, Mapping k m) =>
(v -> c) -> (a -> m c -> c) -> Base k m a v -> BaseMap c
baseRecurse v -> c
p a -> m c -> c
q (Base Seq v
l Seq (Node k m a)
m) = let
  l' :: Seq c
l' = v -> c
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq v
l
  f :: Seq c -> Node k m a -> Seq c
f Seq c
v (Node a
x m Int
n) = Seq c
v forall a. Seq a -> a -> Seq a
|> a -> m c -> c
q a
x (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (forall v. BaseMap v -> Int -> v
bindex (forall v. Seq v -> Seq v -> BaseMap v
BaseMap Seq c
l' Seq c
v)) m Int
n)
  in forall v. Seq v -> Seq v -> BaseMap v
BaseMap Seq c
l' forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {k} {k} {k :: k}.
Mapping k m =>
Seq c -> Node k m a -> Seq c
f forall a. Seq a
Q.empty Seq (Node k m a)
m

-- | A general kind of recursive function on a Decision
decisionRecurse :: (Ord c,
                    Mapping k m)
                 => (v -> c)
                 -- ^ What to do on a value
                 -> (a -> m c -> c)
                 -- ^ What do do on a node
                 -> Decision k m a v
                 -- ^ Input decision
                 -> c
decisionRecurse :: forall c k (m :: * -> *) v a.
(Ord c, Mapping k m) =>
(v -> c) -> (a -> m c -> c) -> Decision k m a v -> c
decisionRecurse v -> c
p a -> m c -> c
q (Decision Base k m a v
b Int
s) = forall v. BaseMap v -> Int -> v
bindex (forall c k (m :: * -> *) v a.
(Ord c, Mapping k m) =>
(v -> c) -> (a -> m c -> c) -> Base k m a v -> BaseMap c
baseRecurse v -> c
p a -> m c -> c
q Base k m a v
b) Int
s


-- | A general counting function
generalCounts :: (Ord a, Ord n, Mapping k m)
              => (a -> a -> Int)
                 -- ^ In the list of decisions, how far apart are these?
              -> a
                 -- ^ The first possible decision
              -> a
                 -- ^ The last possible decision
              -> (v -> n)
                 -- ^ The count of a value
              -> (m n -> n)
                 -- ^ How to combine counts at a node
              -> Decision k m a v
                 -- ^ The input decision diagram
              -> n
                 -- ^ The count
generalCounts :: forall a n k (m :: * -> *) v.
(Ord a, Ord n, Mapping k m) =>
(a -> a -> Int)
-> a -> a -> (v -> n) -> (m n -> n) -> Decision k m a v -> n
generalCounts a -> a -> Int
d a
x0 a
x1 v -> n
onVal m n -> n
combine = let
  d' :: Maybe a -> Maybe a -> Int
d' Maybe a
Nothing Maybe a
Nothing = Int
2 forall a. Num a => a -> a -> a
+ a -> a -> Int
d a
x0 a
x1
  d' Maybe a
Nothing (Just a
y) = Int
1 forall a. Num a => a -> a -> a
+ a -> a -> Int
d a
x0 a
y
  d' (Just a
x) Maybe a
Nothing = Int
1 forall a. Num a => a -> a -> a
+ a -> a -> Int
d a
x a
x1
  d' (Just a
x) (Just a
y) = a -> a -> Int
d a
x a
y
  p :: Maybe a -> (Maybe a, n) -> n
p Maybe a
x (Maybe a
y, n
a) = let
    q :: t -> n -> n
q t
1 n
v = n
v
    q t
n n
v = t -> n -> n
q (t
nforall a. Num a => a -> a -> a
-t
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. m n -> n
combine forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v. Mapping k m => v -> m v
cst n
v
    in forall {t}. (Eq t, Num t) => t -> n -> n
q (Maybe a -> Maybe a -> Int
d' Maybe a
x Maybe a
y) n
a
  f :: v -> (Maybe a, n)
f v
x = (forall a. Maybe a
Nothing, v -> n
onVal v
x)
  g :: a -> m (Maybe a, n) -> (Maybe a, n)
g a
a m (Maybe a, n)
m = let
    b :: Maybe a
b = forall a. a -> Maybe a
Just a
a
    in (Maybe a
b, m n -> n
combine forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (Maybe a -> (Maybe a, n) -> n
p Maybe a
b) m (Maybe a, n)
m)
  in Maybe a -> (Maybe a, n) -> n
p forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c k (m :: * -> *) v a.
(Ord c, Mapping k m) =>
(v -> c) -> (a -> m c -> c) -> Decision k m a v -> c
decisionRecurse forall {a}. v -> (Maybe a, n)
f forall {k}. Mapping k m => a -> m (Maybe a, n) -> (Maybe a, n)
g

-- | How many values are true in a decision diagram with integer leaves?
numberTrueGeneral :: Mapping k m => (m Integer -> Integer) -> Int -> Int -> Decision k m Int Bool -> Integer
numberTrueGeneral :: forall k (m :: * -> *).
Mapping k m =>
(m Integer -> Integer)
-> Int -> Int -> Decision k m Int Bool -> Integer
numberTrueGeneral m Integer -> Integer
g Int
x0 Int
x1 = let
  f :: Bool -> a
f Bool
a = if Bool
a then a
1 else a
0
  in forall a n k (m :: * -> *) v.
(Ord a, Ord n, Mapping k m) =>
(a -> a -> Int)
-> a -> a -> (v -> n) -> (m n -> n) -> Decision k m a v -> n
generalCounts forall a. Num a => a -> a -> a
subtract Int
x0 Int
x1 forall {a}. Num a => Bool -> a
f m Integer -> Integer
g

-- | How many values are True in a binary decision diagram with integer leaves?
numberTrue :: Int -> Int -> Decision Bool OnBool Int Bool -> Integer
numberTrue :: Int -> Int -> Decision Bool OnBool Int Bool -> Integer
numberTrue = forall k (m :: * -> *).
Mapping k m =>
(m Integer -> Integer)
-> Int -> Int -> Decision k m Int Bool -> Integer
numberTrueGeneral forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum

-- | Assignments of variables that result in True
chunksTrue :: (Mapping k m, FoldableWithIndex k m, Ord k, Ord a) => Decision k m a Bool -> [Map a k]
chunksTrue :: forall k (m :: * -> *) a.
(Mapping k m, FoldableWithIndex k m, Ord k, Ord a) =>
Decision k m a Bool -> [Map a k]
chunksTrue = let
  f :: Bool -> [Map k a]
f Bool
False = []
  f Bool
True = [forall k a. Map k a
M.empty]
  g :: k -> f (f (Map k a)) -> f (Map k a)
g k
a = forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap (\a
x -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
a a
x))
  in forall c k (m :: * -> *) v a.
(Ord c, Mapping k m) =>
(v -> c) -> (a -> m c -> c) -> Decision k m a v -> c
decisionRecurse forall {k} {a}. Bool -> [Map k a]
f forall {a} {f :: * -> *} {f :: * -> *} {k}.
(FoldableWithIndex a f, Monoid (f (Map k a)), Functor f, Ord k) =>
k -> f (f (Map k a)) -> f (Map k a)
g

-- | All true values (may be a very long list even for reasonable Decisions)
listTrue :: forall k m a.
           (Mapping k m,
            FoldableWithIndex k m,
            Ord k,
            Ord a)
         => Set a
         -> Decision k m a Bool
         -> [Map a k]
listTrue :: forall k (m :: * -> *) a.
(Mapping k m, FoldableWithIndex k m, Ord k, Ord a) =>
Set a -> Decision k m a Bool -> [Map a k]
listTrue Set a
s = let
  m :: Map a ()
m = forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (forall a b. a -> b -> a
const ()) Set a
s
  u :: [k]
u = forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap (\k
i ()
_ -> [k
i]) forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v. Mapping k m => v -> m v
cst @k @m ()
  fillIn :: Map a () -> Map a k -> [Map a k]
fillIn = let
    onL :: WhenMissing [] k () k
onL = forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
M.traverseMissing (\k
_ () -> [k]
u)
    onR :: WhenMissing [] k x y
onR = forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
M.mapMissing (forall a b. a -> b -> a
const (forall a. HasCallStack => [Char] -> a
error [Char]
"Expected a key"))
    onB :: WhenMatched [] k () z z
onB = forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
M.zipWithMatched (\k
_ () -> forall a. a -> a
id)
    in forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
M.mergeA forall {k}. WhenMissing [] k () k
onL forall {k} {x} {y}. WhenMissing [] k x y
onR forall {k} {z}. WhenMatched [] k () z z
onB
  in Map a () -> Map a k -> [Map a k]
fillIn Map a ()
m forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall k (m :: * -> *) a.
(Mapping k m, FoldableWithIndex k m, Ord k, Ord a) =>
Decision k m a Bool -> [Map a k]
chunksTrue

-- | What is the best assignment of keys to values resulting in a
-- value on which `p` is `True`?
bestSuchThat :: (Mapping k m, Ord k, Ord a, Ord v) => (v -> Bool) -> (forall w. a -> m w -> Maybe (k, w)) -> Decision k m a v -> Maybe ([(a,k)], v)
bestSuchThat :: forall k (m :: * -> *) a v.
(Mapping k m, Ord k, Ord a, Ord v) =>
(v -> Bool)
-> (forall w. a -> m w -> Maybe (k, w))
-> Decision k m a v
-> Maybe ([(a, k)], v)
bestSuchThat v -> Bool
p forall w. a -> m w -> Maybe (k, w)
q = let
  f :: v -> Maybe ([a], v)
f v
x = if v -> Bool
p v
x then forall a. a -> Maybe a
Just ([], v
x) else forall a. Maybe a
Nothing
  g :: a -> m (Maybe (p [(a, k)] c)) -> Maybe (p [(a, k)] c)
g a
i = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (\k
x -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((a
i,k
x):))) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall w. a -> m w -> Maybe (k, w)
q a
i
  in forall c k (m :: * -> *) v a.
(Ord c, Mapping k m) =>
(v -> c) -> (a -> m c -> c) -> Decision k m a v -> c
decisionRecurse forall {a}. v -> Maybe ([a], v)
f forall {p :: * -> * -> *} {c}.
Bifunctor p =>
a -> m (Maybe (p [(a, k)] c)) -> Maybe (p [(a, k)] c)
g

-- | Build a sequence from key-value pairs; we take on trust that all
-- values are represented once.
fromKeyVals :: (Foldable f) => f (Int,a) -> Seq a
fromKeyVals :: forall (f :: * -> *) a. Foldable f => f (Int, a) -> Seq a
fromKeyVals = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> Seq a -> Seq a
Q.sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Seq a
Q.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList


-- | A data structure for work-in-progress decision diagrams
data Builder o k m a v = Builder {
  forall {k} o (k :: k) (m :: * -> *) a v.
Builder o k m a v -> Map v Int
leavesMap :: Map v Int,
  forall {k} o (k :: k) (m :: * -> *) a v.
Builder o k m a v -> Map (Node k m a) Int
nodesMap :: Map (Node k m a) Int,
  forall {k} o (k :: k) (m :: * -> *) a v.
Builder o k m a v -> Map o Int
fromOld :: Map o Int
}

emptyBuilder :: Builder o k m a v
emptyBuilder :: forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
emptyBuilder = forall {k} o (k :: k) (m :: * -> *) a v.
Map v Int -> Map (Node k m a) Int -> Map o Int -> Builder o k m a v
Builder forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty

addLeaf :: (Ord o,
            Ord v)
        => v
        -> o
        -> Builder o k m a v
        -> Builder o k m a v
addLeaf :: forall {k} o v (k :: k) (m :: * -> *) a.
(Ord o, Ord v) =>
v -> o -> Builder o k m a v -> Builder o k m a v
addLeaf v
x o
y (Builder Map v Int
l Map (Node k m a) Int
m Map o Int
o) = let
  i :: Int
i = forall a. Bits a => a -> a
complement (forall k a. Map k a -> Int
M.size Map v Int
l)
  (Int
j, Maybe (Map v Int)
s) = forall k v. Ord k => k -> v -> Map k v -> (v, Maybe (Map k v))
insertIfAbsent v
x Int
i Map v Int
l
  o' :: Map o Int
o' = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert o
y Int
j Map o Int
o
  in case Maybe (Map v Int)
s of
    Maybe (Map v Int)
Nothing -> forall {k} o (k :: k) (m :: * -> *) a v.
Map v Int -> Map (Node k m a) Int -> Map o Int -> Builder o k m a v
Builder Map v Int
l Map (Node k m a) Int
m Map o Int
o'
    Just Map v Int
l' -> forall {k} o (k :: k) (m :: * -> *) a v.
Map v Int -> Map (Node k m a) Int -> Map o Int -> Builder o k m a v
Builder Map v Int
l' Map (Node k m a) Int
m Map o Int
o'

addNode :: (Ord o,
            Ord (m Int),
            Ord a,
            Mapping k m)
        => a
        -> m o
        -> o
        -> Builder o k m a v
        -> Builder o k m a v
addNode :: forall o (m :: * -> *) a k v.
(Ord o, Ord (m Int), Ord a, Mapping k m) =>
a -> m o -> o -> Builder o k m a v -> Builder o k m a v
addNode a
r m o
a o
y (Builder Map v Int
l Map (Node k m a) Int
m Map o Int
o) = let
  b :: m Int
b = forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (Map o Int
o M.!) m o
a
  in case forall k (m :: * -> *) v. (Mapping k m, Ord v) => m v -> Maybe v
isConst m Int
b of
    Just Int
j -> forall {k} o (k :: k) (m :: * -> *) a v.
Map v Int -> Map (Node k m a) Int -> Map o Int -> Builder o k m a v
Builder Map v Int
l Map (Node k m a) Int
m (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert o
y Int
j Map o Int
o)
    Maybe Int
Nothing -> let
      i :: Int
i = forall k a. Map k a -> Int
M.size Map (Node k m a) Int
m
      (Int
j, Maybe (Map (Node k m a) Int)
s) = forall k v. Ord k => k -> v -> Map k v -> (v, Maybe (Map k v))
insertIfAbsent (forall {k} (k :: k) (m :: * -> *) a. a -> m Int -> Node k m a
Node a
r m Int
b) Int
i Map (Node k m a) Int
m
      o' :: Map o Int
o' = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert o
y Int
j Map o Int
o
      in case Maybe (Map (Node k m a) Int)
s of
        Maybe (Map (Node k m a) Int)
Nothing -> forall {k} o (k :: k) (m :: * -> *) a v.
Map v Int -> Map (Node k m a) Int -> Map o Int -> Builder o k m a v
Builder Map v Int
l Map (Node k m a) Int
m Map o Int
o'
        Just Map (Node k m a) Int
m' -> forall {k} o (k :: k) (m :: * -> *) a v.
Map v Int -> Map (Node k m a) Int -> Map o Int -> Builder o k m a v
Builder Map v Int
l Map (Node k m a) Int
m' Map o Int
o'

makeBuilder :: (Mapping k m,
                Ord o,
                Ord (m Int),
                Ord a,
                Ord v)
             => Map o v
             -> Map o (a, m o)
             -> Builder o k m a v
makeBuilder :: forall k (m :: * -> *) o a v.
(Mapping k m, Ord o, Ord (m Int), Ord a, Ord v) =>
Map o v -> Map o (a, m o) -> Builder o k m a v
makeBuilder Map o v
l Map o (a, m o)
m = let
  b0 :: Builder o k m a v
b0 = forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
emptyBuilder
  makeL :: Builder o k m a v -> o -> v -> Builder o k m a v
makeL Builder o k m a v
b o
i v
x = forall {k} o v (k :: k) (m :: * -> *) a.
(Ord o, Ord v) =>
v -> o -> Builder o k m a v -> Builder o k m a v
addLeaf v
x o
i Builder o k m a v
b
  b1 :: Builder o k m a v
b1 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {k} {o} {v} {k :: k} {m :: * -> *} {a}.
(Ord o, Ord v) =>
Builder o k m a v -> o -> v -> Builder o k m a v
makeL forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
b0 Map o v
l
  makeN :: Builder o k m a v -> o -> (a, m o) -> Builder o k m a v
makeN Builder o k m a v
b o
i (a
r, m o
o) = forall o (m :: * -> *) a k v.
(Ord o, Ord (m Int), Ord a, Mapping k m) =>
a -> m o -> o -> Builder o k m a v -> Builder o k m a v
addNode a
r m o
o o
i Builder o k m a v
b
  b2 :: Builder o k m a v
b2 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {o} {a} {m :: * -> *} {k} {v}.
(Ord o, Ord a, Ord (m Int), Mapping k m) =>
Builder o k m a v -> o -> (a, m o) -> Builder o k m a v
makeN forall {k} {k :: k} {m :: * -> *} {a}. Builder o k m a v
b1 Map o (a, m o)
m
  in Builder o k m a v
b2

buildBase :: Builder o k m a v -> Base k m a v
buildBase :: forall {k} o (k :: k) (m :: * -> *) a v.
Builder o k m a v -> Base k m a v
buildBase (Builder Map v Int
l Map (Node k m a) Int
m Map o Int
_) = let
  l' :: Seq v
l' = forall (f :: * -> *) a. Foldable f => f (Int, a) -> Seq a
fromKeyVals forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(v
x,Int
i) -> (forall a. Bits a => a -> a
complement Int
i,v
x)) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map v Int
l
  m' :: Seq (Node k m a)
m' = forall (f :: * -> *) a. Foldable f => f (Int, a) -> Seq a
fromKeyVals forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Node k m a
x,Int
i) -> (Int
i,Node k m a
x)) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map (Node k m a) Int
m
  in forall {k} (k :: k) (m :: * -> *) a v.
Seq v -> Seq (Node k m a) -> Base k m a v
Base Seq v
l' Seq (Node k m a)
m'

buildDecision :: Ord o => o -> Builder o k m a v -> Decision k m a v
buildDecision :: forall {k} o (k :: k) (m :: * -> *) a v.
Ord o =>
o -> Builder o k m a v -> Decision k m a v
buildDecision o
s b :: Builder o k m a v
b@(Builder Map v Int
_ Map (Node k m a) Int
_ Map o Int
o) = forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Int -> Decision k m a v
Decision (forall {k} o (k :: k) (m :: * -> *) a v.
Builder o k m a v -> Base k m a v
buildBase Builder o k m a v
b) (Map o Int
o forall k a. Ord k => Map k a -> k -> a
M.! o
s)

-- | A decision tree based on a single decision
singleNode :: (Mapping k m, Ord (m Int), Ord a, Ord v) => a -> m v -> Decision k m a v
singleNode :: forall k (m :: * -> *) a v.
(Mapping k m, Ord (m Int), Ord a, Ord v) =>
a -> m v -> Decision k m a v
singleNode a
r m v
n = let
  f :: Builder (Maybe a) k m a a -> a -> Builder (Maybe a) k m a a
f Builder (Maybe a) k m a a
b a
x = forall {k} o v (k :: k) (m :: * -> *) a.
(Ord o, Ord v) =>
v -> o -> Builder o k m a v -> Builder o k m a v
addLeaf a
x (forall a. a -> Maybe a
Just a
x) Builder (Maybe a) k m a a
b
  d :: Builder (Maybe v) k m a v
d = forall o (m :: * -> *) a k v.
(Ord o, Ord (m Int), Ord a, Mapping k m) =>
a -> m o -> o -> Builder o k m a v -> Builder o k m a v
addNode a
r (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap forall a. a -> Maybe a
Just m v
n) forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {k} {a} {k :: k} {m :: * -> *} {a}.
Ord a =>
Builder (Maybe a) k m a a -> a -> Builder (Maybe a) k m a a
f forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
emptyBuilder m v
n
  in forall {k} o (k :: k) (m :: * -> *) a v.
Ord o =>
o -> Builder o k m a v -> Decision k m a v
buildDecision forall a. Maybe a
Nothing Builder (Maybe v) k m a v
d

-- | A building block for BDD's - tests if a variable is true
genTest :: Boolean b => a -> Decision Bool OnBool a b
genTest :: forall b a. Boolean b => a -> Decision Bool OnBool a b
genTest a
r = let
  l :: Seq b
l = forall a. [a] -> Seq a
Q.fromList [forall b. Boolean b => b
false, forall b. Boolean b => b
true]
  m :: Seq (Node k OnBool a)
m = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (k :: k) (m :: * -> *) a. a -> m Int -> Node k m a
Node a
r forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> OnBool a
OnBool (-Int
1) (-Int
2)
  s :: Int
s = Int
0
  in forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Int -> Decision k m a v
Decision (forall {k} (k :: k) (m :: * -> *) a v.
Seq v -> Seq (Node k m a) -> Base k m a v
Base Seq b
l forall {k} {k :: k}. Seq (Node k OnBool a)
m) Int
s

-- | Test if a variable is true (specialised to `Bool`)
test :: a -> Decision Bool OnBool a Bool
test :: forall a. a -> Decision Bool OnBool a Bool
test = forall b a. Boolean b => a -> Decision Bool OnBool a b
genTest


-- | Rapidly take the conjunction of the inputs
buildAll :: Mapping k m => Map a (m Bool) -> Decision k m a Bool
buildAll :: forall k (m :: * -> *) a.
Mapping k m =>
Map a (m Bool) -> Decision k m a Bool
buildAll Map a (m Bool)
d = let
  l :: Seq Bool
l = forall a. [a] -> Seq a
Q.fromList [forall b. Boolean b => b
true, forall b. Boolean b => b
false]
  s :: Int
s = forall k a. Map k a -> Int
M.size Map a (m Bool)
d
  m :: Seq (Node k m a)
m = forall a. [a] -> Seq a
Q.fromList forall a b. (a -> b) -> a -> b
$ do
    (Int
i,(a
r,m Bool
n)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (forall k a. Map k a -> [(k, a)]
M.toDescList Map a (m Bool)
d)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} (k :: k) (m :: * -> *) a. a -> m Int -> Node k m a
Node a
r (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (forall a. a -> a -> Bool -> a
bool (-Int
2) (Int
iforall a. Num a => a -> a -> a
-Int
1)) m Bool
n))
  in forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Int -> Decision k m a v
Decision (forall {k} (k :: k) (m :: * -> *) a v.
Seq v -> Seq (Node k m a) -> Base k m a v
Base Seq Bool
l forall {k} {k :: k}. Seq (Node k m a)
m) (Int
sforall a. Num a => a -> a -> a
-Int
1)

-- | Rapidly take the disjunction of the inputs
buildAny :: Mapping k m => Map a (m Bool) -> Decision k m a Bool
buildAny :: forall k (m :: * -> *) a.
Mapping k m =>
Map a (m Bool) -> Decision k m a Bool
buildAny Map a (m Bool)
d = let
  l :: Seq Bool
l = forall a. [a] -> Seq a
Q.fromList [forall b. Boolean b => b
false, forall b. Boolean b => b
true]
  s :: Int
s = forall k a. Map k a -> Int
M.size Map a (m Bool)
d
  m :: Seq (Node k m a)
m = forall a. [a] -> Seq a
Q.fromList forall a b. (a -> b) -> a -> b
$ do
    (Int
i,(a
r,m Bool
n)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (forall k a. Map k a -> [(k, a)]
M.toDescList Map a (m Bool)
d)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} (k :: k) (m :: * -> *) a. a -> m Int -> Node k m a
Node a
r (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (forall a. a -> a -> Bool -> a
bool (Int
iforall a. Num a => a -> a -> a
-Int
1) (-Int
2)) m Bool
n))
  in forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Int -> Decision k m a v
Decision (forall {k} (k :: k) (m :: * -> *) a v.
Seq v -> Seq (Node k m a) -> Base k m a v
Base Seq Bool
l forall {k} {k :: k}. Seq (Node k m a)
m) (Int
sforall a. Num a => a -> a -> a
-Int
1)


-- | Traverse bases
baseTraverse :: (Applicative f, Ord a, Ord (m Int), Ord w, Mapping k m) => (v -> f w) -> Base k m a v -> f (Builder Int k m a w)
baseTraverse :: forall (f :: * -> *) a (m :: * -> *) w k v.
(Applicative f, Ord a, Ord (m Int), Ord w, Mapping k m) =>
(v -> f w) -> Base k m a v -> f (Builder Int k m a w)
baseTraverse v -> f w
p (Base Seq v
l Seq (Node k m a)
m) = let
  t0 :: f (Builder o k m a v)
t0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
emptyBuilder

  t1 :: f (Builder Int k m a w)
t1 = let
    f :: f (Builder o k m a w) -> o -> v -> f (Builder o k m a w)
f f (Builder o k m a w)
b o
i v
x = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\Builder o k m a w
b' w
px' -> forall {k} o v (k :: k) (m :: * -> *) a.
(Ord o, Ord v) =>
v -> o -> Builder o k m a v -> Builder o k m a v
addLeaf w
px' (forall a. Bits a => a -> a
complement o
i) Builder o k m a w
b') f (Builder o k m a w)
b (v -> f w
p v
x)
    in forall b a. (b -> Int -> a -> b) -> b -> Seq a -> b
Q.foldlWithIndex forall {k} {o} {k :: k} {m :: * -> *} {a}.
(Ord o, Bits o) =>
f (Builder o k m a w) -> o -> v -> f (Builder o k m a w)
f forall {k} {o} {k :: k} {m :: * -> *} {a} {v}.
f (Builder o k m a v)
t0 Seq v
l

  t2 :: f (Builder Int k m a w)
t2 = let
    f :: f (Builder Int k m a v)
-> Int -> Node k m a -> f (Builder Int k m a v)
f f (Builder Int k m a v)
b Int
i (Node a
r m Int
d) = forall o (m :: * -> *) a k v.
(Ord o, Ord (m Int), Ord a, Mapping k m) =>
a -> m o -> o -> Builder o k m a v -> Builder o k m a v
addNode a
r m Int
d Int
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Builder Int k m a v)
b
    in forall b a. (b -> Int -> a -> b) -> b -> Seq a -> b
Q.foldlWithIndex forall {k} {f :: * -> *} {a} {m :: * -> *} {k} {v} {k :: k}.
(Functor f, Ord a, Ord (m Int), Mapping k m) =>
f (Builder Int k m a v)
-> Int -> Node k m a -> f (Builder Int k m a v)
f forall {k} {k :: k} {m :: * -> *} {a}. f (Builder Int k m a w)
t1 Seq (Node k m a)
m

  in f (Builder Int k m a w)
t2


-- | Map bases
baseMap :: (Ord a, Ord (m Int), Ord w, Mapping k m) => (v -> w) -> Base k m a v -> Builder Int k m a w
baseMap :: forall a (m :: * -> *) w k v.
(Ord a, Ord (m Int), Ord w, Mapping k m) =>
(v -> w) -> Base k m a v -> Builder Int k m a w
baseMap v -> w
p = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a (m :: * -> *) w k v.
(Applicative f, Ord a, Ord (m Int), Ord w, Mapping k m) =>
(v -> f w) -> Base k m a v -> f (Builder Int k m a w)
baseTraverse (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> w
p)


-- | A more general map for `Base`, where the shape of nodes can change
baseTransform ::    (Ord a, Ord (n Int), Mapping l n, Ord w)
                 => (v -> w)
                 -> (forall x. a -> m x -> n x)
                 -> Base k m a v
                 -> IntSet
                 -> Builder Int l n a w
baseTransform :: forall {k} a (n :: * -> *) l w v (m :: * -> *) (k :: k).
(Ord a, Ord (n Int), Mapping l n, Ord w) =>
(v -> w)
-> (forall x. a -> m x -> n x)
-> Base k m a v
-> IntSet
-> Builder Int l n a w
baseTransform v -> w
p forall x. a -> m x -> n x
q (Base Seq v
l Seq (Node k m a)
m) = let

  close :: Map Int w -> Map Int (a, n Int) -> IntSet -> Builder Int k n a w
close Map Int w
aL Map Int (a, n Int)
aN IntSet
s = case IntSet -> Maybe (Int, IntSet)
IS.maxView IntSet
s of
   Maybe (Int, IntSet)
Nothing -> forall k (m :: * -> *) o a v.
(Mapping k m, Ord o, Ord (m Int), Ord a, Ord v) =>
Map o v -> Map o (a, m o) -> Builder o k m a v
makeBuilder Map Int w
aL Map Int (a, n Int)
aN
   Just (Int
i, IntSet
s') -> if Int
i forall a. Ord a => a -> a -> Bool
< Int
0
     then let
       x :: w
x = v -> w
p (forall a. Seq a -> Int -> a
Q.index Seq v
l forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
i)
       in Map Int w -> Map Int (a, n Int) -> IntSet -> Builder Int k n a w
close (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
i w
x Map Int w
aL) Map Int (a, n Int)
aN IntSet
s'
     else let
       Node a
r m Int
n = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m Int
i
       o :: n Int
o = forall x. a -> m x -> n x
q a
r m Int
n
       s'' :: IntSet
s'' = IntSet -> IntSet -> IntSet
IS.union IntSet
s' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IntSet
IS.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList n Int
o
       in Map Int w -> Map Int (a, n Int) -> IntSet -> Builder Int k n a w
close Map Int w
aL (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
i (a
r, n Int
o) Map Int (a, n Int)
aN) IntSet
s''

  in forall {k}.
Mapping k n =>
Map Int w -> Map Int (a, n Int) -> IntSet -> Builder Int k n a w
close forall k a. Map k a
M.empty forall k a. Map k a
M.empty


-- | A more general map for `Decision`, where the shape of nodes can change
decisionTransform :: (Mapping l n,
                      Ord (n Int),
                      Ord a,
                      Ord w)
                   => (v -> w)
                   -> (forall x. a -> m x -> n x)
                   -> Decision k m a v
                   -> Decision l n a w
decisionTransform :: forall {k} l (n :: * -> *) a w v (m :: * -> *) (k :: k).
(Mapping l n, Ord (n Int), Ord a, Ord w) =>
(v -> w)
-> (forall x. a -> m x -> n x)
-> Decision k m a v
-> Decision l n a w
decisionTransform v -> w
p forall x. a -> m x -> n x
q (Decision Base k m a v
b Int
s) = let
  in forall {k} o (k :: k) (m :: * -> *) a v.
Ord o =>
o -> Builder o k m a v -> Decision k m a v
buildDecision Int
s forall a b. (a -> b) -> a -> b
$ forall {k} a (n :: * -> *) l w v (m :: * -> *) (k :: k).
(Ord a, Ord (n Int), Mapping l n, Ord w) =>
(v -> w)
-> (forall x. a -> m x -> n x)
-> Base k m a v
-> IntSet
-> Builder Int l n a w
baseTransform v -> w
p forall x. a -> m x -> n x
q Base k m a v
b (Int -> IntSet
IS.singleton Int
s)


-- | Fill in some values of a map
-- > act (restrict h d) f = let
-- >   f' x = case h x of
-- >     Just y  -> y
-- >     Nothing -> f x
-- >   in act d f'
restrict :: (Ord (m Int), Ord v, Ord a, Mapping k m) => (a -> Maybe k) -> Decision k m a v -> Decision k m a v
restrict :: forall (m :: * -> *) v a k.
(Ord (m Int), Ord v, Ord a, Mapping k m) =>
(a -> Maybe k) -> Decision k m a v -> Decision k m a v
restrict a -> Maybe k
f = let
  g :: a -> m v -> m v
g a
x m v
m = case a -> Maybe k
f a
x of
    Maybe k
Nothing -> m v
m
    Just k
c -> forall k (m :: * -> *) v. Mapping k m => v -> m v
cst (forall k (m :: * -> *) v. Mapping k m => m v -> k -> v
act m v
m k
c)
  in forall {k} l (n :: * -> *) a w v (m :: * -> *) (k :: k).
(Mapping l n, Ord (n Int), Ord a, Ord w) =>
(v -> w)
-> (forall x. a -> m x -> n x)
-> Decision k m a v
-> Decision l n a w
decisionTransform forall a. a -> a
id forall {m :: * -> *} {v}. Mapping k m => a -> m v -> m v
g


-- | A general function for merging bases
baseGenMerge ::    (Ord a, Ord w, Ord (o Int), Mapping l o)
                => (u -> v -> w)
                -> (forall x . Ord x => a -> m x -> o x)
                -> (forall y . Ord y => a -> n y -> o y)
                -> (forall x y. (Ord x, Ord y) => a -> m x -> n y -> o (x, y))
                -> Base h m a u -> Base k n a v -> Set (Int, Int) -> Builder (Int, Int) l o a w
baseGenMerge :: forall {k} {k} a w (o :: * -> *) l u v (m :: * -> *) (n :: * -> *)
       (h :: k) (k :: k).
(Ord a, Ord w, Ord (o Int), Mapping l o) =>
(u -> v -> w)
-> (forall x. Ord x => a -> m x -> o x)
-> (forall y. Ord y => a -> n y -> o y)
-> (forall x y. (Ord x, Ord y) => a -> m x -> n y -> o (x, y))
-> Base h m a u
-> Base k n a v
-> Set (Int, Int)
-> Builder (Int, Int) l o a w
baseGenMerge u -> v -> w
pLL forall x. Ord x => a -> m x -> o x
pNL forall y. Ord y => a -> n y -> o y
pLN forall x y. (Ord x, Ord y) => a -> m x -> n y -> o (x, y)
pNN (Base Seq u
l1 Seq (Node h m a)
m1) (Base Seq v
l2 Seq (Node k n a)
m2) = let

  close :: Map (Int, Int) w
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Set (Int, Int)
-> Builder (Int, Int) k o a w
close Map (Int, Int) w
aLL Map (Int, Int) (a, o (Int, Int))
aNL Map (Int, Int) (a, o (Int, Int))
aLN Map (Int, Int) (a, o (Int, Int))
aNN Set (Int, Int)
s = case forall a. Set a -> Maybe (a, Set a)
S.maxView Set (Int, Int)
s of
    Maybe ((Int, Int), Set (Int, Int))
Nothing -> forall {a} {b} {b} {a} {m :: * -> *} {k}.
(Ord b, Ord a, Ord b, Ord a, Ord (m Int), Mapping k m) =>
Map (a, b) b
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> Builder (a, b) k m a b
make Map (Int, Int) w
aLL Map (Int, Int) (a, o (Int, Int))
aNL Map (Int, Int) (a, o (Int, Int))
aLN Map (Int, Int) (a, o (Int, Int))
aNN
    Just ((Int
i1, Int
i2), Set (Int, Int)
s') -> case (Int
i1 forall a. Ord a => a -> a -> Bool
< Int
0, Int
i2 forall a. Ord a => a -> a -> Bool
< Int
0) of
      ( Bool
True,  Bool
True) -> let
        x :: w
x = u -> v -> w
pLL (forall a. Seq a -> Int -> a
Q.index Seq u
l1 forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
i1) (forall a. Seq a -> Int -> a
Q.index Seq v
l2 forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
i2)
        in Map (Int, Int) w
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Set (Int, Int)
-> Builder (Int, Int) k o a w
close (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) w
x Map (Int, Int) w
aLL) Map (Int, Int) (a, o (Int, Int))
aNL Map (Int, Int) (a, o (Int, Int))
aLN Map (Int, Int) (a, o (Int, Int))
aNN Set (Int, Int)
s'
      ( Bool
True, Bool
False) -> let
        Node a
r2 n Int
n2 = forall a. Seq a -> Int -> a
Q.index Seq (Node k n a)
m2 Int
i2
        o :: o (Int, Int)
o = forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (Int
i1,) forall a b. (a -> b) -> a -> b
$ forall y. Ord y => a -> n y -> o y
pLN a
r2 n Int
n2
        s'' :: Set (Int, Int)
s'' = forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Int, Int)
s' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList o (Int, Int)
o
        in Map (Int, Int) w
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Set (Int, Int)
-> Builder (Int, Int) k o a w
close Map (Int, Int) w
aLL Map (Int, Int) (a, o (Int, Int))
aNL (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) (a
r2, o (Int, Int)
o) Map (Int, Int) (a, o (Int, Int))
aLN) Map (Int, Int) (a, o (Int, Int))
aNN Set (Int, Int)
s''
      (Bool
False,  Bool
True) -> let
        Node a
r1 m Int
n1 = forall a. Seq a -> Int -> a
Q.index Seq (Node h m a)
m1 Int
i1
        o :: o (Int, Int)
o = forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (,Int
i2) forall a b. (a -> b) -> a -> b
$ forall x. Ord x => a -> m x -> o x
pNL a
r1 m Int
n1
        s'' :: Set (Int, Int)
s'' = forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Int, Int)
s' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList o (Int, Int)
o
        in Map (Int, Int) w
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Set (Int, Int)
-> Builder (Int, Int) k o a w
close Map (Int, Int) w
aLL (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) (a
r1, o (Int, Int)
o) Map (Int, Int) (a, o (Int, Int))
aNL) Map (Int, Int) (a, o (Int, Int))
aLN Map (Int, Int) (a, o (Int, Int))
aNN Set (Int, Int)
s''
      (Bool
False, Bool
False) -> let
        Node a
r1 m Int
n1 = forall a. Seq a -> Int -> a
Q.index Seq (Node h m a)
m1 Int
i1
        Node a
r2 n Int
n2 = forall a. Seq a -> Int -> a
Q.index Seq (Node k n a)
m2 Int
i2
        (a
r, o (Int, Int)
o) = case forall a. Ord a => a -> a -> Ordering
compare a
r1 a
r2 of
          Ordering
LT -> (a
r1, forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (,Int
i2) forall a b. (a -> b) -> a -> b
$ forall x. Ord x => a -> m x -> o x
pNL a
r1 m Int
n1)
          Ordering
GT -> (a
r2, forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (Int
i1,) forall a b. (a -> b) -> a -> b
$ forall y. Ord y => a -> n y -> o y
pLN a
r2 n Int
n2)
          Ordering
EQ -> (a
r1, forall x y. (Ord x, Ord y) => a -> m x -> n y -> o (x, y)
pNN a
r1 m Int
n1 n Int
n2)
        s'' :: Set (Int, Int)
s'' = forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Int, Int)
s' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList o (Int, Int)
o
        in Map (Int, Int) w
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Set (Int, Int)
-> Builder (Int, Int) k o a w
close Map (Int, Int) w
aLL Map (Int, Int) (a, o (Int, Int))
aNL Map (Int, Int) (a, o (Int, Int))
aLN (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) (a
r, o (Int, Int)
o) Map (Int, Int) (a, o (Int, Int))
aNN) Set (Int, Int)
s''

  make :: Map (a, b) b
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> Builder (a, b) k m a b
make Map (a, b) b
aLL Map (a, b) (a, m (a, b))
aNL Map (a, b) (a, m (a, b))
aLN Map (a, b) (a, m (a, b))
aNN = let

    b0 :: Builder o k m a v
b0 = forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
emptyBuilder

    makeL :: Builder (a, b) k m a v -> (a, b) -> v -> Builder (a, b) k m a v
makeL Builder (a, b) k m a v
b (a
i, b
j) v
x = forall {k} o v (k :: k) (m :: * -> *) a.
(Ord o, Ord v) =>
v -> o -> Builder o k m a v -> Builder o k m a v
addLeaf v
x (a
i, b
j) Builder (a, b) k m a v
b
    b1 :: Builder (a, b) k m a b
b1 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {k} {a} {b} {v} {k :: k} {m :: * -> *} {a}.
(Ord a, Ord b, Ord v) =>
Builder (a, b) k m a v -> (a, b) -> v -> Builder (a, b) k m a v
makeL forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
b0 Map (a, b) b
aLL

    makeN :: Builder (a, b) k m a v
-> (a, b) -> (a, m (a, b)) -> Builder (a, b) k m a v
makeN Builder (a, b) k m a v
b (a
i, b
j) (a
r, m (a, b)
o) = forall o (m :: * -> *) a k v.
(Ord o, Ord (m Int), Ord a, Mapping k m) =>
a -> m o -> o -> Builder o k m a v -> Builder o k m a v
addNode a
r m (a, b)
o (a
i, b
j) Builder (a, b) k m a v
b
    b2 :: Builder (a, b) k m a b
b2 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {a} {b} {a} {m :: * -> *} {k} {v}.
(Ord a, Ord b, Ord a, Ord (m Int), Mapping k m) =>
Builder (a, b) k m a v
-> (a, b) -> (a, m (a, b)) -> Builder (a, b) k m a v
makeN forall {k} {k :: k} {m :: * -> *} {a}. Builder (a, b) k m a b
b1 Map (a, b) (a, m (a, b))
aNL
    b3 :: Builder (a, b) k m a b
b3 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {a} {b} {a} {m :: * -> *} {k} {v}.
(Ord a, Ord b, Ord a, Ord (m Int), Mapping k m) =>
Builder (a, b) k m a v
-> (a, b) -> (a, m (a, b)) -> Builder (a, b) k m a v
makeN Builder (a, b) k m a b
b2 Map (a, b) (a, m (a, b))
aLN
    b4 :: Builder (a, b) k m a b
b4 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {a} {b} {a} {m :: * -> *} {k} {v}.
(Ord a, Ord b, Ord a, Ord (m Int), Mapping k m) =>
Builder (a, b) k m a v
-> (a, b) -> (a, m (a, b)) -> Builder (a, b) k m a v
makeN Builder (a, b) k m a b
b3 Map (a, b) (a, m (a, b))
aNN
    in Builder (a, b) k m a b
b4

  in forall {k} {k} {k} {k}.
(Mapping k o, Mapping k o, Mapping k o, Mapping k o) =>
Map (Int, Int) w
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Map (Int, Int) (a, o (Int, Int))
-> Set (Int, Int)
-> Builder (Int, Int) k o a w
close forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty


-- | Merge two bases in an applicative functor
baseMergeA ::    (Applicative f, Ord a, Ord w, Ord (m Int), Mapping k m)
              => (u -> v -> f w)
              -> Base k m a u -> Base k m a v -> Set (Int, Int) -> f (Builder (Int, Int) k m a w)
baseMergeA :: forall (f :: * -> *) a w (m :: * -> *) k u v.
(Applicative f, Ord a, Ord w, Ord (m Int), Mapping k m) =>
(u -> v -> f w)
-> Base k m a u
-> Base k m a v
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
baseMergeA u -> v -> f w
p (Base Seq u
l1 Seq (Node k m a)
m1) (Base Seq v
l2 Seq (Node k m a)
m2) = let

  close :: Map (Int, Int) (f w)
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
close Map (Int, Int) (f w)
aLL Map (Int, Int) (a, m (Int, Int))
aNL Map (Int, Int) (a, m (Int, Int))
aLN Map (Int, Int) (a, m (Int, Int))
aNN Set (Int, Int)
s = case forall a. Set a -> Maybe (a, Set a)
S.maxView Set (Int, Int)
s of
    Maybe ((Int, Int), Set (Int, Int))
Nothing -> forall {f :: * -> *} {a} {b} {v} {a} {m :: * -> *} {k}.
(Applicative f, Ord v, Ord a, Ord b, Ord a, Ord (m Int),
 Mapping k m) =>
Map (a, b) (f v)
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> f (Builder (a, b) k m a v)
make Map (Int, Int) (f w)
aLL Map (Int, Int) (a, m (Int, Int))
aNL Map (Int, Int) (a, m (Int, Int))
aLN Map (Int, Int) (a, m (Int, Int))
aNN
    Just ((Int
i1, Int
i2), Set (Int, Int)
s') -> case (Int
i1 forall a. Ord a => a -> a -> Bool
< Int
0, Int
i2 forall a. Ord a => a -> a -> Bool
< Int
0) of
      ( Bool
True,  Bool
True) -> let
        x :: f w
x = u -> v -> f w
p (forall a. Seq a -> Int -> a
Q.index Seq u
l1 forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
i1) (forall a. Seq a -> Int -> a
Q.index Seq v
l2 forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
i2)
        in Map (Int, Int) (f w)
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
close (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) f w
x Map (Int, Int) (f w)
aLL) Map (Int, Int) (a, m (Int, Int))
aNL Map (Int, Int) (a, m (Int, Int))
aLN Map (Int, Int) (a, m (Int, Int))
aNN Set (Int, Int)
s'
      ( Bool
True, Bool
False) -> let
        Node a
r2 m Int
n2 = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m2 Int
i2
        o :: m (Int, Int)
o = forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (Int
i1,) m Int
n2
        s'' :: Set (Int, Int)
s'' = forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Int, Int)
s' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList m (Int, Int)
o
        in Map (Int, Int) (f w)
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
close Map (Int, Int) (f w)
aLL Map (Int, Int) (a, m (Int, Int))
aNL (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) (a
r2, m (Int, Int)
o) Map (Int, Int) (a, m (Int, Int))
aLN) Map (Int, Int) (a, m (Int, Int))
aNN Set (Int, Int)
s''
      (Bool
False,  Bool
True) -> let
        Node a
r1 m Int
n1 = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m1 Int
i1
        o :: m (Int, Int)
o = forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (,Int
i2) m Int
n1
        s'' :: Set (Int, Int)
s'' = forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Int, Int)
s' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList m (Int, Int)
o
        in Map (Int, Int) (f w)
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
close Map (Int, Int) (f w)
aLL (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) (a
r1, m (Int, Int)
o) Map (Int, Int) (a, m (Int, Int))
aNL) Map (Int, Int) (a, m (Int, Int))
aLN Map (Int, Int) (a, m (Int, Int))
aNN Set (Int, Int)
s''
      (Bool
False, Bool
False) -> let
        Node a
r1 m Int
n1 = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m1 Int
i1
        Node a
r2 m Int
n2 = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m2 Int
i2
        (a
r,m (Int, Int)
o) = case forall a. Ord a => a -> a -> Ordering
compare a
r1 a
r2 of
          Ordering
LT -> (a
r1, forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (,Int
i2) m Int
n1)
          Ordering
GT -> (a
r2, forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (Int
i1,) m Int
n2)
          Ordering
EQ -> (a
r1, forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge (,) m Int
n1 m Int
n2)
        s'' :: Set (Int, Int)
s'' = forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Int, Int)
s' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList m (Int, Int)
o
        in Map (Int, Int) (f w)
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
close Map (Int, Int) (f w)
aLL Map (Int, Int) (a, m (Int, Int))
aNL Map (Int, Int) (a, m (Int, Int))
aLN (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
i1, Int
i2) (a
r, m (Int, Int)
o) Map (Int, Int) (a, m (Int, Int))
aNN) Set (Int, Int)
s''

  make :: Map (a, b) (f v)
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> Map (a, b) (a, m (a, b))
-> f (Builder (a, b) k m a v)
make Map (a, b) (f v)
aLL Map (a, b) (a, m (a, b))
aNL Map (a, b) (a, m (a, b))
aLN Map (a, b) (a, m (a, b))
aNN = let

    b0 :: f (Builder o k m a v)
b0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} o (k :: k) (m :: * -> *) a v. Builder o k m a v
emptyBuilder

    makeL :: f (Builder (a, b) k m a v)
-> (a, b) -> f v -> f (Builder (a, b) k m a v)
makeL f (Builder (a, b) k m a v)
b (a
i, b
j) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\Builder (a, b) k m a v
b' v
x'-> forall {k} o v (k :: k) (m :: * -> *) a.
(Ord o, Ord v) =>
v -> o -> Builder o k m a v -> Builder o k m a v
addLeaf v
x' (a
i, b
j) Builder (a, b) k m a v
b') f (Builder (a, b) k m a v)
b
    b1 :: f (Builder (a, b) k m a v)
b1 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {k} {f :: * -> *} {a} {b} {v} {k :: k} {m :: * -> *} {a}.
(Applicative f, Ord a, Ord b, Ord v) =>
f (Builder (a, b) k m a v)
-> (a, b) -> f v -> f (Builder (a, b) k m a v)
makeL forall {k} {o} {k :: k} {m :: * -> *} {a} {v}.
f (Builder o k m a v)
b0 Map (a, b) (f v)
aLL

    makeN :: f (Builder (a, b) k m a v)
-> (a, b) -> (a, m (a, b)) -> f (Builder (a, b) k m a v)
makeN f (Builder (a, b) k m a v)
b (a
i, b
j) (a
r, m (a, b)
o) = forall o (m :: * -> *) a k v.
(Ord o, Ord (m Int), Ord a, Mapping k m) =>
a -> m o -> o -> Builder o k m a v -> Builder o k m a v
addNode a
r m (a, b)
o (a
i, b
j) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Builder (a, b) k m a v)
b
    b2 :: f (Builder (a, b) k m a v)
b2 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {f :: * -> *} {a} {b} {a} {m :: * -> *} {k} {v}.
(Functor f, Ord a, Ord b, Ord a, Ord (m Int), Mapping k m) =>
f (Builder (a, b) k m a v)
-> (a, b) -> (a, m (a, b)) -> f (Builder (a, b) k m a v)
makeN forall {k} {k :: k} {m :: * -> *} {a}. f (Builder (a, b) k m a v)
b1 Map (a, b) (a, m (a, b))
aNL
    b3 :: f (Builder (a, b) k m a v)
b3 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {f :: * -> *} {a} {b} {a} {m :: * -> *} {k} {v}.
(Functor f, Ord a, Ord b, Ord a, Ord (m Int), Mapping k m) =>
f (Builder (a, b) k m a v)
-> (a, b) -> (a, m (a, b)) -> f (Builder (a, b) k m a v)
makeN f (Builder (a, b) k m a v)
b2 Map (a, b) (a, m (a, b))
aLN
    b4 :: f (Builder (a, b) k m a v)
b4 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' forall {f :: * -> *} {a} {b} {a} {m :: * -> *} {k} {v}.
(Functor f, Ord a, Ord b, Ord a, Ord (m Int), Mapping k m) =>
f (Builder (a, b) k m a v)
-> (a, b) -> (a, m (a, b)) -> f (Builder (a, b) k m a v)
makeN f (Builder (a, b) k m a v)
b3 Map (a, b) (a, m (a, b))
aNN
    in f (Builder (a, b) k m a v)
b4

  in forall {k} {k} {k} {k}.
(Mapping k m, Mapping k m, Mapping k m, Mapping k m) =>
Map (Int, Int) (f w)
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Map (Int, Int) (a, m (Int, Int))
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
close forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty


-- | Merge two bases
baseMerge ::    (Ord a, Ord w, Ord (m Int), Mapping k m)
             => (u -> v -> w)
             -> Base k m a u -> Base k m a v -> Set (Int, Int) -> Builder (Int, Int) k m a w
baseMerge :: forall a w (m :: * -> *) k u v.
(Ord a, Ord w, Ord (m Int), Mapping k m) =>
(u -> v -> w)
-> Base k m a u
-> Base k m a v
-> Set (Int, Int)
-> Builder (Int, Int) k m a w
baseMerge u -> v -> w
p Base k m a u
b1 Base k m a v
b2 = let
  p' :: u -> v -> Identity w
p' u
x v
y = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ u -> v -> w
p u
x v
y
  in forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a w (m :: * -> *) k u v.
(Applicative f, Ord a, Ord w, Ord (m Int), Mapping k m) =>
(u -> v -> f w)
-> Base k m a u
-> Base k m a v
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
baseMergeA u -> v -> Identity w
p' Base k m a u
b1 Base k m a v
b2


-- | Folds over *all* the leaves; not something you want to do to an
-- arbitrary base
instance Foldable (Base k m a) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Base k m a a -> m
foldMap a -> m
p = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (k :: k) (m :: * -> *) a v. Base k m a v -> Seq v
leaves

instance Foldable m => Foldable (Decision k m a) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Decision k m a a -> m
foldMap a -> m
p (Decision (Base Seq a
l Seq (Node k m a)
m) Int
s) = let
    inner :: m -> IntSet -> IntSet -> m
inner m
x IntSet
old IntSet
new = case IntSet -> Maybe (Int, IntSet)
IS.minView IntSet
new of
      Maybe (Int, IntSet)
Nothing        -> m
x
      Just (Int
i, IntSet
new') -> if Int
i forall a. Ord a => a -> a -> Bool
< Int
0
        then m -> IntSet -> IntSet -> m
inner (m
x forall a. Semigroup a => a -> a -> a
<> a -> m
p (forall a. Seq a -> Int -> a
Q.index Seq a
l (forall a. Bits a => a -> a
complement Int
i))) (Int -> IntSet -> IntSet
IS.insert Int
i IntSet
old) IntSet
new'
        else let
          old' :: IntSet
old' = Int -> IntSet -> IntSet
IS.insert Int
i IntSet
old
          extra :: IntSet
extra = IntSet -> IntSet -> IntSet
IS.difference ([Int] -> IntSet
IS.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (k :: k) (m :: * -> *) a. Node k m a -> m Int
nodeBranch forall a b. (a -> b) -> a -> b
$ forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m Int
i) IntSet
old'
          in m -> IntSet -> IntSet -> m
inner m
x IntSet
old' (IntSet -> IntSet -> IntSet
IS.union IntSet
new' IntSet
extra)
    in m -> IntSet -> IntSet -> m
inner forall a. Monoid a => a
mempty IntSet
IS.empty forall a b. (a -> b) -> a -> b
$ Int -> IntSet
IS.singleton Int
s

instance (Ord a, Ord (m Int), Mapping k m) => Mapping (a -> k) (Decision k m a) where

  cst :: forall v. v -> Decision k m a v
cst v
x = forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Int -> Decision k m a v
Decision (forall {k} (k :: k) (m :: * -> *) a v.
Seq v -> Seq (Node k m a) -> Base k m a v
Base (forall a. a -> Seq a
Q.singleton v
x) forall a. Seq a
Q.empty) (-Int
1)

  act :: forall v. Decision k m a v -> (a -> k) -> v
act (Decision (Base Seq v
l Seq (Node k m a)
n) Int
s) a -> k
f = let
    inner :: Int -> v
inner Int
i
      | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Seq a -> Int -> a
Q.index Seq v
l forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
i
      | Bool
otherwise = let
          Node a
a m Int
m = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
n Int
i
          in Int -> v
inner forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) v. Mapping k m => m v -> k -> v
act m Int
m forall a b. (a -> b) -> a -> b
$ a -> k
f a
a
    in Int -> v
inner Int
s

  -- We assume the diagram is optimised, so it is constant only if it starts
  -- with a leaf.
  isConst :: forall v. Ord v => Decision k m a v -> Maybe v
isConst (Decision (Base Seq v
l Seq (Node k m a)
_) Int
s)
    | Int
s forall a. Ord a => a -> a -> Bool
< Int
0     = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Seq a -> Int -> a
Q.index Seq v
l forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> a
complement Int
s
    | Bool
otherwise = forall a. Maybe a
Nothing

  mtraverse :: forall (f :: * -> *) v u.
(Applicative f, Ord v) =>
(u -> f v) -> Decision k m a u -> f (Decision k m a v)
mtraverse u -> f v
p (Decision (Base Seq u
l Seq (Node k m a)
m) Int
s) = forall {k} o (k :: k) (m :: * -> *) a v.
Ord o =>
o -> Builder o k m a v -> Decision k m a v
buildDecision Int
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a (m :: * -> *) w k v.
(Applicative f, Ord a, Ord (m Int), Ord w, Mapping k m) =>
(v -> f w) -> Base k m a v -> f (Builder Int k m a w)
baseTraverse u -> f v
p (forall {k} (k :: k) (m :: * -> *) a v.
Seq v -> Seq (Node k m a) -> Base k m a v
Base Seq u
l Seq (Node k m a)
m)

  mmap :: forall v u.
Ord v =>
(u -> v) -> Decision k m a u -> Decision k m a v
mmap u -> v
p (Decision Base k m a u
b Int
s) = forall {k} o (k :: k) (m :: * -> *) a v.
Ord o =>
o -> Builder o k m a v -> Decision k m a v
buildDecision Int
s forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *) w k v.
(Ord a, Ord (m Int), Ord w, Mapping k m) =>
(v -> w) -> Base k m a v -> Builder Int k m a w
baseMap u -> v
p Base k m a u
b

  merge :: forall w u v.
Ord w =>
(u -> v -> w)
-> Decision k m a u -> Decision k m a v -> Decision k m a w
merge u -> v -> w
p (Decision Base k m a u
b1 Int
s1) (Decision Base k m a v
b2 Int
s2) = forall {k} o (k :: k) (m :: * -> *) a v.
Ord o =>
o -> Builder o k m a v -> Decision k m a v
buildDecision (Int
s1, Int
s2) forall a b. (a -> b) -> a -> b
$ forall a w (m :: * -> *) k u v.
(Ord a, Ord w, Ord (m Int), Mapping k m) =>
(u -> v -> w)
-> Base k m a u
-> Base k m a v
-> Set (Int, Int)
-> Builder (Int, Int) k m a w
baseMerge u -> v -> w
p Base k m a u
b1 Base k m a v
b2 (forall a. a -> Set a
S.singleton (Int
s1, Int
s2))

  mergeA :: forall (f :: * -> *) w u v.
(Applicative f, Ord w) =>
(u -> v -> f w)
-> Decision k m a u -> Decision k m a v -> f (Decision k m a w)
mergeA u -> v -> f w
p (Decision Base k m a u
b1 Int
s1) (Decision Base k m a v
b2 Int
s2) = forall {k} o (k :: k) (m :: * -> *) a v.
Ord o =>
o -> Builder o k m a v -> Decision k m a v
buildDecision (Int
s1, Int
s2) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a w (m :: * -> *) k u v.
(Applicative f, Ord a, Ord w, Ord (m Int), Mapping k m) =>
(u -> v -> f w)
-> Base k m a u
-> Base k m a v
-> Set (Int, Int)
-> f (Builder (Int, Int) k m a w)
baseMergeA u -> v -> f w
p Base k m a u
b1 Base k m a v
b2 (forall a. a -> Set a
S.singleton (Int
s1, Int
s2))


deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)
  instance (Mapping k m, Ord (m Int), Ord a, Ord v, Semigroup v) => Semigroup (Decision k m a v)

deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)
  instance (Mapping k m, Ord (m Int), Ord a, Ord v, Monoid v) => Monoid (Decision k m a v)

deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)
  instance (Mapping k m, Ord (m Int), Ord a, Ord v, Num v) => Num (Decision k m a v)

deriving via (AlgebraWrapper (a -> k) (Decision k m a) v)
  instance (Mapping k m, Ord (m Int), Ord a, Ord v, Boolean v) => Boolean (Decision k m a v)


-- | Attempt to extend to a bijection
checkBijection :: (Eq a, Eq v, Mapping k m) => Base k m a v -> Base k m a v -> Bij -> Maybe Bij
checkBijection :: forall a v k (m :: * -> *).
(Eq a, Eq v, Mapping k m) =>
Base k m a v -> Base k m a v -> Bij -> Maybe Bij
checkBijection (Base Seq v
l1 Seq (Node k m a)
m1) (Base Seq v
l2 Seq (Node k m a)
m2) = let
  consequences :: Int -> Int -> Maybe Bij
consequences Int
i Int
j = case (Int
i forall a. Ord a => a -> a -> Bool
< Int
0, Int
j forall a. Ord a => a -> a -> Bool
< Int
0) of
    (Bool
True, Bool
True) -> if forall a. Seq a -> Int -> a
Q.index Seq v
l1 (forall a. Bits a => a -> a
complement Int
i) forall a. Eq a => a -> a -> Bool
== forall a. Seq a -> Int -> a
Q.index Seq v
l2 (forall a. Bits a => a -> a
complement Int
j)
      then forall a. a -> Maybe a
Just Bij
B.empty
      else forall a. Maybe a
Nothing
    (Bool
False, Bool
False) -> let
      Node a
r1 m Int
o1 = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m1 Int
i
      Node a
r2 m Int
o2 = forall a. Seq a -> Int -> a
Q.index Seq (Node k m a)
m2 Int
j
      in if a
r1 forall a. Eq a => a -> a -> Bool
== a
r2
        then MaybeBij -> Maybe Bij
B.getMaybeBij forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings Int -> Int -> MaybeBij
B.msingleton m Int
o1 m Int
o2
        else forall a. Maybe a
Nothing
    (Bool, Bool)
_ -> forall a. Maybe a
Nothing
  in (Int -> Int -> Maybe Bij) -> Bij -> Maybe Bij
B.closeBijection Int -> Int -> Maybe Bij
consequences

-- | Are these Decisions isomorphic?
findBijection :: (Eq a, Eq v, Mapping k m) => Decision k m a v -> Decision k m a v -> Maybe Bij
findBijection :: forall a v k (m :: * -> *).
(Eq a, Eq v, Mapping k m) =>
Decision k m a v -> Decision k m a v -> Maybe Bij
findBijection (Decision Base k m a v
b1 Int
s1) (Decision Base k m a v
b2 Int
s2) = forall a v k (m :: * -> *).
(Eq a, Eq v, Mapping k m) =>
Base k m a v -> Base k m a v -> Bij -> Maybe Bij
checkBijection Base k m a v
b1 Base k m a v
b2 (Int -> Int -> Bij
B.singleton Int
s1 Int
s2)

instance (Eq a, Eq v, Mapping k m) => Eq (Decision k m a v) where
  Decision k m a v
u == :: Decision k m a v -> Decision k m a v -> Bool
== Decision k m a v
v = case forall a v k (m :: * -> *).
(Eq a, Eq v, Mapping k m) =>
Decision k m a v -> Decision k m a v -> Maybe Bij
findBijection Decision k m a v
u Decision k m a v
v of
    Just Bij
_ -> Bool
True
    Maybe Bij
Nothing -> Bool
False


-- | A ludicrously short definition!
instance (Ord a, Ord v, Ord (m Int), Mapping k m) => Ord (Decision k m a v) where
  compare :: Decision k m a v -> Decision k m a v -> Ordering
compare = forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings forall a. Ord a => a -> a -> Ordering
compare


-- | Output the structure of a Decision
debugShow :: (Show a, Show v, Show (m Int)) => Decision k m a v -> String
debugShow :: forall {k} a v (m :: * -> *) (k :: k).
(Show a, Show v, Show (m Int)) =>
Decision k m a v -> [Char]
debugShow (Decision (Base Seq v
l Seq (Node k m a)
m) Int
s) = let

  p :: Int
p = Int
1 forall a. Num a => a -> a -> a
+ forall a. Ord a => a -> a -> a
max (Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> [Char]
show (forall a. Seq a -> Int
Q.length Seq v
l))) (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> [Char]
show (Int
1 forall a. Num a => a -> a -> a
+ forall a. Seq a -> Int
Q.length Seq (Node k m a)
m)))

  prefix :: Int -> a -> a
prefix Int
i = ((if Int
i forall a. Eq a => a -> a -> Bool
== Int
s then a
"->" else a
"  ") <>)

  leafLine :: [Char] -> Int -> a -> [Char]
leafLine [Char]
t Int
i a
x = let
    j :: Int
j = forall a. Bits a => a -> a
complement Int
i
    in forall {a}. (Semigroup a, IsString a) => Int -> a -> a
prefix Int
j (forall a. Format [Char] a -> a
F.formatToString (forall a r. Buildable a => Int -> Char -> Format r (a -> r)
F.left Int
p Char
' ' forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (a -> [Char]) (a -> [Char])
": " forall r a r'. Format r a -> Format r' r -> Format r' a
% forall a r. Show a => Format r (a -> r)
F.shown forall r a r'. Format r a -> Format r' r -> Format r' a
% Format [Char] [Char]
"\n") Int
j a
x) forall a. Semigroup a => a -> a -> a
<> [Char]
t

  nodeLine :: Int -> Node k m a -> [Char] -> [Char]
nodeLine Int
i (Node a
r m Int
n) [Char]
t =
    forall {a}. (Semigroup a, IsString a) => Int -> a -> a
prefix Int
i (forall a. Format [Char] a -> a
F.formatToString (forall a r. Buildable a => Int -> Char -> Format r (a -> r)
F.left Int
p Char
' ' forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (a -> m Int -> [Char]) (a -> m Int -> [Char])
": " forall r a r'. Format r a -> Format r' r -> Format r' a
% forall a r. Show a => Format r (a -> r)
F.shown forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (m Int -> [Char]) (m Int -> [Char])
"; " forall r a r'. Format r a -> Format r' r -> Format r' a
% forall a r. Show a => Format r (a -> r)
F.shown forall r a r'. Format r a -> Format r' r -> Format r' a
% Format [Char] [Char]
"\n") Int
i a
r m Int
n) forall a. Semigroup a => a -> a -> a
<> [Char]
t

  in forall b a. (b -> Int -> a -> b) -> b -> Seq a -> b
Q.foldlWithIndex forall {a}. Show a => [Char] -> Int -> a -> [Char]
leafLine (forall a b. (Int -> a -> b -> b) -> b -> Seq a -> b
Q.foldrWithIndex forall {k} {a} {m :: * -> *} {k :: k}.
(Show a, Show (m Int)) =>
Int -> Node k m a -> [Char] -> [Char]
nodeLine [Char]
"" Seq (Node k m a)
m) Seq v
l


instance (Mapping k m,
          Neighbourly m,
          Ord a,
          Ord (m Int))
       => Neighbourly (Decision k m a) where
  neighbours :: forall v. Ord v => Decision k m a v -> Set (v, v)
neighbours (Decision (Base Seq v
l Seq (Node k m a)
m) Int
s) = let
    f :: Seq (Set (v, v)) -> Node k m a -> Seq (Set (v, v))
f Seq (Set (v, v))
v (Node a
_ m Int
n) = let
      here :: Set (v, v)
here = let
        b :: Base k m a v
b = forall {k} (k :: k) (m :: * -> *) a v.
Seq v -> Seq (Node k m a) -> Base k m a v
Base Seq v
l Seq (Node k m a)
m
        e :: (Int, Int) -> Set (v, v)
e (Int
i, Int
j) = forall a. (a -> Bool) -> Set a -> Set a
S.filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(/=)) forall a b. (a -> b) -> a -> b
$ forall u v k (m :: * -> *).
(Ord u, Ord v, Mapping k m) =>
m u -> m v -> Set (u, v)
mutualValues (forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Int -> Decision k m a v
Decision Base k m a v
b Int
i) (forall {k} (k :: k) (m :: * -> *) a v.
Base k m a v -> Int -> Decision k m a v
Decision Base k m a v
b Int
j)
        in forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int, Int) -> Set (v, v)
e forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) v. (Neighbourly m, Ord v) => m v -> Set (v, v)
neighbours m Int
n
      there :: Set (v, v)
there = let
        g :: Int -> Set (v, v)
g Int
i
          | Int
i forall a. Ord a => a -> a -> Bool
< Int
0     = forall a. Monoid a => a
mempty
          | Bool
otherwise = forall a. Seq a -> Int -> a
Q.index Seq (Set (v, v))
v Int
i
        in forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Set (v, v)
g m Int
n
      in Seq (Set (v, v))
v forall a. Seq a -> a -> Seq a
|> (Set (v, v)
here forall a. Semigroup a => a -> a -> a
<> Set (v, v)
there)
    in forall a. Seq a -> Int -> a
Q.index (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {k} {m :: * -> *} {k :: k} {a}.
(Foldable m, Neighbourly m) =>
Seq (Set (v, v)) -> Node k m a -> Seq (Set (v, v))
f forall a. Seq a
Q.empty Seq (Node k m a)
m) Int
s