{-# LANGUAGE TypeFamilies #-}

module Test.Credit.Heap.Scheduled where

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

data Stream m a
  = SCons a (Stream m a)
  | SNil
  | SIndirect (Thunk m (Lazy m) (Stream m a))

indirect :: MonadCredit m => m (Stream m a) -> m (Stream m a)
indirect :: forall (m :: * -> *) a.
MonadCredit m =>
m (Stream m a) -> m (Stream m a)
indirect = (Thunk m (Lazy m) (Stream m a) -> Stream m a)
-> m (Thunk m (Lazy m) (Stream m a)) -> m (Stream m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Thunk m (Lazy m) (Stream m a) -> Stream m a
forall (m :: * -> *) a. Thunk m (Lazy m) (Stream m a) -> Stream m a
SIndirect (m (Thunk m (Lazy m) (Stream m a)) -> m (Stream m a))
-> (m (Stream m a) -> m (Thunk m (Lazy m) (Stream m a)))
-> m (Stream m a)
-> m (Stream m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lazy m (Stream m a) -> m (Thunk m (Lazy m) (Stream m 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 (Stream m a) -> m (Thunk m (Lazy m) (Stream m a)))
-> (m (Stream m a) -> Lazy m (Stream m a))
-> m (Stream m a)
-> m (Thunk m (Lazy m) (Stream m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Stream m a) -> Lazy m (Stream m a)
forall {k} (m :: k -> *) (a :: k). m a -> Lazy m a
Lazy

credit :: MonadCredit m => Credit -> Stream m a -> m ()
credit :: forall (m :: * -> *) a.
MonadCredit m =>
Credit -> Stream m a -> m ()
credit Credit
cr (SIndirect Thunk m (Lazy m) (Stream m a)
i) = Thunk m (Lazy m) (Stream m 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) (Stream m a)
i Credit
cr
credit Credit
_ Stream m a
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Smart destructor for streams, consuming one credit
smatch :: MonadCredit m => Stream m a -- ^ Scrutinee
       -> m b -- ^ Nil case
       -> (a -> Stream m a -> m b) -- ^ Cons case
       -> m b
smatch :: forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m a
x m b
nil a -> Stream m a -> m b
cons = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m a -> m b
eval Stream m a
x
  where
    eval :: Stream m a -> m b
eval Stream m a
x = case Stream m a
x of
      SCons a
a Stream m a
as -> a -> Stream m a -> m b
cons a
a Stream m a
as
      Stream m a
SNil -> m b
nil
      SIndirect Thunk m (Lazy m) (Stream m a)
i -> Thunk m (Lazy m) (Stream m a) -> m (Stream m 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) (Stream m a)
i m (Stream m a) -> (Stream m a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stream m a -> m b
eval

data Tree a = Node 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)

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

type Schedule m a = [Stream m (Digit a)]

data Scheduled a m = Scheduled (Stream m (Digit a)) (Schedule m a)

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 a
x1 [Tree a]
c1) t2 :: Tree a
t2@(Node a
x2 [Tree a]
c2)
  | a
x1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x2 = a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
x1 (Tree a
t2Tree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
:[Tree a]
c1)
  | Bool
otherwise = a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node 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 -> Stream m (Digit a) -> m (Stream m (Digit a))
insTree :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> Stream m (Digit a) -> m (Stream m (Digit a))
insTree Tree a
t Stream m (Digit a)
s = Stream m (Digit a)
-> m (Stream m (Digit a))
-> (Digit a -> Stream m (Digit a) -> m (Stream m (Digit a)))
-> m (Stream m (Digit a))
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
s
  (Stream m (Digit a) -> m (Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream m (Digit a) -> m (Stream m (Digit a)))
-> Stream m (Digit a) -> m (Stream m (Digit a))
forall a b. (a -> b) -> a -> b
$ Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons (Tree a -> Digit a
forall a. Tree a -> Digit a
One Tree a
t) Stream m (Digit a)
forall (m :: * -> *) a. Stream m a
SNil)
  (\Digit a
d Stream m (Digit a)
ds -> case Digit a
d of
    Digit a
Zero -> Stream m (Digit a) -> m (Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream m (Digit a) -> m (Stream m (Digit a)))
-> Stream m (Digit a) -> m (Stream m (Digit a))
forall a b. (a -> b) -> a -> b
$ Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons (Tree a -> Digit a
forall a. Tree a -> Digit a
One Tree a
t) Stream m (Digit a)
ds
    One Tree a
t' -> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
MonadCredit m =>
m (Stream m a) -> m (Stream m a)
indirect (m (Stream m (Digit a)) -> m (Stream m (Digit a)))
-> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall a b. (a -> b) -> a -> b
$ do
      Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
forall a. Digit a
Zero (Stream m (Digit a) -> Stream m (Digit a))
-> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree a -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> Stream m (Digit a) -> m (Stream m (Digit 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') Stream m (Digit a)
ds)

mrg :: MonadCredit m => Ord a => Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
mrg :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
mrg Stream m (Digit a)
ds1 Stream m (Digit a)
ds2 = Credit -> Stream m (Digit a) -> m ()
forall (m :: * -> *) a.
MonadCredit m =>
Credit -> Stream m a -> m ()
credit Credit
1 Stream m (Digit a)
ds1 m () -> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m (Digit a)
-> m (Stream m (Digit a))
-> (Digit a -> Stream m (Digit a) -> m (Stream m (Digit a)))
-> m (Stream m (Digit a))
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
ds1
  (Stream m (Digit a) -> m (Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream m (Digit a)
ds2)
  (\Digit a
d1 Stream m (Digit a)
ds1 -> Credit -> Stream m (Digit a) -> m ()
forall (m :: * -> *) a.
MonadCredit m =>
Credit -> Stream m a -> m ()
credit Credit
1 Stream m (Digit a)
ds1 m () -> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m (Digit a)
-> m (Stream m (Digit a))
-> (Digit a -> Stream m (Digit a) -> m (Stream m (Digit a)))
-> m (Stream m (Digit a))
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
ds2
    (Stream m (Digit a) -> m (Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream m (Digit a) -> m (Stream m (Digit a)))
-> Stream m (Digit a) -> m (Stream m (Digit a))
forall a b. (a -> b) -> a -> b
$ Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
d1 Stream m (Digit a)
ds1)
    (\Digit a
d2 Stream m (Digit a)
ds2 -> case (Digit a
d1, Digit a
d2) of
      (Digit a
Zero, Digit a
_) -> Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
d2 (Stream m (Digit a) -> Stream m (Digit a))
-> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
mrg Stream m (Digit a)
ds1 Stream m (Digit a)
ds2
      (Digit a
_, Digit a
Zero) -> Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
d1 (Stream m (Digit a) -> Stream m (Digit a))
-> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
mrg Stream m (Digit a)
ds1 Stream m (Digit a)
ds2
      (One Tree a
t1, One Tree a
t2) -> Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
forall a. Digit a
Zero (Stream m (Digit a) -> Stream m (Digit a))
-> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree a -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> Stream m (Digit a) -> m (Stream m (Digit 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) (Stream m (Digit a) -> m (Stream m (Digit a)))
-> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
mrg Stream m (Digit a)
ds1 Stream m (Digit a)
ds2)))

normalize :: MonadCredit m => Ord a => Stream m (Digit a) -> m (Stream m (Digit a))
normalize :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Stream m (Digit a))
normalize Stream m (Digit a)
ds = Credit -> Stream m (Digit a) -> m ()
forall (m :: * -> *) a.
MonadCredit m =>
Credit -> Stream m a -> m ()
credit Credit
1 Stream m (Digit a)
ds m () -> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m (Digit a)
-> m (Stream m (Digit a))
-> (Digit a -> Stream m (Digit a) -> m (Stream m (Digit a)))
-> m (Stream m (Digit a))
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
ds
    (Stream m (Digit a) -> m (Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream m (Digit a)
forall (m :: * -> *) a. Stream m a
SNil)
    (\Digit a
d Stream m (Digit a)
ds -> Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
d (Stream m (Digit a) -> Stream m (Digit a))
-> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Stream m (Digit a))
normalize Stream m (Digit a)
ds)

exec :: MonadCredit m => Schedule m a -> m (Schedule m a)
exec :: forall (m :: * -> *) a.
MonadCredit m =>
Schedule m a -> m (Schedule m a)
exec [] = [Stream m (Digit a)] -> m [Stream m (Digit a)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
exec (Stream m (Digit a)
ds:[Stream m (Digit a)]
dss) = Credit -> Stream m (Digit a) -> m ()
forall (m :: * -> *) a.
MonadCredit m =>
Credit -> Stream m a -> m ()
credit Credit
1 Stream m (Digit a)
ds m () -> m [Stream m (Digit a)] -> m [Stream m (Digit a)]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m (Digit a)
-> m [Stream m (Digit a)]
-> (Digit a -> Stream m (Digit a) -> m [Stream m (Digit a)])
-> m [Stream m (Digit a)]
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
ds
  ([Stream m (Digit a)] -> m [Stream m (Digit a)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Stream m (Digit a)]
dss)
  (\Digit a
d Stream m (Digit a)
job -> case Digit a
d of
    Digit a
Zero -> [Stream m (Digit a)] -> m [Stream m (Digit a)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stream m (Digit a)] -> m [Stream m (Digit a)])
-> [Stream m (Digit a)] -> m [Stream m (Digit a)]
forall a b. (a -> b) -> a -> b
$ Stream m (Digit a)
jobStream m (Digit a) -> [Stream m (Digit a)] -> [Stream m (Digit a)]
forall a. a -> [a] -> [a]
:[Stream m (Digit a)]
dss
    One Tree a
_ -> [Stream m (Digit a)] -> m [Stream m (Digit a)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Stream m (Digit a)]
dss)

removeMinTree :: MonadCredit m => Ord a => Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
removeMinTree :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
removeMinTree Stream m (Digit a)
ds = Credit -> Stream m (Digit a) -> m ()
forall (m :: * -> *) a.
MonadCredit m =>
Credit -> Stream m a -> m ()
credit Credit
1 Stream m (Digit a)
ds m ()
-> m (Tree a, Stream m (Digit a)) -> m (Tree a, Stream m (Digit a))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m (Digit a)
-> m (Tree a, Stream m (Digit a))
-> (Digit a
    -> Stream m (Digit a) -> m (Tree a, Stream m (Digit a)))
-> m (Tree a, Stream m (Digit a))
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
ds
  (String -> m (Tree a, Stream m (Digit a))
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"removeMinTree: empty stream")
  (\Digit a
d Stream m (Digit a)
ds -> case Digit a
d of
      Digit a
Zero -> do 
        (Tree a
t', Stream m (Digit a)
ds') <- Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
removeMinTree Stream m (Digit a)
ds
        (Tree a, Stream m (Digit a)) -> m (Tree a, Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree a
t', Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
forall a. Digit a
Zero Stream m (Digit a)
ds')
      One (t :: Tree a
t@(Node a
x [Tree a]
_)) -> Credit -> Stream m (Digit a) -> m ()
forall (m :: * -> *) a.
MonadCredit m =>
Credit -> Stream m a -> m ()
credit Credit
1 Stream m (Digit a)
ds m ()
-> m (Tree a, Stream m (Digit a)) -> m (Tree a, Stream m (Digit a))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream m (Digit a)
-> m (Tree a, Stream m (Digit a))
-> (Digit a
    -> Stream m (Digit a) -> m (Tree a, Stream m (Digit a)))
-> m (Tree a, Stream m (Digit a))
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
ds
        ((Tree a, Stream m (Digit a)) -> m (Tree a, Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree a
t, Stream m (Digit a)
forall (m :: * -> *) a. Stream m a
SNil))
        (\Digit a
_ Stream m (Digit a)
_ -> do
          (t' :: Tree a
t'@(Node a
x' [Tree a]
_), Stream m (Digit a)
ds') <- Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
removeMinTree Stream m (Digit a)
ds
          if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x'
            then (Tree a, Stream m (Digit a)) -> m (Tree a, Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree a
t, Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons Digit a
forall a. Digit a
Zero Stream m (Digit a)
ds)
            else (Tree a, Stream m (Digit a)) -> m (Tree a, Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree a
t', Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons (Tree a -> Digit a
forall a. Tree a -> Digit a
One Tree a
t) Stream m (Digit a)
ds')))

revOneStream :: MonadCredit m => [Tree a] -> Stream m (Digit a) -> m (Stream m (Digit a))
revOneStream :: forall (m :: * -> *) a.
MonadCredit m =>
[Tree a] -> Stream m (Digit a) -> m (Stream m (Digit a))
revOneStream [] Stream m (Digit a)
acc = Stream m (Digit a) -> m (Stream m (Digit a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream m (Digit a)
acc
revOneStream (Tree a
t:[Tree a]
ts) Stream m (Digit a)
acc = m ()
forall (m :: * -> *). MonadCount m => m ()
tick m () -> m (Stream m (Digit a)) -> m (Stream m (Digit a))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Tree a] -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
MonadCredit m =>
[Tree a] -> Stream m (Digit a) -> m (Stream m (Digit a))
revOneStream [Tree a]
ts (Digit a -> Stream m (Digit a) -> Stream m (Digit a)
forall (m :: * -> *) a. a -> Stream m a -> Stream m a
SCons (Tree a -> Digit a
forall a. Tree a -> Digit a
One Tree a
t) Stream m (Digit a)
acc)

instance Heap Scheduled where
  empty :: forall (m :: * -> *) a. MonadCredit m => m (Scheduled a m)
empty = Scheduled a m -> m (Scheduled a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scheduled a m -> m (Scheduled a m))
-> Scheduled a m -> m (Scheduled a m)
forall a b. (a -> b) -> a -> b
$ Stream m (Digit a) -> Schedule m a -> Scheduled a m
forall a (m :: * -> *).
Stream m (Digit a) -> Schedule m a -> Scheduled a m
Scheduled Stream m (Digit a)
forall (m :: * -> *) a. Stream m a
SNil []
  insert :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
a -> Scheduled a m -> m (Scheduled a m)
insert a
x (Scheduled Stream m (Digit a)
ds Schedule m a
sched) = do
    Stream m (Digit a)
ds' <- Tree a -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Tree a -> Stream m (Digit a) -> m (Stream m (Digit a))
insTree (a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
x []) Stream m (Digit a)
ds -- 1
    Schedule m a
sched' <- Schedule m a -> m (Schedule m a)
forall (m :: * -> *) a.
MonadCredit m =>
Schedule m a -> m (Schedule m a)
exec (Schedule m a -> m (Schedule m a))
-> m (Schedule m a) -> m (Schedule m a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Schedule m a -> m (Schedule m a)
forall (m :: * -> *) a.
MonadCredit m =>
Schedule m a -> m (Schedule m a)
exec (Stream m (Digit a)
ds'Stream m (Digit a) -> Schedule m a -> Schedule m a
forall a. a -> [a] -> [a]
:Schedule m a
sched) -- 2 + 2
    Scheduled a m -> m (Scheduled a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scheduled a m -> m (Scheduled a m))
-> Scheduled a m -> m (Scheduled a m)
forall a b. (a -> b) -> a -> b
$ Stream m (Digit a) -> Schedule m a -> Scheduled a m
forall a (m :: * -> *).
Stream m (Digit a) -> Schedule m a -> Scheduled a m
Scheduled Stream m (Digit a)
ds' Schedule m a
sched'
  merge :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Scheduled a m -> Scheduled a m -> m (Scheduled a m)
merge (Scheduled Stream m (Digit a)
ds1 Schedule m a
_) (Scheduled Stream m (Digit a)
ds2 Schedule m a
_) = do
    Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Stream m (Digit a))
normalize Stream m (Digit a)
ds1 -- log2 n1
    Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Stream m (Digit a))
normalize Stream m (Digit a)
ds2 -- log2 n2
    Stream m (Digit a)
ds <- Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
mrg Stream m (Digit a)
ds1 Stream m (Digit a)
ds2 -- 5 * log2 (n1 + n2)
    Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Stream m (Digit a))
normalize Stream m (Digit a)
ds -- log2 (n1 + n2)
    Scheduled a m -> m (Scheduled a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scheduled a m -> m (Scheduled a m))
-> Scheduled a m -> m (Scheduled a m)
forall a b. (a -> b) -> a -> b
$ Stream m (Digit a) -> Schedule m a -> Scheduled a m
forall a (m :: * -> *).
Stream m (Digit a) -> Schedule m a -> Scheduled a m
Scheduled Stream m (Digit a)
ds []
  splitMin :: forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Scheduled a m -> m (Maybe (a, Scheduled a m))
splitMin (Scheduled Stream m (Digit a)
ds Schedule m a
sched) = Stream m (Digit a)
-> m (Maybe (a, Scheduled a m))
-> (Digit a -> Stream m (Digit a) -> m (Maybe (a, Scheduled a m)))
-> m (Maybe (a, Scheduled a m))
forall (m :: * -> *) a b.
MonadCredit m =>
Stream m a -> m b -> (a -> Stream m a -> m b) -> m b
smatch Stream m (Digit a)
ds
    (Maybe (a, Scheduled a m) -> m (Maybe (a, Scheduled a m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, Scheduled a m)
forall a. Maybe a
Nothing)
    (\Digit a
_ Stream m (Digit a)
_ -> do
      (Node a
x [Tree a]
c, Stream m (Digit a)
ds') <- Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Tree a, Stream m (Digit a))
removeMinTree Stream m (Digit a)
ds -- 4 * log2 n
      Stream m (Digit a)
c' <- [Tree a] -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
MonadCredit m =>
[Tree a] -> Stream m (Digit a) -> m (Stream m (Digit a))
revOneStream [Tree a]
c Stream m (Digit a)
forall (m :: * -> *) a. Stream m a
SNil -- log2 n
      Stream m (Digit a)
ds'' <- Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> Stream m (Digit a) -> m (Stream m (Digit a))
mrg Stream m (Digit a)
c' Stream m (Digit a)
ds' -- 5 * log2 (n1 + n2)
      Stream m (Digit a) -> m (Stream m (Digit a))
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
Stream m (Digit a) -> m (Stream m (Digit a))
normalize Stream m (Digit a)
ds'' -- log2 (n1 + n2)
      Maybe (a, Scheduled a m) -> m (Maybe (a, Scheduled a m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Scheduled a m) -> Maybe (a, Scheduled a m)
forall a. a -> Maybe a
Just (a
x, Stream m (Digit a) -> Schedule m a -> Scheduled a m
forall a (m :: * -> *).
Stream m (Digit a) -> Schedule m a -> Scheduled a m
Scheduled Stream m (Digit a)
ds'' [])))

instance BoundedHeap Scheduled where
  hcost :: forall a. Size -> HeapOp a -> Credit
hcost Size
_ (Insert a
_) = Credit
5
  hcost Size
n HeapOp a
Merge = Credit
4 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
+ Credit
8 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
* Size -> Credit
log2 Size
n
  hcost Size
n HeapOp a
SplitMin = Credit
1 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
+ Credit
5 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
* Size -> Credit
log2 Size
n Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
+ Credit
6 Credit -> Credit -> Credit
forall a. Num a => a -> a -> a
* Size -> Credit
log2 (Size
2 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
n)

instance MemoryCell m a => MemoryCell m (Tree a) where
  prettyCell :: Tree a -> m Memory
prettyCell (Node a
x [Tree a]
c) = do
    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
x', [Memory] -> Maybe Memory -> Memory
mkMList [Memory]
c' Maybe Memory
forall a. Maybe a
Nothing]

instance MemoryCell m a => MemoryCell m (Digit a) where
  prettyCell :: Digit a -> m Memory
prettyCell Digit a
Zero = 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
"Zero" []
  prettyCell (One Tree a
t) = String -> [Memory] -> Memory
mkMCell String
"One" ([Memory] -> Memory) -> (Memory -> [Memory]) -> Memory -> Memory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Memory -> [Memory] -> [Memory]
forall a. a -> [a] -> [a]
:[]) (Memory -> Memory) -> m Memory -> m Memory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Tree a
t

instance (MonadMemory m, MemoryCell m a) => MemoryCell m (Stream m a) where
  prettyCell :: Stream m a -> m Memory
prettyCell Stream m a
xs = [Memory] -> Maybe Memory -> Memory
mkMList ([Memory] -> Maybe Memory -> Memory)
-> m [Memory] -> m (Maybe Memory -> Memory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stream m a -> m [Memory]
forall {f :: * -> *} {a} {m :: * -> *}.
MemoryCell f a =>
Stream m a -> f [Memory]
toList Stream m a
xs m (Maybe Memory -> Memory) -> m (Maybe Memory) -> m Memory
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stream m a -> m (Maybe Memory)
forall {f :: * -> *} {m :: * -> *} {a}.
MemoryCell f (Thunk m (Lazy m) (Stream m a)) =>
Stream m a -> f (Maybe Memory)
toHole Stream m a
xs
    where
      toList :: Stream m a -> f [Memory]
toList Stream m a
SNil = [Memory] -> f [Memory]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Memory] -> f [Memory]) -> [Memory] -> f [Memory]
forall a b. (a -> b) -> a -> b
$ []
      toList (SCons a
x Stream m a
xs) = (:) (Memory -> [Memory] -> [Memory])
-> f Memory -> f ([Memory] -> [Memory])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell a
x f ([Memory] -> [Memory]) -> f [Memory] -> f [Memory]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stream m a -> f [Memory]
toList Stream m a
xs
      toList (SIndirect Thunk m (Lazy m) (Stream m a)
t) = [Memory] -> f [Memory]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Memory] -> f [Memory]) -> [Memory] -> f [Memory]
forall a b. (a -> b) -> a -> b
$ []

      toHole :: Stream m a -> f (Maybe Memory)
toHole Stream m a
SNil = Maybe Memory -> f (Maybe Memory)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Memory -> f (Maybe Memory))
-> Maybe Memory -> f (Maybe Memory)
forall a b. (a -> b) -> a -> b
$ Maybe Memory
forall a. Maybe a
Nothing
      toHole (SCons a
x Stream m a
xs) = Stream m a -> f (Maybe Memory)
toHole Stream m a
xs
      toHole (SIndirect Thunk m (Lazy m) (Stream m a)
t) = Memory -> Maybe Memory
forall a. a -> Maybe a
Just (Memory -> Maybe Memory) -> f Memory -> f (Maybe Memory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Thunk m (Lazy m) (Stream m a) -> f Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Thunk m (Lazy m) (Stream m a)
t

instance (MonadMemory m, MemoryCell m a) => MemoryCell m (Scheduled a m) where
  prettyCell :: Scheduled a m -> m Memory
prettyCell (Scheduled Stream m (Digit a)
ds Schedule m a
sched) = do
    Memory
ds' <- Stream m (Digit a) -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Stream m (Digit a)
ds
    [Memory]
sched' <- (Stream m (Digit a) -> m Memory) -> Schedule m 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 Stream m (Digit a) -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell Schedule m a
sched
    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
"Scheduled" [Memory
ds', [Memory] -> Maybe Memory -> Memory
mkMList [Memory]
sched' Maybe Memory
forall a. Maybe a
Nothing]

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