{-# LANGUAGE TypeFamilies #-}

module Test.Credit.Heap.Binomial where

import Prettyprinter (Pretty)
import Control.Monad.Credit
import Test.Credit
import Test.Credit.Heap.Base

data Tree a = Node Int a [Tree a]
  deriving (Tree a -> Tree a -> Bool
(Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool) -> Eq (Tree a)
forall a. Eq a => Tree a -> Tree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Tree a -> Tree a -> Bool
== :: Tree a -> Tree a -> Bool
$c/= :: forall a. Eq a => Tree a -> Tree a -> Bool
/= :: Tree a -> Tree a -> Bool
Eq, Eq (Tree a)
Eq (Tree a) =>
(Tree a -> Tree a -> Ordering)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Tree a)
-> (Tree a -> Tree a -> Tree a)
-> Ord (Tree a)
Tree a -> Tree a -> Bool
Tree a -> Tree a -> Ordering
Tree a -> Tree a -> Tree a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Tree a)
forall a. Ord a => Tree a -> Tree a -> Bool
forall a. Ord a => Tree a -> Tree a -> Ordering
forall a. Ord a => Tree a -> Tree a -> Tree a
$ccompare :: forall a. Ord a => Tree a -> Tree a -> Ordering
compare :: Tree a -> Tree a -> Ordering
$c< :: forall a. Ord a => Tree a -> Tree a -> Bool
< :: Tree a -> Tree a -> Bool
$c<= :: forall a. Ord a => Tree a -> Tree a -> Bool
<= :: Tree a -> Tree a -> Bool
$c> :: forall a. Ord a => Tree a -> Tree a -> Bool
> :: Tree a -> Tree a -> Bool
$c>= :: forall a. Ord a => Tree a -> Tree a -> Bool
>= :: Tree a -> Tree a -> Bool
$cmax :: forall a. Ord a => Tree a -> Tree a -> Tree a
max :: Tree a -> Tree a -> Tree a
$cmin :: forall a. Ord a => Tree a -> Tree a -> Tree a
min :: Tree a -> Tree a -> Tree a
Ord, Int -> Tree a -> ShowS
[Tree a] -> ShowS
Tree a -> String
(Int -> Tree a -> ShowS)
-> (Tree a -> String) -> ([Tree a] -> ShowS) -> Show (Tree a)
forall a. Show a => Int -> Tree a -> ShowS
forall a. Show a => [Tree a] -> ShowS
forall a. Show a => Tree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Tree a -> ShowS
showsPrec :: Int -> Tree a -> ShowS
$cshow :: forall a. Show a => Tree a -> String
show :: Tree a -> String
$cshowList :: forall a. Show a => [Tree a] -> ShowS
showList :: [Tree a] -> ShowS
Show)

rank :: Tree a -> Int
rank :: forall a. Tree a -> Int
rank (Node Int
r a
_ [Tree a]
_) = Int
r

root :: Tree a -> a
root :: forall a. Tree a -> a
root (Node Int
_ a
x [Tree a]
_) = a
x

rev :: MonadCredit m => [a] -> [a] -> m [a]
rev :: forall (m :: * -> *) a. MonadCredit m => [a] -> [a] -> m [a]
rev [] [a]
acc = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
acc
rev (a
x : [a]
xs) [a]
acc = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m [a] -> m [a]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> [a] -> m [a]
forall (m :: * -> *) a. MonadCredit m => [a] -> [a] -> m [a]
rev [a]
xs (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)

link :: Ord a => Tree a -> Tree a -> Tree a
link :: forall a. Ord a => Tree a -> Tree a -> Tree a
link t1 :: Tree a
t1@(Node Int
r a
x1 [Tree a]
c1) t2 :: Tree a
t2@(Node Int
_ a
x2 [Tree a]
c2)
  | a
x1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x2 = Int -> a -> [Tree a] -> Tree a
forall a. Int -> a -> [Tree a] -> Tree a
Node (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a
x1 (Tree a
t2Tree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
:[Tree a]
c1)
  | Bool
otherwise = Int -> a -> [Tree a] -> Tree a
forall a. Int -> a -> [Tree a] -> Tree a
Node (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a
x2 (Tree a
t1Tree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
:[Tree a]
c2)

insTree :: MonadCredit m => Ord a => Tree a -> [Tree a] -> m [Tree a]
insTree :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> [Tree a] -> m [Tree a]
insTree Tree a
t [] = [Tree a] -> m [Tree a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tree a
t]
insTree Tree a
t ts :: [Tree a]
ts@(Tree a
t':[Tree a]
ts')
  | Tree a -> Int
forall a. Tree a -> Int
rank Tree a
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Tree a -> Int
forall a. Tree a -> Int
rank Tree a
t' = [Tree a] -> m [Tree a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Tree a] -> m [Tree a]) -> [Tree a] -> m [Tree a]
forall a b. (a -> b) -> a -> b
$ Tree a
tTree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
:[Tree a]
ts
  | Bool
otherwise = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m [Tree a] -> m [Tree a]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tree a -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> [Tree a] -> m [Tree a]
insTree (Tree a -> Tree a -> Tree a
forall a. Ord a => Tree a -> Tree a -> Tree a
link Tree a
t Tree a
t') [Tree a]
ts'

mrg :: MonadCredit m => Ord a => [Tree a] -> [Tree a] -> m [Tree a]
mrg :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> [Tree a] -> m [Tree a]
mrg [Tree a]
ts1 [] = [Tree a] -> m [Tree a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tree a]
ts1
mrg [] [Tree a]
ts2 = [Tree a] -> m [Tree a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tree a]
ts2
mrg ts1 :: [Tree a]
ts1@(Tree a
t1:[Tree a]
ts1') ts2 :: [Tree a]
ts2@(Tree a
t2:[Tree a]
ts2')
  | Tree a -> Int
forall a. Tree a -> Int
rank Tree a
t1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Tree a -> Int
forall a. Tree a -> Int
rank Tree a
t2 = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m [Tree a] -> m [Tree a]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Tree a
t1 :) ([Tree a] -> [Tree a]) -> m [Tree a] -> m [Tree a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree a] -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> [Tree a] -> m [Tree a]
mrg [Tree a]
ts1' [Tree a]
ts2
  | Tree a -> Int
forall a. Tree a -> Int
rank Tree a
t2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Tree a -> Int
forall a. Tree a -> Int
rank Tree a
t1 = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m [Tree a] -> m [Tree a]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Tree a
t2 :) ([Tree a] -> [Tree a]) -> m [Tree a] -> m [Tree a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree a] -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> [Tree a] -> m [Tree a]
mrg [Tree a]
ts1 [Tree a]
ts2'
  | Bool
otherwise = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m [Tree a] -> m [Tree a]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
    Tree a -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> [Tree a] -> m [Tree a]
insTree (Tree a -> Tree a -> Tree a
forall a. Ord a => Tree a -> Tree a -> Tree a
link Tree a
t1 Tree a
t2) ([Tree a] -> m [Tree a]) -> m [Tree a] -> m [Tree a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Tree a] -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> [Tree a] -> m [Tree a]
mrg [Tree a]
ts1' [Tree a]
ts2'

removeMinTree :: MonadCredit m => Ord a => [Tree a] -> m (Tree a, [Tree a])
removeMinTree :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> m (Tree a, [Tree a])
removeMinTree [] = String -> m (Tree a, [Tree a])
forall a. HasCallStack => String -> a
error String
"removeMinTree"
removeMinTree [Tree a
t] = (Tree a, [Tree a]) -> m (Tree a, [Tree a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree a
t, [])
removeMinTree (Tree a
t:[Tree a]
ts) = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m (Tree a, [Tree a]) -> m (Tree a, [Tree a])
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
  (Tree a
t', [Tree a]
ts') <- [Tree a] -> m (Tree a, [Tree a])
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> m (Tree a, [Tree a])
removeMinTree [Tree a]
ts
  (Tree a, [Tree a]) -> m (Tree a, [Tree a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Tree a, [Tree a]) -> m (Tree a, [Tree a]))
-> (Tree a, [Tree a]) -> m (Tree a, [Tree a])
forall a b. (a -> b) -> a -> b
$ if Tree a -> a
forall a. Tree a -> a
root Tree a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= Tree a -> a
forall a. Tree a -> a
root Tree a
t' then (Tree a
t, [Tree a]
ts) else (Tree a
t', Tree a
tTree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
:[Tree a]
ts')

data Binomial a m = Binomial Size (Thunk m (Lazy m) [Tree a])

allZeros :: Size -> Credit
allZeros :: Size -> Credit
allZeros Size
0 = Credit
0
allZeros Size
n = (Size -> Credit
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size -> Credit) -> Size -> Credit
forall a b. (a -> b) -> a -> b
$ (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size -> Size -> Size
forall a. Integral a => a -> a -> a
`mod` Size
2) Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
+ Size -> Credit
allZeros (Size
n Size -> Size -> Size
forall a. Integral a => a -> a -> a
`div` Size
2)

instance Heap Binomial where
  empty :: forall (m :: * -> *) a. MonadCredit m => m (Binomial a m)
empty = do
    Thunk m (Lazy m) [Tree a]
t <- Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall (m :: * -> *) (t :: * -> *) a.
MonadLazy m =>
t a -> m (Thunk m t a)
forall (t :: * -> *) a. t a -> m (Thunk m t a)
delay (Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a]))
-> Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall a b. (a -> b) -> a -> b
$ m [Tree a] -> Lazy m [Tree a]
forall {k} (m :: k -> *) (a :: k). m a -> Lazy m a
Lazy (m [Tree a] -> Lazy m [Tree a]) -> m [Tree a] -> Lazy m [Tree a]
forall a b. (a -> b) -> a -> b
$ [Tree a] -> m [Tree a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Binomial a m -> m (Binomial a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binomial a m -> m (Binomial a m))
-> Binomial a m -> m (Binomial a m)
forall a b. (a -> b) -> a -> b
$ Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
forall a (m :: * -> *).
Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
Binomial Size
0 Thunk m (Lazy m) [Tree a]
t
  insert :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
a -> Binomial a m -> m (Binomial a m)
insert a
x (Binomial Size
n Thunk m (Lazy m) [Tree a]
h) = do
    Thunk m (Lazy m) [Tree a]
ts <- Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall (m :: * -> *) (t :: * -> *) a.
MonadLazy m =>
t a -> m (Thunk m t a)
forall (t :: * -> *) a. t a -> m (Thunk m t a)
delay (Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a]))
-> Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall a b. (a -> b) -> a -> b
$ m [Tree a] -> Lazy m [Tree a]
forall {k} (m :: k -> *) (a :: k). m a -> Lazy m a
Lazy (m [Tree a] -> Lazy m [Tree a]) -> m [Tree a] -> Lazy m [Tree a]
forall a b. (a -> b) -> a -> b
$ do 
      Thunk m (Lazy m) [Tree a] -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
creditWith Thunk m (Lazy m) [Tree a]
h (Size -> Credit
allZeros Size
n)
      [Tree a]
h' <- Thunk m (Lazy m) [Tree a] -> m [Tree a]
forall (m :: * -> *) (t :: * -> *) a.
(MonadLazy m, HasStep t m) =>
Thunk m t a -> m a
forall (t :: * -> *) a. HasStep t m => Thunk m t a -> m a
force Thunk m (Lazy m) [Tree a]
h
      Tree a -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> [Tree a] -> m [Tree a]
insTree (Int -> a -> [Tree a] -> Tree a
forall a. Int -> a -> [Tree a] -> Tree a
Node Int
0 a
x []) [Tree a]
h'
    Thunk m (Lazy m) [Tree a] -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
creditWith Thunk m (Lazy m) [Tree a]
ts Credit
2
    Binomial a m -> m (Binomial a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binomial a m -> m (Binomial a m))
-> Binomial a m -> m (Binomial a m)
forall a b. (a -> b) -> a -> b
$ Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
forall a (m :: * -> *).
Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
Binomial (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Thunk m (Lazy m) [Tree a]
ts
  merge :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Binomial a m -> Binomial a m -> m (Binomial a m)
merge (Binomial Size
n1 Thunk m (Lazy m) [Tree a]
t1) (Binomial Size
n2 Thunk m (Lazy m) [Tree a]
t2) = do
    Thunk m (Lazy m) [Tree a]
t1 Thunk m (Lazy m) [Tree a] -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
`creditWith` (Size -> Credit
allZeros Size
n1)
    [Tree a]
ts1 <- Thunk m (Lazy m) [Tree a] -> m [Tree a]
forall (m :: * -> *) (t :: * -> *) a.
(MonadLazy m, HasStep t m) =>
Thunk m t a -> m a
forall (t :: * -> *) a. HasStep t m => Thunk m t a -> m a
force Thunk m (Lazy m) [Tree a]
t1
    Thunk m (Lazy m) [Tree a]
t2 Thunk m (Lazy m) [Tree a] -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
`creditWith` (Size -> Credit
allZeros Size
n2)
    [Tree a]
ts2 <- Thunk m (Lazy m) [Tree a] -> m [Tree a]
forall (m :: * -> *) (t :: * -> *) a.
(MonadLazy m, HasStep t m) =>
Thunk m t a -> m a
forall (t :: * -> *) a. HasStep t m => Thunk m t a -> m a
force Thunk m (Lazy m) [Tree a]
t2
    Thunk m (Lazy m) [Tree a]
ts <- Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall (m :: * -> *) (t :: * -> *) a.
MonadLazy m =>
t a -> m (Thunk m t a)
forall (t :: * -> *) a. t a -> m (Thunk m t a)
delay (Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a]))
-> Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall a b. (a -> b) -> a -> b
$ m [Tree a] -> Lazy m [Tree a]
forall {k} (m :: k -> *) (a :: k). m a -> Lazy m a
Lazy (m [Tree a] -> Lazy m [Tree a]) -> m [Tree a] -> Lazy m [Tree a]
forall a b. (a -> b) -> a -> b
$ [Tree a] -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> [Tree a] -> m [Tree a]
mrg [Tree a]
ts1 [Tree a]
ts2
    Thunk m (Lazy m) [Tree a]
ts Thunk m (Lazy m) [Tree a] -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
`creditWith` (Size -> Credit
log2 (Size
n1 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
n2))
    Binomial a m -> m (Binomial a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binomial a m -> m (Binomial a m))
-> Binomial a m -> m (Binomial a m)
forall a b. (a -> b) -> a -> b
$ Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
forall a (m :: * -> *).
Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
Binomial (Size
n1 Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
n2) Thunk m (Lazy m) [Tree a]
ts
  splitMin :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Binomial a m -> m (Maybe (a, Binomial a m))
splitMin (Binomial Size
n Thunk m (Lazy m) [Tree a]
t) = do
    Thunk m (Lazy m) [Tree a] -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
creditWith Thunk m (Lazy m) [Tree a]
t (Size -> Credit
log2 Size
n)
    [Tree a]
ts <- Thunk m (Lazy m) [Tree a] -> m [Tree a]
forall (m :: * -> *) (t :: * -> *) a.
(MonadLazy m, HasStep t m) =>
Thunk m t a -> m a
forall (t :: * -> *) a. HasStep t m => Thunk m t a -> m a
force Thunk m (Lazy m) [Tree a]
t
    case [Tree a]
ts of
      [] -> Maybe (a, Binomial a m) -> m (Maybe (a, Binomial a m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, Binomial a m)
forall a. Maybe a
Nothing
      [Tree a]
_ -> do
        (Node Int
_ a
x [Tree a]
ts1, [Tree a]
ts2) <- [Tree a] -> m (Tree a, [Tree a])
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> m (Tree a, [Tree a])
removeMinTree [Tree a]
ts
        Thunk m (Lazy m) [Tree a]
t' <- Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall (m :: * -> *) (t :: * -> *) a.
MonadLazy m =>
t a -> m (Thunk m t a)
forall (t :: * -> *) a. t a -> m (Thunk m t a)
delay (Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a]))
-> Lazy m [Tree a] -> m (Thunk m (Lazy m) [Tree a])
forall a b. (a -> b) -> a -> b
$ m [Tree a] -> Lazy m [Tree a]
forall {k} (m :: k -> *) (a :: k). m a -> Lazy m a
Lazy (m [Tree a] -> Lazy m [Tree a]) -> m [Tree a] -> Lazy m [Tree a]
forall a b. (a -> b) -> a -> b
$ do
          [Tree a]
rts1 <- [Tree a] -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a. MonadCredit m => [a] -> [a] -> m [a]
rev [Tree a]
ts1 []
          [Tree a] -> [Tree a] -> m [Tree a]
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
[Tree a] -> [Tree a] -> m [Tree a]
mrg [Tree a]
rts1 [Tree a]
ts2
        Thunk m (Lazy m) [Tree a] -> Credit -> m ()
forall (m :: * -> *) (t :: * -> *) a.
MonadCredit m =>
Thunk m t a -> Credit -> m ()
forall (t :: * -> *) a. Thunk m t a -> Credit -> m ()
creditWith Thunk m (Lazy m) [Tree a]
t' (Credit
2 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
* Size -> Credit
log2 Size
n)
        Maybe (a, Binomial a m) -> m (Maybe (a, Binomial a m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Binomial a m) -> m (Maybe (a, Binomial a m)))
-> Maybe (a, Binomial a m) -> m (Maybe (a, Binomial a m))
forall a b. (a -> b) -> a -> b
$ (a, Binomial a m) -> Maybe (a, Binomial a m)
forall a. a -> Maybe a
Just (a
x, Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
forall a (m :: * -> *).
Size -> Thunk m (Lazy m) [Tree a] -> Binomial a m
Binomial (Size -> Size -> Size
forall a. Ord a => a -> a -> a
max Size
0 (Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1)) Thunk m (Lazy m) [Tree a]
t')

instance BoundedHeap Binomial where
  hcost :: forall a. Size -> HeapOp a -> Credit
hcost Size
_ (Insert a
_) = Credit
2
  hcost Size
n HeapOp a
Merge = Credit
3 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
* Size -> Credit
log2 Size
n
  hcost Size
n HeapOp a
SplitMin = Credit
4 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
* Size -> Credit
log2 Size
n

instance MemoryCell m a => MemoryCell m (Tree a) where
  prettyCell :: Tree a -> m Memory
prettyCell (Node Int
r a
x [Tree a]
c) = do
    Memory
r' <- Int -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Int
r
    Memory
x' <- a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell a
x
    [Memory]
c' <- (Tree a -> m Memory) -> [Tree a] -> m [Memory]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Tree a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell [Tree a]
c
    Memory -> m Memory
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Memory -> m Memory) -> Memory -> m Memory
forall a b. (a -> b) -> a -> b
$ String -> [Memory] -> Memory
mkMCell String
"Node" [Memory
r', Memory
x', [Memory] -> Maybe Memory -> Memory
mkMList [Memory]
c' Maybe Memory
forall a. Maybe a
Nothing]

instance (MonadMemory m, MemoryCell m a) => MemoryCell m (Binomial a m) where
  prettyCell :: Binomial a m -> m Memory
prettyCell (Binomial Size
_ Thunk m (Lazy m) [Tree a]
t) = do
    Memory
t' <- Thunk m (Lazy m) [Tree a] -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Thunk m (Lazy m) [Tree a]
t
    Memory -> m Memory
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Memory -> m Memory) -> Memory -> m Memory
forall a b. (a -> b) -> a -> b
$ String -> [Memory] -> Memory
mkMCell String
"Binomial" [Memory
t']

instance Pretty a => MemoryStructure (Binomial (PrettyCell a)) where
  prettyStructure :: forall (m :: * -> *).
MonadMemory m =>
Binomial (PrettyCell a) m -> m Memory
prettyStructure = Binomial (PrettyCell a) m -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell