{-
    Copyright (C) Stilo International plc, 2019

    See LICENSE
-}

{-# 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

{- | A lazy-spined priority queue where the type parameters t c a are:

* t for a phantom that can be either Pruned for a single-item container or Branching for a growing priority queue;

* c for the cost type, like Sum Int; and

* a for the values
-}
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 k@ adds a penalty of k to each value in the queue.
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 #-}

-- | Fold together all stored values that share the same priority.
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)

-- | Imposes the given cost on the current computation branch.
-- > cost k = withCost k (pure ())
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 ())

-- | Relax the 'Pruned' phantom constraint, allowing the queue to become 'Branching'.
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

-- | Prune away all stored values more expensive than the given cost.
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 #-}

-- | Prune away all stored values more expensive than the given cost and a less expensive alternative value.
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 away all stored values except the one with the least penalty, making the queue 'Pruned'.
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

-- | Minimize the queue structure. This operation forces the entire spine of the queue and its every level.
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 away from the queue the values that the argument function maps to `False`
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

-- | Assuming the stored values belong to a cancellative monoid, prune away all extraneous values and factors using the
-- supplied function that calculates the sum and difference of the two values, if there is any difference, and the monoid null.
-- > fold (pruneSubsets plusDiff mempty pq) == fold pq
-- >   where plusDiff u a
-- >           | gcd u a == a = Nothing
-- >           | d <- a - gcd u a = Just (u <> d, d)
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')

-- | Returns the pair of the GCD of all the penalties and the penalties without the GCD
-- > gcd <*> rest == f
-- >   where (gcd, rest) = stripCommon f
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)

-- | Subtract the first argument cost GCD from the cost of every value in the second argument
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
-- stripCost c q = error ("stripCost " <> show c <> " " <> show (() <$ q))

-- | Returns 'Just' the minimal cost present in the queue, 'Nothing' if the queue is 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

-- | Maps each item contained in the queue, supplying the item's cost as first argument
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