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

module Pandora.Paradigm.Inventory.State where

import Pandora.Core.Functor (type (:.), type (:=))
import Pandora.Pattern.Category (identity, (.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)), Covariant_ ((-<$>-)))
import Pandora.Pattern.Functor.Invariant (Invariant ((<$<)))
import Pandora.Pattern.Functor.Pointable (Pointable (point))
import Pandora.Pattern.Functor.Applicative (Applicative ((<*>)), Semimonoidal (multiply))
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.Primary.Transformer (Flip)
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 ((:*:) ((:*:)), (%), (!.), (-<*>-), delta)

-- | 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 (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
(<$>) a -> b
f ((s :*: a) -> s :*: b)
-> (s -> s :*: a) -> ((->) s :. (:*:) s) := b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. State s a -> Primary (State s) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run State s a
x

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 (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant_ t source target =>
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.
Category m =>
m b c -> m a b -> m a c
. State s a -> Primary (State s) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run State s a
x

instance Applicative (State s) where
	State s (a -> b)
f <*> :: State s (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 (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
(<$>) ((a -> b) -> (s :*: a) -> s :*: b)
-> ((s :*: a) :*: (a -> b)) -> s :*: b
forall (t :: * -> *) (u :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Adjoint t u source target =>
target a (u b) -> source (t a) b
|-) (((s :*: a) :*: (a -> b)) -> s :*: b)
-> (s -> (s :*: a) :*: (a -> b)) -> ((->) s :. (:*:) s) := b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (State s a -> Primary (State s) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run State s a
x (((->) s :. (:*:) s) := a)
-> ((a -> b) -> a -> b)
-> (s :*: (a -> b))
-> (s :*: a) :*: (a -> b)
forall (v :: * -> * -> *) (left :: * -> * -> *)
       (right :: * -> * -> *) (target :: * -> * -> *) a b c d.
Bivariant v left right target =>
left a b -> right c d -> target (v a c) (v b d)
<-> forall a. Category (->) => a -> a
forall (m :: * -> * -> *) a. Category m => m a a
identity @(->)) ((s :*: (a -> b)) -> (s :*: a) :*: (a -> b))
-> (s -> s :*: (a -> b)) -> s -> (s :*: a) :*: (a -> b)
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. State s (a -> b) -> Primary (State s) (a -> b)
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run State s (a -> b)
f

instance Semimonoidal (State s) (:*:) (->) (->) where
	multiply :: ((a :*: b) -> r) -> (State s a :*: State s b) -> State s r
multiply (a :*: b) -> r
f (State ((->) s :. (:*:) s) := a
g :*: State ((->) s :. (:*:) s) := b
h) = (((->) s :. (:*:) s) := r) -> State s r
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((((->) s :. (:*:) s) := r) -> State s r)
-> (((->) s :. (:*:) s) := r) -> State s r
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 -> r -> s :*: r
forall s a. s -> a -> s :*: a
:*: (a :*: b) -> r
f (a
x a -> b -> a :*: b
forall s a. s -> a -> s :*: a
:*: b
y)

instance Pointable (State s) (->) where
	point :: a -> State s a
point = (((->) s :. (:*:) s) := a) -> State s a
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((((->) s :. (:*:) s) := a) -> State s a)
-> (a -> ((->) s :. (:*:) s) := a) -> a -> State s a
forall (m :: * -> * -> *) b c a.
Category 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 (t :: * -> *) (u :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Adjoint t u source target =>
source (t a) b -> target a (u b)
-|)

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 (t :: * -> *) a. Interpreted t => 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.
Category m =>
m b c -> m a b -> m a c
. a -> State s b
f (a -> ((->) s :. (:*:) s) := b) -> (s :*: a) -> s :*: b
forall (t :: * -> *) (u :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Adjoint t u source target =>
target a (u b) -> source (t a) b
|-) ((s :*: a) -> s :*: b)
-> (s -> s :*: a) -> ((->) s :. (:*:) s) := b
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant_ t source target =>
source a b -> target (t a) (t b)
-<$>- State s a -> Primary (State s) a
forall (t :: * -> *) a. Interpreted t => 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 (v :: * -> * -> *) (left :: * -> * -> *)
       (right :: * -> * -> *) (target :: * -> * -> *) a b c d.
Divariant v left right target =>
left a b -> right c d -> target (v b c) (v a d)
>-> ((a -> b) -> (r -> r) -> (a :*: r) -> b :*: r
forall (v :: * -> * -> *) (left :: * -> * -> *)
       (right :: * -> * -> *) (target :: * -> * -> *) a b c d.
Bivariant v left right target =>
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 (t :: * -> *) (u :: * -> *) a b.
(Interpreted t, Interpreted u) =>
(Primary t a -> Primary u b) -> t a -> u b
||=) (Primary (Flip State r) a -> Primary (Flip State r) b)
-> Flip State r a -> Flip State r b
forall (t :: * -> *) (u :: * -> *) a b.
(Interpreted t, Interpreted u) =>
(Primary t a -> Primary u b) -> 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.
Category 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 :: * -> *) (source :: * -> * -> *) a.
Pointable t source =>
source a (t a)
point ((s :*: a) -> (:.) u ((:*:) s) a)
-> (s -> s :*: a) -> s -> (:.) u ((:*:) s) a
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> State s a -> Primary (State s) a
forall (t :: * -> *) a. Interpreted t => 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.
Category 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.
Category 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 (t :: * -> *) (source :: * -> * -> *) a b.
Bindable t source =>
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.
Category m =>
m b c -> m a b -> m a c
. s -> u s
f (s -> t s) -> t s -> t s
forall (t :: * -> *) (source :: * -> * -> *) a b.
Bindable t source =>
source a (t b) -> source (t a) (t b)
=<< t s
forall s (t :: * -> *). Stateful s t => t s
current

type Memorable s t = (Pointable t (->), Semimonoidal 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 -> t s -> s
forall a b. a -> b -> a
(!.) (s -> t s -> s) -> t s -> s -> s
forall a b c. (a -> b -> c) -> b -> a -> c
%) (t s -> s -> s) -> u (t s) -> u (s -> s)
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant_ t source target =>
source a b -> target (t a) (t b)
-<$>- ((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.
Category m =>
m b c -> m a b -> m a c
. a -> s -> s
op (a -> u s) -> t a -> u (t s)
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) (u :: * -> *) a b.
(Traversable t source target, Covariant_ u source target,
 Pointable u target, Semimonoidal u (:*:) source target) =>
source a (u b) -> target (t a) (u (t b))
<<- t a
struct) u (s -> s) -> u s -> u s
forall a b (t :: * -> *).
Semimonoidal t (:*:) (->) (->) =>
t (a -> b) -> t a -> t b
-<*>- u s
forall s (t :: * -> *). Stateful s t => t s
current