{-# OPTIONS_GHC -fno-warn-orphans #-}

module Pandora.Paradigm.Inventory.State where

import Pandora.Pattern.Morphism.Flip (Flip)
import Pandora.Pattern.Morphism.Straight (Straight (Straight))
import Pandora.Core.Functor (type (:.), type (:=))
import Pandora.Pattern.Semigroupoid ((.))
import Pandora.Pattern.Category (identity, ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Invariant (Invariant ((<$<)))
import Pandora.Pattern.Functor.Semimonoidal (Semimonoidal (mult))
import Pandora.Pattern.Functor.Monoidal (Monoidal (unit))
import Pandora.Pattern.Functor.Traversable (Traversable ((<<-)))
import Pandora.Pattern.Functor.Bindable (Bindable ((=<<)))
import Pandora.Pattern.Functor.Monad (Monad)
import Pandora.Pattern.Functor.Adjoint ((-|), (|-))
import Pandora.Pattern.Functor.Bivariant ((<->))
import Pandora.Pattern.Functor.Divariant ((>->))
import Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable (adapt))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Interpreted (Primary, run, unite, (||=)), Schematic)
import Pandora.Paradigm.Controlflow.Effect.Transformer.Monadic (Monadic (wrap), (:>) (TM))
import Pandora.Paradigm.Schemes.TUT (TUT (TUT), type (<:<.>:>))
import Pandora.Paradigm.Primary.Algebraic.Exponential (type (-->))
import Pandora.Paradigm.Primary.Algebraic ((:*:) ((:*:)), (*>-), delta)
import Pandora.Paradigm.Primary.Algebraic.One (One (One))
import Pandora.Paradigm.Primary.Algebraic (Pointable, point)

-- | Effectful computation with a variable
newtype State s a = State ((->) s :. (:*:) s := a)

instance Covariant (->) (->) (State s) where
	a -> b
f <$> :: (a -> b) -> State s a -> State s b
<$> State s a
x = (((->) s :. (:*:) s) := b) -> State s b
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((((->) s :. (:*:) s) := b) -> State s b)
-> (((->) s :. (:*:) s) := b) -> State s b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (a -> b) -> (s :*: a) -> s :*: b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
(<$>) a -> b
f ((s :*: a) -> s :*: b)
-> (s -> s :*: a) -> ((->) s :. (:*:) s) := b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. State s a -> s -> s :*: a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run State s a
x

instance Semimonoidal (-->) (:*:) (:*:) (State s) where
	mult :: (State s a :*: State s b) --> State s (a :*: b)
mult = ((State s a :*: State s b) -> State s (a :*: b))
-> (State s a :*: State s b) --> State s (a :*: b)
forall (v :: * -> * -> *) a e. v a e -> Straight v a e
Straight (((State s a :*: State s b) -> State s (a :*: b))
 -> (State s a :*: State s b) --> State s (a :*: b))
-> ((State s a :*: State s b) -> State s (a :*: b))
-> (State s a :*: State s b) --> State s (a :*: b)
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ \(State ((->) s :. (:*:) s) := a
g :*: State ((->) s :. (:*:) s) := b
h) -> (((->) s :. (:*:) s) := (a :*: b)) -> State s (a :*: b)
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((((->) s :. (:*:) s) := (a :*: b)) -> State s (a :*: b))
-> (((->) s :. (:*:) s) := (a :*: b)) -> State s (a :*: b)
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ \s
s ->
		let s
old :*: a
x = ((->) s :. (:*:) s) := a
g s
s in
		let s
new :*: b
y = ((->) s :. (:*:) s) := b
h s
old in
		s
new s -> (a :*: b) -> s :*: (a :*: b)
forall s a. s -> a -> s :*: a
:*: a
x a -> b -> a :*: b
forall s a. s -> a -> s :*: a
:*: b
y

instance Monoidal (-->) (->) (:*:) (:*:) (State s) where
	unit :: Proxy (:*:) -> (Unit (:*:) -> a) --> State s a
unit Proxy (:*:)
_ = ((One -> a) -> State s a) -> Straight (->) (One -> a) (State s a)
forall (v :: * -> * -> *) a e. v a e -> Straight v a e
Straight (((One -> a) -> State s a) -> Straight (->) (One -> a) (State s a))
-> ((One -> a) -> State s a)
-> Straight (->) (One -> a) (State s a)
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (((->) s :. (:*:) s) := a) -> State s a
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((((->) s :. (:*:) s) := a) -> State s a)
-> ((One -> a) -> ((->) s :. (:*:) s) := a)
-> (One -> a)
-> State s a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (forall a. Category (->) => a -> a
forall (m :: * -> * -> *) a. Category m => m a a
identity @(->) ((s :*: a) -> s :*: a) -> a -> ((->) s :. (:*:) s) := a
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
Adjoint source target t u =>
source (t a) b -> target a (u b)
-|) (a -> ((->) s :. (:*:) s) := a)
-> ((One -> a) -> a) -> (One -> a) -> ((->) s :. (:*:) s) := a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. ((One -> a) -> One -> a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ One
One)

instance Bindable (->) (State s) where
	a -> State s b
f =<< :: (a -> State s b) -> State s a -> State s b
=<< State s a
x = (((->) s :. (:*:) s) := b) -> State s b
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((((->) s :. (:*:) s) := b) -> State s b)
-> (((->) s :. (:*:) s) := b) -> State s b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (State s b -> ((->) s :. (:*:) s) := b
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run (State s b -> ((->) s :. (:*:) s) := b)
-> (a -> State s b) -> a -> ((->) s :. (:*:) s) := b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. a -> State s b
f (a -> ((->) s :. (:*:) s) := b) -> (s :*: a) -> s :*: b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
Adjoint source target t u =>
target a (u b) -> source (t a) b
|-) ((s :*: a) -> s :*: b)
-> (s -> s :*: a) -> ((->) s :. (:*:) s) := b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
<$> State s a -> s -> s :*: a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run State s a
x

instance Monad (->) (State s) where

instance Invariant (Flip State r) where
	a -> b
f <$< :: (a -> b) -> (b -> a) -> Flip State r a -> Flip State r b
<$< b -> a
g = ((b -> a
g (b -> a)
-> ((a :*: r) -> b :*: r) -> (a -> a :*: r) -> b -> b :*: r
forall (left :: * -> * -> *) (right :: * -> * -> *)
       (target :: * -> * -> *) (v :: * -> * -> *) a b c d.
Divariant left right target v =>
left a b -> right c d -> target (v b c) (v a d)
>-> ((a -> b) -> (r -> r) -> (a :*: r) -> b :*: r
forall (left :: * -> * -> *) (right :: * -> * -> *)
       (target :: * -> * -> *) (v :: * -> * -> *) a b c d.
Bivariant left right target v =>
left a b -> right c d -> target (v a c) (v b d)
(<->) @_ @(->) @(->) a -> b
f r -> r
forall (m :: * -> * -> *) a. Category m => m a a
identity) (Primary (State a) r -> Primary (State b) r)
-> State a r -> State b r
forall (m :: * -> * -> *) (t :: * -> *) (u :: * -> *) a b.
(Interpreted m t, Semigroupoid m, Interpreted m u) =>
m (Primary t a) (Primary u b) -> m (t a) (u b)
||=) (Primary (Flip State r) a -> Primary (Flip State r) b)
-> Flip State r a -> Flip State r b
forall (m :: * -> * -> *) (t :: * -> *) (u :: * -> *) a b.
(Interpreted m t, Semigroupoid m, Interpreted m u) =>
m (Primary t a) (Primary u b) -> m (t a) (u b)
||=)

instance Interpreted (->) (State s) where
	type Primary (State s) a = (->) s :. (:*:) s := a
	run :: State s a -> Primary (State s) a
run ~(State ((->) s :. (:*:) s) := a
x) = Primary (State s) a
((->) s :. (:*:) s) := a
x
	unite :: Primary (State s) a -> State s a
unite = Primary (State s) a -> State s a
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State

type instance Schematic Monad (State s) = (->) s <:<.>:> (:*:) s

instance Monadic (State s) where
	wrap :: State s ~> (State s :> u)
wrap State s a
x = (<:<.>:>) ((->) s) ((:*:) s) u a -> (:>) (State s) u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM ((<:<.>:>) ((->) s) ((:*:) s) u a -> (:>) (State s) u a)
-> ((((->) s :. (u :. (:*:) s)) := a)
    -> (<:<.>:>) ((->) s) ((:*:) s) u a)
-> (((->) s :. (u :. (:*:) s)) := a)
-> (:>) (State s) u a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (((->) s :. (u :. (:*:) s)) := a)
-> (<:<.>:>) ((->) s) ((:*:) s) u a
forall k k k k k k (ct :: k) (ct' :: k) (cu :: k) (t :: k -> *)
       (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT ct ct' cu t t' u a
TUT ((((->) s :. (u :. (:*:) s)) := a) -> (:>) (State s) u a)
-> (((->) s :. (u :. (:*:) s)) := a) -> (:>) (State s) u a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (s :*: a) -> u (s :*: a)
forall (t :: * -> *) a. Pointable t => a -> t a
point ((s :*: a) -> u (s :*: a))
-> (s -> s :*: a) -> ((->) s :. (u :. (:*:) s)) := a
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
<$> State s a -> s -> s :*: a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run State s a
x

type Stateful s = Adaptable (State s)

-- | Get current value
current :: Stateful s t => t s
current :: t s
current = State s s -> t s
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt (State s s -> t s) -> State s s -> t s
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (((->) s :. (:*:) s) := s) -> State s s
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((->) s :. (:*:) s) := s
forall a. a -> a :*: a
delta

-- | Modify stored value with a function
modify :: Stateful s t => (s -> s) -> t s
modify :: (s -> s) -> t s
modify s -> s
f = State s s -> t s
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt (State s s -> t s)
-> ((s -> s :*: s) -> State s s) -> (s -> s :*: s) -> t s
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (s -> s :*: s) -> State s s
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((s -> s :*: s) -> t s) -> (s -> s :*: s) -> t s
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ \s
s -> let r :: s
r = s -> s
f s
s in s
r s -> s -> s :*: s
forall s a. s -> a -> s :*: a
:*: s
r

-- | Replace current value with another one
replace :: Stateful s t => s -> t s
replace :: s -> t s
replace s
s = State s s -> t s
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt (State s s -> t s)
-> ((s -> s :*: s) -> State s s) -> (s -> s :*: s) -> t s
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (s -> s :*: s) -> State s s
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((s -> s :*: s) -> t s) -> (s -> s :*: s) -> t s
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ \s
_ -> s
s s -> s -> s :*: s
forall s a. s -> a -> s :*: a
:*: s
s

reconcile :: (Bindable (->) t, Stateful s t, Adaptable u t) => (s -> u s) -> t s
reconcile :: (s -> u s) -> t s
reconcile s -> u s
f = s -> t s
forall s (t :: * -> *). Stateful s t => s -> t s
replace (s -> t s) -> t s -> t s
forall (source :: * -> * -> *) (t :: * -> *) a b.
Bindable source t =>
source a (t b) -> source (t a) (t b)
=<< u s -> t s
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt (u s -> t s) -> (s -> u s) -> s -> t s
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. s -> u s
f (s -> t s) -> t s -> t s
forall (source :: * -> * -> *) (t :: * -> *) a b.
Bindable source t =>
source a (t b) -> source (t a) (t b)
=<< t s
forall s (t :: * -> *). Stateful s t => t s
current

type Memorable s t = (Covariant (->) (->) t, Pointable t,  Stateful s t)

fold :: (Traversable (->) (->) t, Memorable s u) => (a -> s -> s) -> t a -> u s
fold :: (a -> s -> s) -> t a -> u s
fold a -> s -> s
op t a
struct = ((s -> s) -> u s
forall s (t :: * -> *). Stateful s t => (s -> s) -> t s
modify ((s -> s) -> u s) -> (a -> s -> s) -> a -> u s
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. a -> s -> s
op (a -> u s) -> t a -> u (t s)
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
(Traversable source target t, Covariant source target u,
 Monoidal (Straight source) target (:*:) (:*:) u) =>
source a (u b) -> target (t a) (u (t b))
<<- t a
struct) u (t s) -> u s -> u s
forall (t :: * -> *) a b.
(Covariant (->) (->) t, Semimonoidal (-->) (:*:) (:*:) t) =>
t a -> t b -> t b
*>- u s
forall s (t :: * -> *). Stateful s t => t s
current