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

module Pandora.Paradigm.Inventory (module Exports, zoom, magnify, (=<>), (~<>), adjust) where

import Pandora.Paradigm.Inventory.Optics as Exports
import Pandora.Paradigm.Inventory.Store as Exports
import Pandora.Paradigm.Inventory.State as Exports
import Pandora.Paradigm.Inventory.Imprint as Exports
import Pandora.Paradigm.Inventory.Equipment as Exports
import Pandora.Paradigm.Inventory.Environment as Exports
import Pandora.Paradigm.Inventory.Accumulator as Exports

import Pandora.Core.Functor (type (~>))
import Pandora.Pattern.Semigroupoid ((.))
import Pandora.Pattern.Category (($), (#), identity)
import Pandora.Pattern.Functor.Adjoint (Adjoint ((-|), (|-)))
import Pandora.Pattern.Functor.Bivariant ((<->))
import Pandora.Paradigm.Primary.Algebraic.Product ((:*:) ((:*:)))
import Pandora.Paradigm.Primary.Algebraic.Exponential ((!.), (%))
import Pandora.Paradigm.Primary.Algebraic (extract)
import Pandora.Paradigm.Primary.Functor.Identity (Identity (Identity))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (run)
import Pandora.Paradigm.Controlflow.Effect.Adaptable (adapt)
import Pandora.Paradigm.Structure.Ability.Accessible (Accessible (access))

instance Adjoint (->) (->) (Store s) (State s) where
	(-|) :: (Store s a -> b) -> a -> State s b
	Store s a -> b
f -| :: (Store s a -> b) -> a -> State s b
-| 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)
$ \s
s -> s -> b -> s :*: b
forall s a. s -> a -> s :*: a
(:*:) s
s (b -> s :*: b)
-> ((s :*: (s -> a)) -> b) -> (s :*: (s -> a)) -> s :*: b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. Store s a -> b
f (Store s a -> b)
-> ((s :*: (s -> a)) -> Store s a) -> (s :*: (s -> a)) -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (s :*: (s -> a)) -> Store s a
forall s a. (((:*:) s :. (->) s) := a) -> Store s a
Store ((s :*: (s -> a)) -> s :*: b) -> (s :*: (s -> a)) -> s :*: b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ s
s s -> (s -> a) -> s :*: (s -> a)
forall s a. s -> a -> s :*: a
:*: (a
x a -> s -> a
forall a b. a -> b -> a
!.)
	(|-) :: (a -> State s b) -> Store s a -> b
	a -> State s b
g |- :: (a -> State s b) -> Store s a -> b
|- Store (s
s :*: s -> a
f) = (s :*: b) -> b
forall (t :: * -> *) a. Extractable t => t a -> a
extract ((s :*: b) -> b) -> (a -> s :*: b) -> a -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (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)
-> s -> State s b -> s :*: b
forall a b c. (a -> b -> c) -> b -> a -> c
% s
s) (State s b -> s :*: b) -> (a -> State s b) -> a -> s :*: b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. a -> State s b
g (a -> b) -> a -> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ s -> a
f s
s

instance Adjoint (->) (->) (Accumulator e) (Imprint e) where
	Accumulator e a -> b
f -| :: (Accumulator e a -> b) -> a -> Imprint e b
-| a
x = (e -> b) -> Imprint e b
forall e a. (e -> a) -> Imprint e a
Imprint ((e -> b) -> Imprint e b) -> (e -> b) -> Imprint e b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ Accumulator e a -> b
f (Accumulator e a -> b)
-> ((e :*: a) -> Accumulator e a) -> (e :*: a) -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (e :*: a) -> Accumulator e a
forall e a. (e :*: a) -> Accumulator e a
Accumulator ((e :*: a) -> b) -> a -> e -> b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
Adjoint source target t u =>
source (t a) b -> target a (u b)
-| a
x
	a -> Imprint e b
g |- :: (a -> Imprint e b) -> Accumulator e a -> b
|- Accumulator e a
x = Imprint e b -> e -> b
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run (Imprint e b -> e -> b) -> (a -> Imprint e b) -> a -> e -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. a -> Imprint e b
g (a -> e -> b) -> (e :*: a) -> b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
Adjoint source target t u =>
target a (u b) -> source (t a) b
|- Accumulator e a -> e :*: a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run Accumulator e a
x

instance Adjoint (->) (->) (Equipment e) (Environment e) where
	Equipment e a -> b
f -| :: (Equipment e a -> b) -> a -> Environment e b
-| a
x = (e -> b) -> Environment e b
forall e a. (e -> a) -> Environment e a
Environment ((e -> b) -> Environment e b) -> (e -> b) -> Environment e b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ Equipment e a -> b
f (Equipment e a -> b)
-> ((e :*: a) -> Equipment e a) -> (e :*: a) -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (e :*: a) -> Equipment e a
forall e a. (e :*: a) -> Equipment e a
Equipment ((e :*: a) -> b) -> a -> e -> b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
Adjoint source target t u =>
source (t a) b -> target a (u b)
-| a
x
	a -> Environment e b
g |- :: (a -> Environment e b) -> Equipment e a -> b
|- Equipment e a
x = Environment e b -> e -> b
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run (Environment e b -> e -> b)
-> (a -> Environment e b) -> a -> e -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. a -> Environment e b
g (a -> e -> b) -> (e :*: a) -> b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
Adjoint source target t u =>
target a (u b) -> source (t a) b
|- Equipment e a -> e :*: a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run Equipment e a
x

zoom :: Stateful bg t => Lens Identity bg ls -> State ls ~> t
zoom :: Lens Identity bg ls -> State ls ~> t
zoom Lens Identity bg ls
lens State ls a
less = let restruct :: (Identity ls -> bg) -> Identity ls -> bg :*: a
restruct Identity ls -> bg
to = (Identity ls -> bg
to (Identity ls -> bg) -> (ls -> Identity ls) -> ls -> bg
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. ls -> Identity ls
forall a. a -> Identity a
Identity (ls -> bg) -> (a -> a) -> (ls :*: a) -> bg :*: a
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)
<-> forall a. Category (->) => a -> a
forall (m :: * -> * -> *) a. Category m => m a a
identity @(->)) ((ls :*: a) -> bg :*: a)
-> (Identity ls -> ls :*: a) -> Identity ls -> bg :*: a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. State ls a -> ((->) ls :. (:*:) ls) := a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run State ls a
less (((->) ls :. (:*:) ls) := a)
-> (Identity ls -> ls) -> Identity ls -> ls :*: a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. forall a. Extractable Identity => Identity a -> a
forall (t :: * -> *) a. Extractable t => t a -> a
extract @Identity
	in State bg a -> t a
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt (State bg a -> t a)
-> ((bg -> bg :*: a) -> State bg a) -> (bg -> bg :*: a) -> t a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (bg -> bg :*: a) -> State bg a
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((bg -> bg :*: a) -> t a) -> (bg -> bg :*: a) -> t a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ ((Identity ls -> bg) -> Identity ls -> bg :*: a
restruct ((Identity ls -> bg) -> Identity ls -> bg :*: a)
-> (Identity ls :*: (Identity ls -> bg)) -> bg :*: a
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
Adjoint source target t u =>
target a (u b) -> source (t a) b
|-) ((Identity ls :*: (Identity ls -> bg)) -> bg :*: a)
-> (bg -> Identity ls :*: (Identity ls -> bg)) -> bg -> bg :*: a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. Store (Identity ls) bg -> Identity ls :*: (Identity ls -> bg)
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run (Store (Identity ls) bg -> Identity ls :*: (Identity ls -> bg))
-> (bg -> Store (Identity ls) bg)
-> bg
-> Identity ls :*: (Identity ls -> bg)
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. Lens Identity bg ls -> bg -> Store (Identity ls) bg
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
m (t a) (Primary t a)
run Lens Identity bg ls
lens

(=<>) :: Stateful src t => Lens mode src tgt -> mode tgt -> t src
Lens mode src tgt
lens =<> :: Lens mode src tgt -> mode tgt -> t src
=<> mode tgt
new = (src -> src) -> t src
forall s (t :: * -> *). Stateful s t => (s -> s) -> t s
modify ((src -> src) -> t src) -> (src -> src) -> t src
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ Lens mode src tgt -> mode tgt -> src -> src
forall (available :: * -> *) source target.
Lens available source target
-> available target -> source -> source
set Lens mode src tgt
lens mode tgt
new

(~<>) :: Stateful src t => Lens mode src tgt -> (mode tgt -> mode tgt) -> t src
Lens mode src tgt
lens ~<> :: Lens mode src tgt -> (mode tgt -> mode tgt) -> t src
~<> mode tgt -> mode tgt
f = (src -> src) -> t src
forall s (t :: * -> *). Stateful s t => (s -> s) -> t s
modify ((src -> src) -> t src) -> (src -> src) -> t src
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ Lens mode src tgt -> (mode tgt -> mode tgt) -> src -> src
forall (available :: * -> *) source target.
Lens available source target
-> (available target -> available target) -> source -> source
over Lens mode src tgt
lens mode tgt -> mode tgt
f

magnify :: forall bg ls t . (Accessible ls bg, Stateful bg t) => t ls
magnify :: t ls
magnify = forall bg (t :: * -> *) ls.
Stateful bg t =>
Lens Identity bg ls -> State ls ~> t
forall (t :: * -> *) ls.
Stateful bg t =>
Lens Identity bg ls -> State ls ~> t
zoom @bg (Lens Identity bg ls -> State ls ls -> t ls)
-> Lens Identity bg ls -> State ls ls -> t ls
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# Accessible ls bg => Lens Identity bg ls
forall target source.
Accessible target source =>
Lens Identity source target
access @ls @bg (State ls ls -> t ls) -> State ls ls -> t ls
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# State ls ls
forall s (t :: * -> *). Stateful s t => t s
current

adjust :: forall bg ls t . (Accessible ls bg, Stateful bg t) => (ls -> ls) -> t ls
adjust :: (ls -> ls) -> t ls
adjust = Lens Identity bg ls -> State ls ~> t
forall bg (t :: * -> *) ls.
Stateful bg t =>
Lens Identity bg ls -> State ls ~> t
zoom @bg (Accessible ls bg => Lens Identity bg ls
forall target source.
Accessible target source =>
Lens Identity source target
access @ls @bg) (State ls ls -> t ls)
-> ((ls -> ls) -> State ls ls) -> (ls -> ls) -> t ls
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (ls -> ls) -> State ls ls
forall s (t :: * -> *). Stateful s t => (s -> s) -> t s
modify