-- |
-- Module      : MonusWeightedSearch.Internal.Heap
-- Copyright   : (c) Donnacha Oisín Kidney 2021
-- Maintainer  : mail@doisinkidney.com
-- Stability   : experimental
-- Portability : non-portable
--
-- A reference implementation of a pairing heap, to compare to the heap monad.

module MonusWeightedSearch.Internal.Heap (Heap(..),minView, singleton, dijkstra, monusSort) where

import Data.Monus
import Data.Monus.Dist

import qualified Data.Set as Set

import Data.List (unfoldr)

import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup

-- | A pairing heap.
--
-- This implementation does use a monus rather than just a standard ordered
-- key, but that does not change any of the algorithms really.
data Heap a b
  = Leaf
  | Node !a b [Heap a b]
  deriving (Int -> Heap a b -> ShowS
[Heap a b] -> ShowS
Heap a b -> String
(Int -> Heap a b -> ShowS)
-> (Heap a b -> String) -> ([Heap a b] -> ShowS) -> Show (Heap a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Heap a b -> ShowS
forall a b. (Show a, Show b) => [Heap a b] -> ShowS
forall a b. (Show a, Show b) => Heap a b -> String
showList :: [Heap a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [Heap a b] -> ShowS
show :: Heap a b -> String
$cshow :: forall a b. (Show a, Show b) => Heap a b -> String
showsPrec :: Int -> Heap a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Heap a b -> ShowS
Show, (forall a b. (a -> b) -> Heap a a -> Heap a b)
-> (forall a b. a -> Heap a b -> Heap a a) -> Functor (Heap a)
forall a b. a -> Heap a b -> Heap a a
forall a b. (a -> b) -> Heap a a -> Heap a b
forall a a b. a -> Heap a b -> Heap a a
forall a a b. (a -> b) -> Heap a a -> Heap a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Heap a b -> Heap a a
$c<$ :: forall a a b. a -> Heap a b -> Heap a a
fmap :: forall a b. (a -> b) -> Heap a a -> Heap a b
$cfmap :: forall a a b. (a -> b) -> Heap a a -> Heap a b
Functor, (forall m. Monoid m => Heap a m -> m)
-> (forall m a. Monoid m => (a -> m) -> Heap a a -> m)
-> (forall m a. Monoid m => (a -> m) -> Heap a a -> m)
-> (forall a b. (a -> b -> b) -> b -> Heap a a -> b)
-> (forall a b. (a -> b -> b) -> b -> Heap a a -> b)
-> (forall b a. (b -> a -> b) -> b -> Heap a a -> b)
-> (forall b a. (b -> a -> b) -> b -> Heap a a -> b)
-> (forall a. (a -> a -> a) -> Heap a a -> a)
-> (forall a. (a -> a -> a) -> Heap a a -> a)
-> (forall a. Heap a a -> [a])
-> (forall a. Heap a a -> Bool)
-> (forall a. Heap a a -> Int)
-> (forall a. Eq a => a -> Heap a a -> Bool)
-> (forall a. Ord a => Heap a a -> a)
-> (forall a. Ord a => Heap a a -> a)
-> (forall a. Num a => Heap a a -> a)
-> (forall a. Num a => Heap a a -> a)
-> Foldable (Heap a)
forall a. Eq a => a -> Heap a a -> Bool
forall a. Num a => Heap a a -> a
forall a. Ord a => Heap a a -> a
forall m. Monoid m => Heap a m -> m
forall a. Heap a a -> Bool
forall a. Heap a a -> Int
forall a. Heap a a -> [a]
forall a. (a -> a -> a) -> Heap a a -> a
forall a a. Eq a => a -> Heap a a -> Bool
forall a a. Num a => Heap a a -> a
forall a a. Ord a => Heap a a -> a
forall m a. Monoid m => (a -> m) -> Heap a a -> m
forall a m. Monoid m => Heap a m -> m
forall a a. Heap a a -> Bool
forall a a. Heap a a -> Int
forall a a. Heap a a -> [a]
forall b a. (b -> a -> b) -> b -> Heap a a -> b
forall a b. (a -> b -> b) -> b -> Heap a a -> b
forall a a. (a -> a -> a) -> Heap a a -> a
forall a m a. Monoid m => (a -> m) -> Heap a a -> m
forall a b a. (b -> a -> b) -> b -> Heap a a -> b
forall a a b. (a -> b -> b) -> b -> Heap a a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Heap a a -> a
$cproduct :: forall a a. Num a => Heap a a -> a
sum :: forall a. Num a => Heap a a -> a
$csum :: forall a a. Num a => Heap a a -> a
minimum :: forall a. Ord a => Heap a a -> a
$cminimum :: forall a a. Ord a => Heap a a -> a
maximum :: forall a. Ord a => Heap a a -> a
$cmaximum :: forall a a. Ord a => Heap a a -> a
elem :: forall a. Eq a => a -> Heap a a -> Bool
$celem :: forall a a. Eq a => a -> Heap a a -> Bool
length :: forall a. Heap a a -> Int
$clength :: forall a a. Heap a a -> Int
null :: forall a. Heap a a -> Bool
$cnull :: forall a a. Heap a a -> Bool
toList :: forall a. Heap a a -> [a]
$ctoList :: forall a a. Heap a a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Heap a a -> a
$cfoldl1 :: forall a a. (a -> a -> a) -> Heap a a -> a
foldr1 :: forall a. (a -> a -> a) -> Heap a a -> a
$cfoldr1 :: forall a a. (a -> a -> a) -> Heap a a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Heap a a -> b
$cfoldl' :: forall a b a. (b -> a -> b) -> b -> Heap a a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Heap a a -> b
$cfoldl :: forall a b a. (b -> a -> b) -> b -> Heap a a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Heap a a -> b
$cfoldr' :: forall a a b. (a -> b -> b) -> b -> Heap a a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Heap a a -> b
$cfoldr :: forall a a b. (a -> b -> b) -> b -> Heap a a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Heap a a -> m
$cfoldMap' :: forall a m a. Monoid m => (a -> m) -> Heap a a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Heap a a -> m
$cfoldMap :: forall a m a. Monoid m => (a -> m) -> Heap a a -> m
fold :: forall m. Monoid m => Heap a m -> m
$cfold :: forall a m. Monoid m => Heap a m -> m
Foldable, Functor (Heap a)
Foldable (Heap a)
Functor (Heap a)
-> Foldable (Heap a)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Heap a a -> f (Heap a b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Heap a (f a) -> f (Heap a a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Heap a a -> m (Heap a b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Heap a (m a) -> m (Heap a a))
-> Traversable (Heap a)
forall a. Functor (Heap a)
forall a. Foldable (Heap a)
forall a (m :: * -> *) a. Monad m => Heap a (m a) -> m (Heap a a)
forall a (f :: * -> *) a.
Applicative f =>
Heap a (f a) -> f (Heap a a)
forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Heap a a -> m (Heap a b)
forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Heap a a -> f (Heap a b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Heap a (m a) -> m (Heap a a)
forall (f :: * -> *) a.
Applicative f =>
Heap a (f a) -> f (Heap a a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Heap a a -> m (Heap a b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Heap a a -> f (Heap a b)
sequence :: forall (m :: * -> *) a. Monad m => Heap a (m a) -> m (Heap a a)
$csequence :: forall a (m :: * -> *) a. Monad m => Heap a (m a) -> m (Heap a a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Heap a a -> m (Heap a b)
$cmapM :: forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Heap a a -> m (Heap a b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Heap a (f a) -> f (Heap a a)
$csequenceA :: forall a (f :: * -> *) a.
Applicative f =>
Heap a (f a) -> f (Heap a a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Heap a a -> f (Heap a b)
$ctraverse :: forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Heap a a -> f (Heap a b)
Traversable)

instance Monus a => Semigroup (Heap a b) where
  Heap a b
Leaf <> :: Heap a b -> Heap a b -> Heap a b
<> Heap a b
ys = Heap a b
ys
  Heap a b
xs <> Heap a b
Leaf = Heap a b
xs
  Node a
x b
xv [Heap a b]
xs <> Node a
y b
yv [Heap a b]
ys
    | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y    = a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node a
x b
xv (a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node (a
y a -> a -> a
forall a. Monus a => a -> a -> a
|-| a
x) b
yv [Heap a b]
ys Heap a b -> [Heap a b] -> [Heap a b]
forall a. a -> [a] -> [a]
: [Heap a b]
xs)
    | Bool
otherwise = a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node a
y b
yv (a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node (a
x a -> a -> a
forall a. Monus a => a -> a -> a
|-| a
y) b
xv [Heap a b]
xs Heap a b -> [Heap a b] -> [Heap a b]
forall a. a -> [a] -> [a]
: [Heap a b]
ys)
  {-# INLINE (<>) #-}

  sconcat :: NonEmpty (Heap a b) -> Heap a b
sconcat (Heap a b
x :| []) = Heap a b
x
  sconcat (Heap a b
x1 :| [Heap a b
x2]) = Heap a b
x1 Heap a b -> Heap a b -> Heap a b
forall a. Semigroup a => a -> a -> a
<> Heap a b
x2
  sconcat (Heap a b
x1 :| Heap a b
x2 : Heap a b
x3 : [Heap a b]
xs) = (Heap a b
x1 Heap a b -> Heap a b -> Heap a b
forall a. Semigroup a => a -> a -> a
<> Heap a b
x2) Heap a b -> Heap a b -> Heap a b
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Heap a b) -> Heap a b
forall a. Semigroup a => NonEmpty a -> a
sconcat (Heap a b
x3 Heap a b -> [Heap a b] -> NonEmpty (Heap a b)
forall a. a -> [a] -> NonEmpty a
:| [Heap a b]
xs)
  {-# INLINABLE sconcat #-}

instance Monus a => Monoid (Heap a b) where
  mempty :: Heap a b
mempty = Heap a b
forall a b. Heap a b
Leaf
  {-# INLINE mempty #-}

  mconcat :: [Heap a b] -> Heap a b
mconcat []     = Heap a b
forall a b. Heap a b
Leaf
  mconcat (Heap a b
x:[Heap a b]
xs) = NonEmpty (Heap a b) -> Heap a b
forall a. Semigroup a => NonEmpty a -> a
sconcat (Heap a b
x Heap a b -> [Heap a b] -> NonEmpty (Heap a b)
forall a. a -> [a] -> NonEmpty a
:| [Heap a b]
xs)
  {-# INLINE mconcat #-}

mergeHeaps :: Monus a => [Heap a b] -> Heap a b
mergeHeaps :: forall a b. Monus a => [Heap a b] -> Heap a b
mergeHeaps [] = Heap a b
forall a b. Heap a b
Leaf
mergeHeaps (Heap a b
x : [Heap a b]
xs) = Heap a b -> [Heap a b] -> Heap a b
forall {t}. Semigroup t => t -> [t] -> t
go Heap a b
x [Heap a b]
xs
  where
    go :: t -> [t] -> t
go t
x [] = t
x
    go t
x1 [t
x2] = t
x1 t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t
x2
    go t
x1 (t
x2 : t
x3 : [t]
xs) = (t
x1 t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t
x2) t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t -> [t] -> t
go t
x3 [t]
xs
{-# INLINE mergeHeaps #-}

(<><) :: Monus a => a -> Heap a b -> Heap a b
a
x <>< :: forall a b. Monus a => a -> Heap a b -> Heap a b
<>< Heap a b
Leaf = Heap a b
forall a b. Heap a b
Leaf
a
x <>< Node a
y b
yv [Heap a b]
ys = a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y) b
yv [Heap a b]
ys
{-# INLINE (<><) #-}

-- | /O(log n)/. Pop the minimum element and its key in the heap, and return it.
minView :: Monus a => Heap a b -> Maybe ((a, b), Heap a b)
minView :: forall a b. Monus a => Heap a b -> Maybe ((a, b), Heap a b)
minView Heap a b
Leaf = Maybe ((a, b), Heap a b)
forall a. Maybe a
Nothing
minView (Node a
x b
xv [Heap a b]
xs) = ((a, b), Heap a b) -> Maybe ((a, b), Heap a b)
forall a. a -> Maybe a
Just ((a
x, b
xv), a
x a -> Heap a b -> Heap a b
forall a b. Monus a => a -> Heap a b -> Heap a b
<>< [Heap a b] -> Heap a b
forall a b. Monus a => [Heap a b] -> Heap a b
mergeHeaps [Heap a b]
xs)
{-# INLINE minView #-}

-- | A singleton heap.
singleton :: a -> b -> Heap a b
singleton :: forall a b. a -> b -> Heap a b
singleton a
x b
y = a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node a
x b
y []
{-# INLINE singleton #-}

-- | An implementation of Dijkstra's algorithm on 'Graph's.
dijkstra :: Ord a => Graph a -> Graph a
dijkstra :: forall a. Ord a => Graph a -> Graph a
dijkstra Graph a
g a
s = Set a -> Heap Dist a -> [(a, Dist)]
go Set a
forall a. Set a
Set.empty (Dist -> a -> [Heap Dist a] -> Heap Dist a
forall a b. a -> b -> [Heap a b] -> Heap a b
Node Dist
forall a. Monoid a => a
mempty a
s [])
  where
    go :: Set a -> Heap Dist a -> [(a, Dist)]
go Set a
s Heap Dist a
hp = case Heap Dist a -> Maybe ((Dist, a), Heap Dist a)
forall a b. Monus a => Heap a b -> Maybe ((a, b), Heap a b)
minView Heap Dist a
hp of
      Maybe ((Dist, a), Heap Dist a)
Nothing -> []
      Just ((Dist
w,a
x),Heap Dist a
xs)
        | a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
s -> Set a -> Heap Dist a -> [(a, Dist)]
go Set a
s Heap Dist a
xs
        | Bool
otherwise -> (a
x,Dist
w) (a, Dist) -> [(a, Dist)] -> [(a, Dist)]
forall a. a -> [a] -> [a]
: Set a -> Heap Dist a -> [(a, Dist)]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) (Heap Dist a
xs Heap Dist a -> Heap Dist a -> Heap Dist a
forall a. Semigroup a => a -> a -> a
<> [Heap Dist a] -> Heap Dist a
forall a b. Monus a => [Heap a b] -> Heap a b
mergeHeaps (((a, Dist) -> Heap Dist a) -> [(a, Dist)] -> [Heap Dist a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Dist) -> Heap Dist a
f (Graph a
g a
x)))
          where
            f :: (a, Dist) -> Heap Dist a
f (a
y, Dist
w') = Dist -> a -> [Heap Dist a] -> Heap Dist a
forall a b. a -> b -> [Heap a b] -> Heap a b
Node (Dist
w Dist -> Dist -> Dist
forall a. Semigroup a => a -> a -> a
<> Dist
w') a
y []
{-# INLINE dijkstra #-}

-- | Sort a list of 'Dist'.
monusSort :: [Dist] -> [Dist]
monusSort :: [Dist] -> [Dist]
monusSort = ((Dist, ()) -> Dist) -> [(Dist, ())] -> [Dist]
forall a b. (a -> b) -> [a] -> [b]
map (Dist, ()) -> Dist
forall a b. (a, b) -> a
fst ([(Dist, ())] -> [Dist])
-> ([Dist] -> [(Dist, ())]) -> [Dist] -> [Dist]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Heap Dist () -> Maybe ((Dist, ()), Heap Dist ()))
-> Heap Dist () -> [(Dist, ())]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Heap Dist () -> Maybe ((Dist, ()), Heap Dist ())
forall a b. Monus a => Heap a b -> Maybe ((a, b), Heap a b)
minView (Heap Dist () -> [(Dist, ())])
-> ([Dist] -> Heap Dist ()) -> [Dist] -> [(Dist, ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dist -> Heap Dist ()) -> [Dist] -> Heap Dist ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Dist -> () -> Heap Dist ()
forall a b. a -> b -> Heap a b
`singleton` ())
{-# INLINE monusSort #-}