{-# LANGUAGE AllowAmbiguousTypes, TypeApplications #-}

module Test.Credit.Sortable.Base where

import Control.Monad.Credit
import Test.Credit
import Test.QuickCheck

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

instance Arbitrary a => Arbitrary (SortableOp a) where
  arbitrary :: Gen (SortableOp a)
arbitrary = [(Int, Gen (SortableOp a))] -> Gen (SortableOp a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
9, a -> SortableOp a
forall a. a -> SortableOp a
Add (a -> SortableOp a) -> Gen a -> Gen (SortableOp a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary)
    , (Int
1, SortableOp a -> Gen (SortableOp a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SortableOp a
forall a. SortableOp a
Sort)
    ]

class Sortable q where
  empty :: MonadCredit m => m (q a m)
  add :: MonadCredit m => Ord a => a -> q a m -> m (q a m)
  sort :: MonadCredit m => Ord a => q a m -> m [a] 

class Sortable q => BoundedSortable q where
  scost :: Size -> SortableOp a -> Credit

data S q a m = E | S Size (q (PrettyCell a) m)

instance (MemoryCell m (q (PrettyCell a) m)) => MemoryCell m (S q a m) where
  prettyCell :: S q a m -> m Memory
prettyCell S q a m
E = 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
"" []
  prettyCell (S Size
_ q (PrettyCell a) m
q) = q (PrettyCell a) m -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell q (PrettyCell a) m
q

instance (MemoryStructure (q (PrettyCell a))) => MemoryStructure (S q a) where
  prettyStructure :: forall (m :: * -> *). MonadMemory m => S q a m -> m Memory
prettyStructure S q a m
E = 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
"" []
  prettyStructure (S Size
sz q (PrettyCell a) m
q) = q (PrettyCell a) m -> m Memory
forall (m :: * -> *).
MonadMemory m =>
q (PrettyCell a) m -> m Memory
forall (t :: (* -> *) -> *) (m :: * -> *).
(MemoryStructure t, MonadMemory m) =>
t m -> m Memory
prettyStructure q (PrettyCell a) m
q

act :: (MonadCredit m, Sortable q, Ord a) => Size -> q (PrettyCell a) m -> SortableOp a -> m (S q a m)
act :: forall (m :: * -> *) (q :: * -> (* -> *) -> *) a.
(MonadCredit m, Sortable q, Ord a) =>
Size -> q (PrettyCell a) m -> SortableOp a -> m (S q a m)
act Size
sz q (PrettyCell a) m
q (Add a
x) = Size -> q (PrettyCell a) m -> S q a m
forall {k} (q :: * -> k -> *) a (m :: k).
Size -> q (PrettyCell a) m -> S q a m
S (Size
sz Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) (q (PrettyCell a) m -> S q a m)
-> m (q (PrettyCell a) m) -> m (S q a m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrettyCell a -> q (PrettyCell a) m -> m (q (PrettyCell a) m)
forall (m :: * -> *) a.
(MonadCredit m, Ord a) =>
a -> q a m -> m (q a m)
forall (q :: * -> (* -> *) -> *) (m :: * -> *) a.
(Sortable q, MonadCredit m, Ord a) =>
a -> q a m -> m (q a m)
add (a -> PrettyCell a
forall a. a -> PrettyCell a
PrettyCell a
x) q (PrettyCell a) m
q
act Size
sz q (PrettyCell a) m
q SortableOp a
Sort = do
  [PrettyCell a]
xs <- q (PrettyCell a) m -> m [PrettyCell a]
forall (m :: * -> *) a. (MonadCredit m, Ord a) => q a m -> m [a]
forall (q :: * -> (* -> *) -> *) (m :: * -> *) a.
(Sortable q, MonadCredit m, Ord a) =>
q a m -> m [a]
sort q (PrettyCell a) m
q
  S q a m -> m (S q a m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (S q a m -> m (S q a m)) -> S q a m -> m (S q a m)
forall a b. (a -> b) -> a -> b
$ Size -> q (PrettyCell a) m -> S q a m
forall {k} (q :: * -> k -> *) a (m :: k).
Size -> q (PrettyCell a) m -> S q a m
S Size
sz q (PrettyCell a) m
q

instance (Arbitrary a, Ord a, BoundedSortable q, Show a) => DataStructure (S q a) (SortableOp a) where
  create :: forall (m :: * -> *). MonadInherit m => S q a m
create = S q a m
forall {k} (q :: * -> k -> *) a (m :: k). S q a m
E
  action :: forall (m :: * -> *).
MonadInherit m =>
S q a m -> SortableOp a -> (Credit, m (S q a m))
action S q a m
E SortableOp a
op = (forall (q :: * -> (* -> *) -> *) a.
BoundedSortable q =>
Size -> SortableOp a -> Credit
scost @q Size
0 SortableOp a
op, m (q (PrettyCell a) m)
forall (m :: * -> *) a. MonadCredit m => m (q a m)
forall (q :: * -> (* -> *) -> *) (m :: * -> *) a.
(Sortable q, MonadCredit m) =>
m (q a m)
empty m (q (PrettyCell a) m)
-> (q (PrettyCell a) m -> m (S q a m)) -> m (S q a m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (q (PrettyCell a) m -> SortableOp a -> m (S q a m))
-> SortableOp a -> q (PrettyCell a) m -> m (S q a m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Size -> q (PrettyCell a) m -> SortableOp a -> m (S q a m)
forall (m :: * -> *) (q :: * -> (* -> *) -> *) a.
(MonadCredit m, Sortable q, Ord a) =>
Size -> q (PrettyCell a) m -> SortableOp a -> m (S q a m)
act Size
0) SortableOp a
op)
  action (S Size
sz q (PrettyCell a) m
q) SortableOp a
op = (forall (q :: * -> (* -> *) -> *) a.
BoundedSortable q =>
Size -> SortableOp a -> Credit
scost @q Size
sz SortableOp a
op, Size -> q (PrettyCell a) m -> SortableOp a -> m (S q a m)
forall (m :: * -> *) (q :: * -> (* -> *) -> *) a.
(MonadCredit m, Sortable q, Ord a) =>
Size -> q (PrettyCell a) m -> SortableOp a -> m (S q a m)
act Size
sz q (PrettyCell a) m
q SortableOp a
op)