module Proton.Grate where

import Data.Profunctor
import Data.Function ((&))
import Data.Functor.Rep
import Proton.Types
import Data.Pair

type Grate s t a b = forall p. Closed p => (p a b) -> (p s t)
type Grate' s a = Grate s s a a

newtype Zipping a b = Zipping (a -> a -> b)

grate :: (((s -> a) -> b) -> t) -> Grate s t a b
grate :: (((s -> a) -> b) -> t) -> Grate s t a b
grate g :: ((s -> a) -> b) -> t
g = (s -> (s -> a) -> a)
-> (((s -> a) -> b) -> t)
-> p ((s -> a) -> a) ((s -> a) -> b)
-> p s t
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> (s -> a) -> a
forall a b. a -> (a -> b) -> b
(&) ((s -> a) -> b) -> t
g (p ((s -> a) -> a) ((s -> a) -> b) -> p s t)
-> (p a b -> p ((s -> a) -> a) ((s -> a) -> b)) -> p a b -> p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p ((s -> a) -> a) ((s -> a) -> b)
forall (p :: * -> * -> *) a b x.
Closed p =>
p a b -> p (x -> a) (x -> b)
closed

distributed :: (Closed p, Representable g) => p a b -> p (g a) (g b)
distributed :: p a b -> p (g a) (g b)
distributed = (g a -> Rep g -> a)
-> ((Rep g -> b) -> g b)
-> p (Rep g -> a) (Rep g -> b)
-> p (g a) (g b)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap g a -> Rep g -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (Rep g -> b) -> g b
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (p (Rep g -> a) (Rep g -> b) -> p (g a) (g b))
-> (p a b -> p (Rep g -> a) (Rep g -> b)) -> p a b -> p (g a) (g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Rep g -> a) (Rep g -> b)
forall (p :: * -> * -> *) a b x.
Closed p =>
p a b -> p (x -> a) (x -> b)
closed

both :: Grate (a, a) (b, b) a b
both :: p a b -> p (a, a) (b, b)
both = p (Pair a) (Pair b) -> p (a, a) (b, b)
forall (p :: * -> * -> *) a b.
Profunctor p =>
p (Pair a) (Pair b) -> p (a, a) (b, b)
paired (p (Pair a) (Pair b) -> p (a, a) (b, b))
-> (p a b -> p (Pair a) (Pair b)) -> p a b -> p (a, a) (b, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Pair a) (Pair b)
forall (p :: * -> * -> *) (g :: * -> *) a b.
(Closed p, Representable g) =>
p a b -> p (g a) (g b)
distributed

zipWithOf :: forall s t a b. Optic (Costar Pair) s t a b -> (a -> a -> b) -> s -> s -> t
zipWithOf :: Optic (Costar Pair) s t a b -> (a -> a -> b) -> s -> s -> t
zipWithOf g :: Optic (Costar Pair) s t a b
g f :: a -> a -> b
f s1 :: s
s1 s2 :: s
s2 = Optic (Costar Pair) s t a b -> (Pair a -> b) -> Pair s -> t
forall (f :: * -> *) s t a b.
Optic (Costar f) s t a b -> (f a -> b) -> f s -> t
zipFWithOf Optic (Costar Pair) s t a b
g ((a -> a -> b) -> Pair a -> b
forall a b. (a -> a -> b) -> Pair a -> b
liftPair a -> a -> b
f) (s -> s -> Pair s
forall a. a -> a -> Pair a
Pair s
s1 s
s2)

-- degrating :: Grate s t a b -> ((s -> a) -> b) -> t
-- degrating g f = undefined

-- Equivalent to `>-` from Algebraic lenses, but with different semantics
zipFWithOf :: forall f s t a b. Optic (Costar f) s t a b -> (f a -> b) -> (f s -> t)
zipFWithOf :: Optic (Costar f) s t a b -> (f a -> b) -> f s -> t
zipFWithOf g :: Optic (Costar f) s t a b
g fab :: f a -> b
fab fs :: f s
fs = f s -> t
grated f s
fs
  where
    grated :: f s -> t
    Costar grated :: f s -> t
grated = Optic (Costar f) s t a b
g ((f a -> b) -> Costar f a b
forall (f :: * -> *) d c. (f d -> c) -> Costar f d c
Costar f a -> b
fab)

-- extendThrough :: forall s t a b w. Comonad w => Grate s t a b -> (w a -> b) -> w s -> w t
-- extendThrough g f = extend (degrated . helper)
--   where
--     helper :: w s -> (s -> a) -> b
--     helper w' sToA = f (sToA <$> w')
--     degrated :: ((s -> a) -> b) -> t
--     degrated = degrating g

-- extendThrough :: forall s t a b w. Comonad w => Grate s t a b -> (w a -> b) -> w s -> w t
-- extendThrough g f = extend (degrated . helper)

-- (-<) :: Comonad w => Grate s t a b -> (w a -> b) -> w s -> w t
-- (-<) = extendThrough