{-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
module Data.PriorityQueue (PQueue, Branching, Pruned,
branchable, prune, pruneAbove, pruneAlternativesAbove, mapWithCost, filter, foldPeers,
canonical, pruneSubsets, strip, stripCommon,
cost, leastCost, withCost) where
import Control.Applicative (Applicative(..), Alternative(..))
import Data.Coerce (coerce)
import Data.Foldable (Foldable(fold))
import Data.Monoid (Monoid(mempty, mappend), Alt(Alt, getAlt))
import Data.Semigroup (Semigroup((<>)))
import Prelude hiding (filter)
data Branching
data Pruned
data PQueue t c a = Costly !c (PQueue t c a)
| Free !(Ground a) (PQueue t c a)
| Empty
deriving Int -> PQueue t c a -> ShowS
[PQueue t c a] -> ShowS
PQueue t c a -> String
(Int -> PQueue t c a -> ShowS)
-> (PQueue t c a -> String)
-> ([PQueue t c a] -> ShowS)
-> Show (PQueue t c a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t c a. (Show c, Show a) => Int -> PQueue t c a -> ShowS
forall t c a. (Show c, Show a) => [PQueue t c a] -> ShowS
forall t c a. (Show c, Show a) => PQueue t c a -> String
showList :: [PQueue t c a] -> ShowS
$cshowList :: forall t c a. (Show c, Show a) => [PQueue t c a] -> ShowS
show :: PQueue t c a -> String
$cshow :: forall t c a. (Show c, Show a) => PQueue t c a -> String
showsPrec :: Int -> PQueue t c a -> ShowS
$cshowsPrec :: forall t c a. (Show c, Show a) => Int -> PQueue t c a -> ShowS
Show
data Ground a = Leaf a
| Peer !(Ground a) !(Ground a)
deriving Int -> Ground a -> ShowS
[Ground a] -> ShowS
Ground a -> String
(Int -> Ground a -> ShowS)
-> (Ground a -> String) -> ([Ground a] -> ShowS) -> Show (Ground a)
forall a. Show a => Int -> Ground a -> ShowS
forall a. Show a => [Ground a] -> ShowS
forall a. Show a => Ground a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ground a] -> ShowS
$cshowList :: forall a. Show a => [Ground a] -> ShowS
show :: Ground a -> String
$cshow :: forall a. Show a => Ground a -> String
showsPrec :: Int -> Ground a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Ground a -> ShowS
Show
instance Foldable Ground where
foldMap :: (a -> m) -> Ground a -> m
foldMap a -> m
f (Leaf a
a) = a -> m
f a
a
foldMap a -> m
f (Peer Ground a
g Ground a
h) = (a -> m) -> Ground a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Ground a
g m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> Ground a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Ground a
h
instance Functor Ground where
fmap :: (a -> b) -> Ground a -> Ground b
fmap a -> b
f (Leaf a
a) = b -> Ground b
forall a. a -> Ground a
Leaf (a -> b
f a
a)
fmap a -> b
f (Peer Ground a
g Ground a
h) = Ground b -> Ground b -> Ground b
forall a. Ground a -> Ground a -> Ground a
Peer ((a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Ground a
g) ((a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Ground a
h)
instance Applicative Ground where
Leaf a -> b
f <*> :: Ground (a -> b) -> Ground a -> Ground b
<*> Ground a
g = a -> b
f (a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ground a
g
Peer Ground (a -> b)
g1 Ground (a -> b)
g2 <*> Ground a
h = Ground b -> Ground b -> Ground b
forall a. Ground a -> Ground a -> Ground a
Peer (Ground (a -> b)
g1 Ground (a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ground a
h) (Ground (a -> b)
g2 Ground (a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ground a
h)
pure :: a -> Ground a
pure = a -> Ground a
forall a. a -> Ground a
Leaf
instance Foldable (PQueue t c) where
foldMap :: (a -> m) -> PQueue t c a -> m
foldMap a -> m
f (Costly c
_ PQueue t c a
q) = (a -> m) -> PQueue t c a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f PQueue t c a
q
foldMap a -> m
f (Free Ground a
a PQueue t c a
q) = (a -> m) -> Ground a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Ground a
a m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> PQueue t c a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f PQueue t c a
q
foldMap a -> m
f PQueue t c a
Empty = m
forall a. Monoid a => a
mempty
instance Functor (PQueue t c) where
fmap :: (a -> b) -> PQueue t c a -> PQueue t c b
fmap a -> b
f (Costly c
c PQueue t c a
q) = c -> PQueue t c b -> PQueue t c b
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c ((a -> b) -> PQueue t c a -> PQueue t c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PQueue t c a
q)
fmap a -> b
f (Free Ground a
a PQueue t c a
q) = Ground b -> PQueue t c b -> PQueue t c b
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free ((a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Ground a
a) ((a -> b) -> PQueue t c a -> PQueue t c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PQueue t c a
q)
fmap a -> b
_ PQueue t c a
Empty = PQueue t c b
forall t c a. PQueue t c a
Empty
instance (Alternative (PQueue t c), Semigroup c) => Applicative (PQueue t c) where
Costly c
c1 PQueue t c (a -> b)
q1 <*> :: PQueue t c (a -> b) -> PQueue t c a -> PQueue t c b
<*> Costly c
c2 PQueue t c a
q2 = c -> PQueue t c b -> PQueue t c b
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly (c
c1 c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
c2) (PQueue t c (a -> b)
q1 PQueue t c (a -> b) -> PQueue t c a -> PQueue t c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PQueue t c a
q2)
Costly c
c PQueue t c (a -> b)
q1 <*> PQueue t c a
q2 = c -> PQueue t c b -> PQueue t c b
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c (PQueue t c (a -> b)
q1 PQueue t c (a -> b) -> PQueue t c a -> PQueue t c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PQueue t c a
q2)
PQueue t c (a -> b)
q1 <*> Costly c
c PQueue t c a
q2 = c -> PQueue t c b -> PQueue t c b
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c (PQueue t c (a -> b)
q1 PQueue t c (a -> b) -> PQueue t c a -> PQueue t c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PQueue t c a
q2)
Free Ground (a -> b)
f PQueue t c (a -> b)
q1 <*> Free Ground a
a PQueue t c a
q2 = Ground b -> PQueue t c b -> PQueue t c b
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (Ground (a -> b)
f Ground (a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ground a
a) ((Ground a -> Ground b) -> PQueue t c a -> PQueue t c b
forall a a t c t.
(Ground a -> Ground a) -> PQueue t c a -> PQueue t c a
mapPeers (Ground (a -> b)
f Ground (a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) PQueue t c a
q2 PQueue t c b -> PQueue t c b -> PQueue t c b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Ground (a -> b) -> Ground b)
-> PQueue t c (a -> b) -> PQueue t c b
forall a a t c t.
(Ground a -> Ground a) -> PQueue t c a -> PQueue t c a
mapPeers (Ground (a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ground a
a) PQueue t c (a -> b)
q1 PQueue t c b -> PQueue t c b -> PQueue t c b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue t c (a -> b)
q1 PQueue t c (a -> b) -> PQueue t c a -> PQueue t c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PQueue t c a
q2)
where mapPeers :: (Ground a -> Ground a) -> PQueue t c a -> PQueue t c a
mapPeers Ground a -> Ground a
f (Free Ground a
g PQueue t c a
q) = Ground a -> PQueue t c a -> PQueue t c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (Ground a -> Ground a
f Ground a
g) ((Ground a -> Ground a) -> PQueue t c a -> PQueue t c a
mapPeers Ground a -> Ground a
f PQueue t c a
q)
mapPeers Ground a -> Ground a
f (Costly c
c PQueue t c a
q) = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c ((Ground a -> Ground a) -> PQueue t c a -> PQueue t c a
mapPeers Ground a -> Ground a
f PQueue t c a
q)
mapPeers Ground a -> Ground a
f PQueue t c a
Empty = PQueue t c a
forall t c a. PQueue t c a
Empty
PQueue t c (a -> b)
Empty <*> PQueue t c a
_ = PQueue t c b
forall t c a. PQueue t c a
Empty
PQueue t c (a -> b)
_ <*> PQueue t c a
Empty = PQueue t c b
forall t c a. PQueue t c a
Empty
pure :: a -> PQueue t c a
pure a
a = Ground a -> PQueue t c a -> PQueue t c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (a -> Ground a
forall a. a -> Ground a
Leaf a
a) PQueue t c a
forall t c a. PQueue t c a
Empty
{-# INLINABLE (<*>) #-}
instance (Num c, Ord c, Semigroup c) => Alternative (PQueue Branching c) where
Costly c
c1 PQueue Branching c a
q1 <|> :: PQueue Branching c a
-> PQueue Branching c a -> PQueue Branching c a
<|> Costly c
c2 PQueue Branching c a
q2 = {-# SCC "AltB.compare" #-}
case c -> c -> Ordering
forall a. Ord a => a -> a -> Ordering
compare c
c1 c
c2
of Ordering
LT -> c -> PQueue Branching c a -> PQueue Branching c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c1 (PQueue Branching c a
q1 PQueue Branching c a
-> PQueue Branching c a -> PQueue Branching c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> c -> PQueue Branching c a -> PQueue Branching c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly (c
c2 c -> c -> c
forall a. Num a => a -> a -> a
- c
c1) PQueue Branching c a
q2)
Ordering
GT -> c -> PQueue Branching c a -> PQueue Branching c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c2 (c -> PQueue Branching c a -> PQueue Branching c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly (c
c1 c -> c -> c
forall a. Num a => a -> a -> a
- c
c2) PQueue Branching c a
q1 PQueue Branching c a
-> PQueue Branching c a -> PQueue Branching c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue Branching c a
q2)
Ordering
EQ -> c -> PQueue Branching c a -> PQueue Branching c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c1 (PQueue Branching c a
q1 PQueue Branching c a
-> PQueue Branching c a -> PQueue Branching c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue Branching c a
q2)
Free Ground a
a PQueue Branching c a
q1 <|> Free Ground a
b PQueue Branching c a
q2 = Ground a -> PQueue Branching c a -> PQueue Branching c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (Ground a -> Ground a -> Ground a
forall a. Ground a -> Ground a -> Ground a
Peer Ground a
a Ground a
b) (PQueue Branching c a
q1 PQueue Branching c a
-> PQueue Branching c a -> PQueue Branching c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue Branching c a
q2)
Free Ground a
a PQueue Branching c a
q1 <|> PQueue Branching c a
q2 = Ground a -> PQueue Branching c a -> PQueue Branching c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground a
a (PQueue Branching c a
q1 PQueue Branching c a
-> PQueue Branching c a -> PQueue Branching c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue Branching c a
q2)
PQueue Branching c a
q1 <|> Free Ground a
a PQueue Branching c a
q2 = Ground a -> PQueue Branching c a -> PQueue Branching c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground a
a (PQueue Branching c a
q1 PQueue Branching c a
-> PQueue Branching c a -> PQueue Branching c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue Branching c a
q2)
PQueue Branching c a
Empty <|> PQueue Branching c a
pq = PQueue Branching c a
pq
PQueue Branching c a
pq <|> PQueue Branching c a
Empty = PQueue Branching c a
pq
empty :: PQueue Branching c a
empty = PQueue Branching c a
forall t c a. PQueue t c a
Empty
{-# INLINABLE (<|>) #-}
instance (Num c, Ord c, Semigroup c) => Alternative (PQueue Pruned c) where
Costly c
c1 PQueue Pruned c a
q1 <|> :: PQueue Pruned c a -> PQueue Pruned c a -> PQueue Pruned c a
<|> Costly c
c2 PQueue Pruned c a
q2 = {-# SCC "AltP.compare" #-}
case c -> c -> Ordering
forall a. Ord a => a -> a -> Ordering
compare c
c1 c
c2
of Ordering
LT -> c -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c1 (PQueue Pruned c a
q1 PQueue Pruned c a -> PQueue Pruned c a -> PQueue Pruned c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> c -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly (c
c2 c -> c -> c
forall a. Num a => a -> a -> a
- c
c1) PQueue Pruned c a
q2)
Ordering
GT -> c -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c2 (c -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly (c
c1 c -> c -> c
forall a. Num a => a -> a -> a
- c
c2) PQueue Pruned c a
q1 PQueue Pruned c a -> PQueue Pruned c a -> PQueue Pruned c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue Pruned c a
q2)
Ordering
EQ -> c -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c1 (PQueue Pruned c a
q1 PQueue Pruned c a -> PQueue Pruned c a -> PQueue Pruned c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PQueue Pruned c a
q2)
Free Ground a
a PQueue Pruned c a
_ <|> PQueue Pruned c a
_ = Ground a -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground a
a PQueue Pruned c a
forall t c a. PQueue t c a
Empty
PQueue Pruned c a
_ <|> Free Ground a
a PQueue Pruned c a
_ = Ground a -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground a
a PQueue Pruned c a
forall t c a. PQueue t c a
Empty
PQueue Pruned c a
Empty <|> PQueue Pruned c a
pq = PQueue Pruned c a
pq
PQueue Pruned c a
pq <|> PQueue Pruned c a
Empty = PQueue Pruned c a
pq
empty :: PQueue Pruned c a
empty = PQueue Pruned c a
forall t c a. PQueue t c a
Empty
{-# INLINABLE (<|>) #-}
instance (Semigroup c, Alternative (PQueue t c)) => Monad (PQueue t c) where
Costly c
c PQueue t c a
q >>= :: PQueue t c a -> (a -> PQueue t c b) -> PQueue t c b
>>= a -> PQueue t c b
f = c -> PQueue t c b -> PQueue t c b
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c (PQueue t c a
q PQueue t c a -> (a -> PQueue t c b) -> PQueue t c b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> PQueue t c b
f)
Free Ground a
a PQueue t c a
q >>= a -> PQueue t c b
f = Alt (PQueue t c) b -> PQueue t c b
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt ((a -> Alt (PQueue t c) b) -> Ground a -> Alt (PQueue t c) b
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PQueue t c b -> Alt (PQueue t c) b
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (PQueue t c b -> Alt (PQueue t c) b)
-> (a -> PQueue t c b) -> a -> Alt (PQueue t c) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PQueue t c b
f) Ground a
a) PQueue t c b -> PQueue t c b -> PQueue t c b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (PQueue t c a
q PQueue t c a -> (a -> PQueue t c b) -> PQueue t c b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> PQueue t c b
f)
PQueue t c a
Empty >>= a -> PQueue t c b
_ = PQueue t c b
forall t c a. PQueue t c a
Empty
{-# INLINABLE (>>=) #-}
withCost :: (Semigroup c, Num c, Ord c) => c -> PQueue t c a -> PQueue t c a
withCost :: c -> PQueue t c a -> PQueue t c a
withCost c
0 PQueue t c a
q = PQueue t c a
q
withCost c
c PQueue t c a
q | c
c c -> c -> Bool
forall a. Ord a => a -> a -> Bool
<= c
0 = String -> PQueue t c a
forall a. HasCallStack => String -> a
error String
"The cost must be non-negative!"
| Bool
otherwise = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c PQueue t c a
q
{-# INLINE withCost #-}
foldPeers :: (a -> a -> a) -> PQueue t c a -> PQueue t c a
foldPeers :: (a -> a -> a) -> PQueue t c a -> PQueue t c a
foldPeers a -> a -> a
_ PQueue t c a
Empty = PQueue t c a
forall t c a. PQueue t c a
Empty
foldPeers a -> a -> a
f (Costly c
c PQueue t c a
q) = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c ((a -> a -> a) -> PQueue t c a -> PQueue t c a
forall a t c. (a -> a -> a) -> PQueue t c a -> PQueue t c a
foldPeers a -> a -> a
f PQueue t c a
q)
foldPeers a -> a -> a
f (Free Ground a
g PQueue t c a
q) = Ground a -> PQueue t c a -> PQueue t c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (a -> Ground a
forall a. a -> Ground a
Leaf a
a'') PQueue t c a
q''
where (a
a'', PQueue t c a
q'') = case (a -> a -> a) -> PQueue t c a -> PQueue t c a
forall a t c. (a -> a -> a) -> PQueue t c a -> PQueue t c a
foldPeers a -> a -> a
f PQueue t c a
q
of Free (Leaf a
b) PQueue t c a
q' -> (a -> a -> a
f a
a' a
b, PQueue t c a
q')
PQueue t c a
q' -> (a
a', PQueue t c a
q')
a' :: a
a' = (a -> a -> a) -> Ground a -> a
forall a. (a -> a -> a) -> Ground a -> a
foldGroundPeers a -> a -> a
f Ground a
g
foldGroundPeers :: (a -> a -> a) -> Ground a -> a
foldGroundPeers :: (a -> a -> a) -> Ground a -> a
foldGroundPeers a -> a -> a
_ (Leaf a
a) = a
a
foldGroundPeers a -> a -> a
f (Peer Ground a
l Ground a
r) = a -> a -> a
f ((a -> a -> a) -> Ground a -> a
forall a. (a -> a -> a) -> Ground a -> a
foldGroundPeers a -> a -> a
f Ground a
l) ((a -> a -> a) -> Ground a -> a
forall a. (a -> a -> a) -> Ground a -> a
foldGroundPeers a -> a -> a
f Ground a
r)
cost :: (Semigroup c, Num c, Ord c) => c -> PQueue Branching c ()
cost :: c -> PQueue Branching c ()
cost c
0 = () -> PQueue Branching c ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
cost c
k | c
k c -> c -> Bool
forall a. Ord a => a -> a -> Bool
> c
0 = c -> PQueue Branching c () -> PQueue Branching c ()
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
k (() -> PQueue Branching c ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
branchable :: PQueue Pruned c a -> PQueue t c a
branchable :: PQueue Pruned c a -> PQueue t c a
branchable = PQueue Pruned c a -> PQueue t c a
coerce
pruneAbove :: (Semigroup c, Num c, Ord c) => c -> PQueue t c a -> PQueue t c a
pruneAbove :: c -> PQueue t c a -> PQueue t c a
pruneAbove c
k PQueue t c a
_
| c
k c -> c -> Bool
forall a. Ord a => a -> a -> Bool
< c
0 = PQueue t c a
forall t c a. PQueue t c a
Empty
pruneAbove c
k (Costly c
c PQueue t c a
q)
| c
k' c -> c -> Bool
forall a. Ord a => a -> a -> Bool
< c
0 = PQueue t c a
forall t c a. PQueue t c a
Empty
| Bool
otherwise = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c (c -> PQueue t c a -> PQueue t c a
forall c t a.
(Semigroup c, Num c, Ord c) =>
c -> PQueue t c a -> PQueue t c a
pruneAbove c
k' PQueue t c a
q)
where k' :: c
k' = c
k c -> c -> c
forall a. Num a => a -> a -> a
- c
c
pruneAbove c
k (Free Ground a
a PQueue t c a
q) = Ground a -> PQueue t c a -> PQueue t c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground a
a (c -> PQueue t c a -> PQueue t c a
forall c t a.
(Semigroup c, Num c, Ord c) =>
c -> PQueue t c a -> PQueue t c a
pruneAbove c
k PQueue t c a
q)
pruneAbove c
_ PQueue t c a
Empty = PQueue t c a
forall t c a. PQueue t c a
Empty
{-# INLINABLE pruneAbove #-}
pruneAlternativesAbove :: (Semigroup c, Num c, Ord c) => c -> PQueue t c a -> PQueue t c a
pruneAlternativesAbove :: c -> PQueue t c a -> PQueue t c a
pruneAlternativesAbove c
k PQueue t c a
q
| c
k c -> c -> Bool
forall a. Ord a => a -> a -> Bool
<= c
0 = PQueue t c a
q
pruneAlternativesAbove c
k (Costly c
c PQueue t c a
q) = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c (c -> PQueue t c a -> PQueue t c a
forall c t a.
(Semigroup c, Num c, Ord c) =>
c -> PQueue t c a -> PQueue t c a
pruneAlternativesAbove (c
k c -> c -> c
forall a. Num a => a -> a -> a
- c
c) PQueue t c a
q)
pruneAlternativesAbove c
k (Free Ground a
a PQueue t c a
q) = Ground a -> PQueue t c a -> PQueue t c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground a
a (c -> PQueue t c a -> PQueue t c a
forall c t a.
(Semigroup c, Num c, Ord c) =>
c -> PQueue t c a -> PQueue t c a
pruneAbove c
k PQueue t c a
q)
pruneAlternativesAbove c
_ PQueue t c a
Empty = PQueue t c a
forall t c a. PQueue t c a
Empty
{-# INLINABLE pruneAlternativesAbove #-}
prune :: PQueue t c a -> PQueue Pruned c a
prune :: PQueue t c a -> PQueue Pruned c a
prune (Costly c
c PQueue t c a
q) = c -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c (PQueue t c a -> PQueue Pruned c a
forall t c a. PQueue t c a -> PQueue Pruned c a
prune PQueue t c a
q)
prune (Free Ground a
a PQueue t c a
q) = Ground a -> PQueue Pruned c a -> PQueue Pruned c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (a -> Ground a
forall a. a -> Ground a
Leaf (a -> Ground a) -> a -> Ground a
forall a b. (a -> b) -> a -> b
$ Ground a -> a
forall a. Ground a -> a
leftmost Ground a
a) PQueue Pruned c a
forall t c a. PQueue t c a
Empty
where leftmost :: Ground a -> a
leftmost :: Ground a -> a
leftmost (Leaf a
a) = a
a
leftmost (Peer Ground a
l Ground a
r) = Ground a -> a
forall a. Ground a -> a
leftmost Ground a
l
prune PQueue t c a
Empty = PQueue Pruned c a
forall t c a. PQueue t c a
Empty
canonical :: Semigroup c => PQueue t c a -> PQueue t c a
canonical :: PQueue t c a -> PQueue t c a
canonical (Costly c
c1 (Costly c
c2 PQueue t c a
q)) = PQueue t c a -> PQueue t c a
forall c t a. Semigroup c => PQueue t c a -> PQueue t c a
canonical (c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly (c
c1 c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
c2) PQueue t c a
q)
canonical (Costly c
c PQueue t c a
q) = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c (PQueue t c a -> PQueue t c a
forall c t a. Semigroup c => PQueue t c a -> PQueue t c a
canonical PQueue t c a
q)
canonical (Free Ground a
a PQueue t c a
q) = Ground a -> PQueue t c a -> PQueue t c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground a
a (PQueue t c a -> PQueue t c a
forall c t a. Semigroup c => PQueue t c a -> PQueue t c a
canonical PQueue t c a
q)
canonical PQueue t c a
Empty = PQueue t c a
forall t c a. PQueue t c a
Empty
filter :: (a -> Bool) -> PQueue t c a -> PQueue t c a
filter :: (a -> Bool) -> PQueue t c a -> PQueue t c a
filter a -> Bool
f (Costly c
c PQueue t c a
q) = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c ((a -> Bool) -> PQueue t c a -> PQueue t c a
forall a t c. (a -> Bool) -> PQueue t c a -> PQueue t c a
filter a -> Bool
f PQueue t c a
q)
filter a -> Bool
f (Free Ground a
g PQueue t c a
q) = (PQueue t c a -> PQueue t c a)
-> (Ground a -> PQueue t c a -> PQueue t c a)
-> Maybe (Ground a)
-> PQueue t c a
-> PQueue t c a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PQueue t c a -> PQueue t c a
forall a. a -> a
id Ground a -> PQueue t c a -> PQueue t c a
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (Ground a -> Maybe (Ground a)
filterGround Ground a
g) ((a -> Bool) -> PQueue t c a -> PQueue t c a
forall a t c. (a -> Bool) -> PQueue t c a -> PQueue t c a
filter a -> Bool
f PQueue t c a
q)
where filterGround :: Ground a -> Maybe (Ground a)
filterGround g :: Ground a
g@(Leaf a
a) = if a -> Bool
f a
a then Ground a -> Maybe (Ground a)
forall a. a -> Maybe a
Just Ground a
g else Maybe (Ground a)
forall a. Maybe a
Nothing
filterGround (Peer Ground a
g1 Ground a
g2) = case (Ground a -> Maybe (Ground a)
filterGround Ground a
g1, Ground a -> Maybe (Ground a)
filterGround Ground a
g2)
of (Just Ground a
g1', Just Ground a
g2') -> Ground a -> Maybe (Ground a)
forall a. a -> Maybe a
Just (Ground a -> Ground a -> Ground a
forall a. Ground a -> Ground a -> Ground a
Peer Ground a
g1' Ground a
g2')
(Just Ground a
g', Maybe (Ground a)
Nothing) -> Ground a -> Maybe (Ground a)
forall a. a -> Maybe a
Just Ground a
g'
(Maybe (Ground a)
Nothing, Just Ground a
g') -> Ground a -> Maybe (Ground a)
forall a. a -> Maybe a
Just Ground a
g'
(Maybe (Ground a)
Nothing, Maybe (Ground a)
Nothing) -> Maybe (Ground a)
forall a. Maybe a
Nothing
filter a -> Bool
_ PQueue t c a
Empty = PQueue t c a
forall t c a. PQueue t c a
Empty
pruneSubsets :: (a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
pruneSubsets :: (a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
pruneSubsets a -> b -> Maybe (a, b)
unionDiff a
set (Costly c
c PQueue t c b
q) = c -> PQueue t c b -> PQueue t c b
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c ((a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
forall a b t c.
(a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
pruneSubsets a -> b -> Maybe (a, b)
unionDiff a
set PQueue t c b
q)
pruneSubsets a -> b -> Maybe (a, b)
unionDiff a
set (Free Ground b
g PQueue t c b
q) =
case (a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
forall a b.
(a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
pruneGroundSubsets a -> b -> Maybe (a, b)
unionDiff a
set Ground b
g
of Maybe (a, Ground b)
Nothing -> (a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
forall a b t c.
(a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
pruneSubsets a -> b -> Maybe (a, b)
unionDiff a
set PQueue t c b
q
Just (a
set', Ground b
g') -> Ground b -> PQueue t c b -> PQueue t c b
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free Ground b
g' ((a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
forall a b t c.
(a -> b -> Maybe (a, b)) -> a -> PQueue t c b -> PQueue t c b
pruneSubsets a -> b -> Maybe (a, b)
unionDiff a
set' PQueue t c b
q)
pruneSubsets a -> b -> Maybe (a, b)
_ a
_ PQueue t c b
Empty = PQueue t c b
forall t c a. PQueue t c a
Empty
pruneGroundSubsets :: (a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
pruneGroundSubsets :: (a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
pruneGroundSubsets a -> b -> Maybe (a, b)
unionDiff a
set (Leaf b
l) = case a -> b -> Maybe (a, b)
unionDiff a
set b
l
of Maybe (a, b)
Nothing -> Maybe (a, Ground b)
forall a. Maybe a
Nothing
Just (a
set', b
l') -> (a, Ground b) -> Maybe (a, Ground b)
forall a. a -> Maybe a
Just (a
set', b -> Ground b
forall a. a -> Ground a
Leaf b
l')
pruneGroundSubsets a -> b -> Maybe (a, b)
unionDiff a
set (Peer Ground b
g1 Ground b
g2) =
case (a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
forall a b.
(a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
pruneGroundSubsets a -> b -> Maybe (a, b)
unionDiff a
set Ground b
g1
of Maybe (a, Ground b)
Nothing -> (a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
forall a b.
(a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
pruneGroundSubsets a -> b -> Maybe (a, b)
unionDiff a
set Ground b
g2
Just (a
set', Ground b
g1') -> case (a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
forall a b.
(a -> b -> Maybe (a, b)) -> a -> Ground b -> Maybe (a, Ground b)
pruneGroundSubsets a -> b -> Maybe (a, b)
unionDiff a
set' Ground b
g2
of Maybe (a, Ground b)
Nothing -> (a, Ground b) -> Maybe (a, Ground b)
forall a. a -> Maybe a
Just (a
set', Ground b
g1')
Just (a
set'', Ground b
g2') -> (a, Ground b) -> Maybe (a, Ground b)
forall a. a -> Maybe a
Just (a
set'', Ground b -> Ground b -> Ground b
forall a. Ground a -> Ground a -> Ground a
Peer Ground b
g1' Ground b
g2')
stripCommon :: (Ord c, Num c, Functor f, Foldable f, Alternative (PQueue t c)) =>
f (PQueue t c a) -> (PQueue Pruned c (a -> a), f (PQueue t c a))
stripCommon :: f (PQueue t c a) -> (PQueue Pruned c (a -> a), f (PQueue t c a))
stripCommon f (PQueue t c a)
f = (PQueue Pruned c (a -> a)
common, PQueue Pruned c (a -> a) -> PQueue t c a -> PQueue t c a
forall c a t b.
(Ord c, Num c) =>
PQueue Pruned c a -> PQueue t c b -> PQueue t c b
strip PQueue Pruned c (a -> a)
common (PQueue t c a -> PQueue t c a)
-> f (PQueue t c a) -> f (PQueue t c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (PQueue t c a)
f)
where common :: PQueue Pruned c (a -> a)
common = (a -> a) -> a -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id (a -> a -> a) -> PQueue Pruned c a -> PQueue Pruned c (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PQueue t c a -> PQueue Pruned c a
forall t c a. PQueue t c a -> PQueue Pruned c a
prune (Alt (PQueue t c) a -> PQueue t c a
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt (Alt (PQueue t c) a -> PQueue t c a)
-> Alt (PQueue t c) a -> PQueue t c a
forall a b. (a -> b) -> a -> b
$ (PQueue t c a -> Alt (PQueue t c) a)
-> f (PQueue t c a) -> Alt (PQueue t c) a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap PQueue t c a -> Alt (PQueue t c) a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt f (PQueue t c a)
f)
strip :: (Ord c, Num c) => PQueue Pruned c a -> PQueue t c b -> PQueue t c b
strip :: PQueue Pruned c a -> PQueue t c b -> PQueue t c b
strip (Costly c
c PQueue Pruned c a
q1) PQueue t c b
q2 = c -> PQueue t c b -> PQueue t c b
forall c t a. (Ord c, Num c) => c -> PQueue t c a -> PQueue t c a
stripCost c
c (PQueue Pruned c a -> PQueue t c b -> PQueue t c b
forall c a t b.
(Ord c, Num c) =>
PQueue Pruned c a -> PQueue t c b -> PQueue t c b
strip PQueue Pruned c a
q1 PQueue t c b
q2)
strip PQueue Pruned c a
_ PQueue t c b
q = PQueue t c b
q
stripCost :: (Ord c, Num c) => c -> PQueue t c a -> PQueue t c a
stripCost :: c -> PQueue t c a -> PQueue t c a
stripCost c
c (Costly c
c' PQueue t c a
q)
| c
c c -> c -> Bool
forall a. Ord a => a -> a -> Bool
< c
c' = c -> PQueue t c a -> PQueue t c a
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly (c
c' c -> c -> c
forall a. Num a => a -> a -> a
- c
c) PQueue t c a
q
| c
c c -> c -> Bool
forall a. Ord a => a -> a -> Bool
> c
c' = c -> PQueue t c a -> PQueue t c a
forall c t a. (Ord c, Num c) => c -> PQueue t c a -> PQueue t c a
stripCost (c
c c -> c -> c
forall a. Num a => a -> a -> a
- c
c') PQueue t c a
q
| Bool
otherwise = PQueue t c a
q
stripCost c
_ PQueue t c a
Empty = PQueue t c a
forall t c a. PQueue t c a
Empty
leastCost :: Monoid c => PQueue t c a -> Maybe c
leastCost :: PQueue t c a -> Maybe c
leastCost (Costly c
c PQueue t c a
q) = (c
c c -> c -> c
forall a. Semigroup a => a -> a -> a
<>) (c -> c) -> Maybe c -> Maybe c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PQueue t c a -> Maybe c
forall c t a. Monoid c => PQueue t c a -> Maybe c
leastCost PQueue t c a
q
leastCost Free{} = c -> Maybe c
forall a. a -> Maybe a
Just c
forall a. Monoid a => a
mempty
leastCost PQueue t c a
Empty = Maybe c
forall a. Maybe a
Nothing
mapWithCost :: Monoid c => (c -> a -> b) -> PQueue t c a -> PQueue t c b
mapWithCost :: (c -> a -> b) -> PQueue t c a -> PQueue t c b
mapWithCost c -> a -> b
f (Costly c
c PQueue t c a
q) = c -> PQueue t c b -> PQueue t c b
forall t c a. c -> PQueue t c a -> PQueue t c a
Costly c
c ((c -> a -> b) -> PQueue t c a -> PQueue t c b
forall c a b t.
Monoid c =>
(c -> a -> b) -> PQueue t c a -> PQueue t c b
mapWithCost (c -> a -> b
f (c -> a -> b) -> (c -> c) -> c -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c
c c -> c -> c
forall a. Semigroup a => a -> a -> a
<>)) PQueue t c a
q)
mapWithCost c -> a -> b
f (Free Ground a
a PQueue t c a
q) = Ground b -> PQueue t c b -> PQueue t c b
forall t c a. Ground a -> PQueue t c a -> PQueue t c a
Free (c -> a -> b
f c
forall a. Monoid a => a
mempty (a -> b) -> Ground a -> Ground b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ground a
a) ((c -> a -> b) -> PQueue t c a -> PQueue t c b
forall c a b t.
Monoid c =>
(c -> a -> b) -> PQueue t c a -> PQueue t c b
mapWithCost c -> a -> b
f PQueue t c a
q)
mapWithCost c -> a -> b
_ PQueue t c a
Empty = PQueue t c b
forall t c a. PQueue t c a
Empty