diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,6 @@
+# Changelog for proton
+
+### 0.0.1
+- Initial release
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Chris Penner (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Chris Penner nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,28 @@
+# proton - Profunctor optics
+
+An **extremely experimental** implementation of profunctor optics in Haskell. 
+This mostly exists so I have a place to experiment with new ideas and new optics. Most things should work but I offer no performance guarantees.
+
+Not intended for use in production (yet).
+
+Includes:
+
+* Lenses
+* Prisms
+* Folds
+* Traversals
+* Getters
+* Reviews
+* Setters
+* Isos
+* Algebraic lenses
+* Coalgebraic prisms
+* Achromatic lenses
+* Grids
+* Grates
+* Glass
+* Loops
+* Feedbacks
+* Kaleidoscopes
+
+And always growing!
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/proton.cabal b/proton.cabal
new file mode 100644
--- /dev/null
+++ b/proton.cabal
@@ -0,0 +1,101 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.33.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: de218e5a99e5d137be7685d7249aafd9d954cdc83f2bcdd1366a114fe7791ff2
+
+name:           proton
+version:        0.0.1
+description:    Please see the README on GitHub at <https://github.com/ChrisPenner/proton#readme>
+homepage:       https://github.com/ChrisPenner/proton#readme
+bug-reports:    https://github.com/ChrisPenner/proton/issues
+author:         Chris Penner
+maintainer:     christopher.penner@gmail.com
+copyright:      Chris Penner
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/ChrisPenner/proton
+
+library
+  exposed-modules:
+      Data.Market
+      Data.Pair
+      Data.Profunctor.Annotated
+      Data.Profunctor.Coindexed
+      Data.Profunctor.Depending
+      Data.Profunctor.Distributing
+      Data.Profunctor.DoubleStar
+      Data.Profunctor.Expanding
+      Data.Profunctor.Extraction
+      Data.Profunctor.Indexed
+      Data.Profunctor.MStrong
+      Data.Profunctor.Phantom
+      Data.Profunctor.Reflector
+      Data.Profunctor.Remember
+      Data.Profunctor.Withering
+      Examples.Algebraic
+      Examples.Alt
+      Examples.Coalgebraic
+      Examples.Diffract
+      Examples.Flowers
+      Examples.Glass
+      Examples.Layers
+      Examples.Loop
+      Examples.Scrap
+      Proton
+      Proton.Achromatic
+      Proton.Algebraic
+      Proton.Annotated
+      Proton.Coalgebraic
+      Proton.Coindexed
+      Proton.Diffraction
+      Proton.Feedback
+      Proton.Fold
+      Proton.Getter
+      Proton.Glass
+      Proton.Grate
+      Proton.Grid
+      Proton.Indexed
+      Proton.Internal.Orphans
+      Proton.Iso
+      Proton.Kaleidoscope
+      Proton.Lens
+      Proton.Loop
+      Proton.Miso
+      Proton.Plated
+      Proton.PreGrate
+      Proton.Prisms
+      Proton.Review
+      Proton.Setter
+      Proton.Traversal
+      Proton.Types
+      Proton.Wither
+  other-modules:
+      Paths_proton
+  hs-source-dirs:
+      src
+  default-extensions: FlexibleInstances FlexibleContexts ScopedTypeVariables LambdaCase ViewPatterns TypeApplications TypeOperators DeriveFunctor DeriveTraversable DeriveGeneric DerivingStrategies StandaloneDeriving TemplateHaskell RankNTypes TypeFamilies InstanceSigs
+  ghc-options: -Wall
+  build-depends:
+      adjunctions
+    , base >=4.7 && <5
+    , bifunctors
+    , comonad
+    , compactable
+    , containers
+    , contravariant
+    , distributive
+    , linear
+    , mtl
+    , profunctors >=5.5.1
+    , tagged
+  default-language: Haskell2010
diff --git a/src/Data/Market.hs b/src/Data/Market.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Market.hs
@@ -0,0 +1,19 @@
+module Data.Market where
+
+import Data.Profunctor
+import Data.Bifunctor
+
+-- | The `Market` profunctor characterizes a `Prism`.
+data Market a b s t = Market (b -> t) (s -> Either t a)
+
+instance Functor (Market a b s) where
+  fmap f (Market proj match) = Market (f . proj) (first f . match)
+
+instance Profunctor (Market a b) where
+  dimap f g (Market a b) = Market (g . a) (first g . b . f)
+
+instance Choice (Market a b) where
+  left' (Market x y) =
+    Market (Left . x) (either (first Left . y) (Left . Right))
+  right' (Market x y) =
+    Market (Right . x) (either (Left . Left) (first Right . y))
diff --git a/src/Data/Pair.hs b/src/Data/Pair.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Pair.hs
@@ -0,0 +1,27 @@
+module Data.Pair where
+
+import Data.Functor.Rep
+import Data.Distributive
+import Data.Profunctor
+
+data Pair a = Pair a a
+  deriving (Show, Eq, Ord, Functor)
+
+instance Applicative Pair where
+  pure a = Pair a a
+  Pair f f' <*> Pair a a' = Pair (f a) (f' a')
+
+instance Distributive Pair where
+  distribute = distributeRep
+
+instance Representable Pair where
+  type Rep Pair = Bool
+  tabulate f = Pair (f False) (f True)
+  index (Pair a _) False = a
+  index (Pair _ b) True = b
+
+paired :: Profunctor p => p (Pair a) (Pair b) -> p (a, a) (b, b)
+paired = dimap (\(a, a') -> Pair a a') (\(Pair a a') -> (a, a'))
+
+liftPair :: (a -> a -> b) -> Pair a -> b
+liftPair f (Pair a a') = f a a'
diff --git a/src/Data/Profunctor/Annotated.hs b/src/Data/Profunctor/Annotated.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Annotated.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures #-}
+module Data.Profunctor.Annotated where
+
+import Data.Profunctor
+import Data.Tagged
+
+class (Profunctor p, Profunctor q) => Annotatable e p q | q -> p where
+    coindexed :: p a (e, b) -> q a b
+    default coindexed :: (p ~ q) => p a (e, b) -> q a b
+    coindexed = rmap snd
+
+data Annotated e p a b = Annotated {runCoindexed :: (p a (e, b))}
+
+instance Profunctor p => Profunctor (Annotated e p) where
+  dimap f g (Annotated p) = Annotated (dimap f (second' g) p)
+
+instance Strong p => Strong (Annotated i p) where
+  second' (Annotated p) = Annotated (dimap id reassoc $ second' p)
+    where
+      reassoc (c, (i, b)) = (i, (c, b))
+
+instance Profunctor p => Annotatable i p (Annotated i p) where
+  coindexed p = Annotated p
+
+instance Annotatable e (Forget r) (Forget r) where
+  coindexed (Forget f) = (Forget f)
+
+instance Annotatable e (->) (->) where
+instance Functor f => Annotatable e (Star f) (Star f) where
+instance Functor f => Annotatable e (Costar f) (Costar f) where
+instance Annotatable e Tagged Tagged where
diff --git a/src/Data/Profunctor/Coindexed.hs b/src/Data/Profunctor/Coindexed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Coindexed.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures #-}
+module Data.Profunctor.Coindexed where
+
+import Data.Profunctor
+import Data.Void
+import Control.Applicative
+import Control.Monad
+import Data.Tagged
+
+class (Profunctor p, Profunctor q) => Coindexable e p q | q -> p where
+    coindexed :: p a (Either e b) -> q a b
+    default coindexed :: (e ~ Void, p ~ q) => p a (Either e b) -> q a b
+    coindexed = rmap (either absurd id)
+
+data Coindexed e p a b = Coindexed {runCoindexed :: (p a (Either e b))}
+
+instance Profunctor p => Profunctor (Coindexed e p) where
+  dimap f g (Coindexed p) = Coindexed (dimap f (right' g) p)
+
+instance Choice p => Choice (Coindexed i p) where
+  right' (Coindexed p) = Coindexed (dimap id reassoc $ right' p)
+    where
+      reassoc (Left c) = Right (Left c)
+      reassoc (Right (Left i)) = Left i
+      reassoc (Right (Right b)) = Right (Right b)
+
+instance Profunctor p => Coindexable i p (Coindexed i p) where
+  coindexed p = Coindexed p
+
+instance Coindexable e (Forget r) (Forget r) where
+  coindexed (Forget f) = (Forget f)
+
+instance Coindexable Void (->) (->)
+
+instance {-# OVERLAPPING #-} Functor f => Coindexable Void (Star f) (Star f) where
+-- Could use selective applicative here instead.
+instance (Alternative f, Monad f) => Coindexable e (Star f) (Star f) where
+  coindexed (Star f) = Star $ f >=> either (const empty) pure
+instance Functor f => Coindexable Void (Costar f) (Costar f) where
+instance Coindexable Void Tagged Tagged where
diff --git a/src/Data/Profunctor/Depending.hs b/src/Data/Profunctor/Depending.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Depending.hs
@@ -0,0 +1,10 @@
+module Data.Profunctor.Depending where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+
+class Traversing p => Depending p where
+  depend :: (forall f. Monad f => (a -> f b) -> (s -> f t)) -> p a b -> p s t
+
+instance Monad f => Depending (Star f) where
+  depend f (Star amb) = Star (f amb)
diff --git a/src/Data/Profunctor/Distributing.hs b/src/Data/Profunctor/Distributing.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Distributing.hs
@@ -0,0 +1,7 @@
+module Data.Profunctor.Distributing where
+
+import Data.Profunctor
+import Data.Functor.Rep
+
+distribute' :: (Closed p, Representable g) => p a b -> p (g a) (g b)
+distribute' = dimap index tabulate . closed
diff --git a/src/Data/Profunctor/DoubleStar.hs b/src/Data/Profunctor/DoubleStar.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/DoubleStar.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE InstanceSigs #-}
+module Data.Profunctor.DoubleStar where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Data.Profunctor.MStrong
+import Data.Distributive
+
+data DoubleStar f g a b = DoubleStar (f a -> g b)
+
+instance (Functor f, Functor g) => Profunctor (DoubleStar f g) where
+  dimap l r (DoubleStar p) = DoubleStar (dimap (fmap l) (fmap r) p)
+
+instance (Traversable f, Distributive g) => MStrong (DoubleStar f g) where
+  msecond' :: forall m a b. Monoid m => DoubleStar f g a b -> DoubleStar f g (m, a) (m, b)
+  msecond' (DoubleStar p) = DoubleStar (go p)
+    where
+      go :: (f a -> g b) -> f (m, a) -> g (m, b)
+      go f fam = distribute . fmap f . sequenceA $ fam
+
+
+instance (Traversable f, Distributive g) => Choice (DoubleStar f g) where
+  right' :: forall c a b. DoubleStar f g a b -> DoubleStar f g (Either c a) (Either c b)
+  right' (DoubleStar p) = DoubleStar go
+    where
+      go :: f (Either c a) -> g (Either c b)
+      go = distribute . fmap p . sequenceA
+
+-- instance (Functor f, Applicative g) => Traversing (DoubleStar f g) where
+--   -- traverse' :: Traversable t => p a b -> p (t a) (t b)
+--   -- traverse' (DoubleStar p) = DoubleStar (traverse m)
+--   wander :: forall s t a b h. Applicative h =>( (a -> h b) -> s -> h t) -> DoubleStar f g a b -> DoubleStar f g s t
+--   wander f (DoubleStar p) = DoubleStar go
+--     where
+--       go :: f s -> g t
+--       go fs = _ . fmap (f _p') $ fs
+
diff --git a/src/Data/Profunctor/Expanding.hs b/src/Data/Profunctor/Expanding.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Expanding.hs
@@ -0,0 +1,28 @@
+module Data.Profunctor.Expanding where
+
+import Data.Profunctor
+import Control.Comonad
+
+class Profunctor p => Expanding p where
+  expand :: Comonad w => p (w a) b -> p a (w b)
+  -- expand :: Applicative f => p (f a) (f b) -> p a b
+
+-- instance Expanding (->) where
+--   expand f = _ f
+
+-- instance Expanding (Forget r) where
+--   expand (Forget rToA) = Forget (rToA . pure)
+
+-- instance Expanding (Forget r) where
+--   expand (Forget rToA) = Forget (_ rToA)
+
+
+-- instance Functor g => Expanding (Star g) where
+--   expand (Star f) = Star (_ f)
+
+-- instance Functor g => Expanding (Costar g) where
+--   expand (Costar f) = Costar (_ f)
+
+
+-- extending :: (Comonad w) => Optic (Costar w) a (w b) a b
+-- extending (Costar f) = Costar (extend f)
diff --git a/src/Data/Profunctor/Extraction.hs b/src/Data/Profunctor/Extraction.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Extraction.hs
@@ -0,0 +1,62 @@
+module Data.Profunctor.Extraction where
+
+import Data.Profunctor
+import Control.Comonad
+import Data.Distributive
+import qualified Data.List.NonEmpty as NE
+import Control.Comonad.Store
+import Data.Pair
+
+class Profunctor p => Extraction p where
+  extractions :: Comonad w => p (w a) b -> p (w a) (w b)
+
+instance Extraction (Forget r) where
+  extractions (Forget f) = Forget f
+
+instance Extraction (->) where
+  extractions f = extend f
+
+instance Distributive f => Extraction (Star f) where
+  extractions (Star f) = Star (distribute . extend f)
+
+act :: (Star f a b -> Star f s t) -> (a -> f b) -> s -> f t
+act o f = runStar (o (Star f))
+
+t :: (NE.NonEmpty a) -> Pair (Maybe a)
+t (a NE.:| (b : _)) = Pair (Just a) (Just b)
+t (a NE.:| _) = Pair (Just a) Nothing
+
+u :: (NE.NonEmpty Int) -> Pair Int
+u xs = Pair (sum xs) (NE.length xs)
+
+
+
+
+-- thingy :: forall w a b. Comonad w => (a -> w (Either a b)) -> (w a -> w b)
+-- thingy f = extend loop . fmap Left
+--     where
+--       loop :: w (Either a b) -> b
+--       loop w = case extract w of
+--           Left a' -> loop $ f a'
+--           Right b -> b
+
+home :: Int -> Store Int Int -> Either Int Int
+home n s | extract s == n = Left $ pos s
+  | abs (peeks (+1) s - n) < abs (peeks (subtract 1) s - n) = Right $ peeks (+1) s
+  | otherwise = Right $ peeks (subtract 1) s
+
+looper :: NE.NonEmpty Int -> Either [Int] Int
+looper xs | sum xs > 10 = Left (NE.toList xs)
+  | otherwise = Right $ (sum xs + 1)
+
+coiterate :: forall w a b.
+         (Traversable w, Comonad w)
+         => (w a -> Either b a)
+         -> (w a -> w b)
+coiterate f = extend loop
+    where
+      loop :: w a -> b
+      loop = either id loop . sequenceA . extend f
+
+-- thingy :: (Choice p, Cochoice p) => p a (Either b a) -> p (w a) (w b)
+-- thingy = _ . unright . _ . right'
diff --git a/src/Data/Profunctor/Indexed.hs b/src/Data/Profunctor/Indexed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Indexed.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures #-}
+module Data.Profunctor.Indexed where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Data.Tagged
+
+class (Profunctor p, Profunctor q) => Indexable i p q | p -> q where
+    indexed :: p a b -> q (i, a) b
+    default indexed :: (p ~ q) => p a b -> q (i, a) b
+    indexed = lmap snd
+
+-- closeIndex :: (Closed q, Indexable i p q) => p a b -> q a (i -> b)
+-- closeIndex = lmap (flip (,)) . closed  . indexed
+
+data Indexed i p a b = Indexed (p (i, a) b)
+newtype UnIndexed i p a b = UnIndexed (p a b)
+  deriving newtype (Profunctor, Closed, Strong, Choice, Traversing, Cochoice, Costrong)
+
+instance Profunctor p => Profunctor (Indexed i p) where
+  dimap f g (Indexed p) = Indexed (dimap (second' f) g p)
+
+instance Strong p => Strong (Indexed i p) where
+  second' (Indexed p) = Indexed (dimap reassoc id $ second' p)
+    where
+      reassoc (i, (c, a)) = (c, (i, a))
+
+instance Profunctor p => Indexable i (Indexed i p) p where
+  indexed (Indexed p) = p
+
+instance Profunctor p => Indexable i (UnIndexed i p) p where
+  indexed (UnIndexed p) = lmap snd p
+
+instance Indexable i (Forget r) (Forget r) where
+instance Functor f => Indexable i (Star f) (Star f) where
+instance Functor f => Indexable i (Costar f) (Costar f) where
+instance Indexable i (->) (->) where
+instance Indexable i Tagged Tagged where
diff --git a/src/Data/Profunctor/MStrong.hs b/src/Data/Profunctor/MStrong.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/MStrong.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Data.Profunctor.MStrong where
+
+import Data.Profunctor
+import Data.Tagged
+import Data.Tuple
+
+class Profunctor p => MStrong p where
+  mfirst' ::  Monoid m => p a b -> p (a, m) (b, m)
+  mfirst' = dimap swap swap . msecond'
+  msecond' ::  Monoid m => p a b -> p (m, a) (m, b)
+  msecond' = dimap swap swap . mfirst'
+
+  {-# MINIMAL mfirst' | msecond' #-}
+
+instance MStrong (Forget r) where
+  msecond' = second'
+
+instance MStrong (->) where
+  msecond' = second'
+
+instance Functor f => MStrong (Star f) where
+  msecond'  = second'
+
+instance MStrong Tagged where
+  msecond' (Tagged b) = Tagged (mempty, b)
+
+instance Traversable f => MStrong (Costar f) where
+  msecond' (Costar f) = Costar go
+    where
+      go fma = f <$> sequenceA fma
+
diff --git a/src/Data/Profunctor/Phantom.hs b/src/Data/Profunctor/Phantom.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Phantom.hs
@@ -0,0 +1,17 @@
+module Data.Profunctor.Phantom where
+
+import Data.Profunctor
+import qualified Data.Functor.Contravariant as C
+import Data.Profunctor.Cayley
+
+class Profunctor p => Phantom p where
+    phantom :: p a x -> p a y
+
+instance Phantom (Forget r) where
+  phantom (Forget f) = Forget f
+
+instance (Functor f, C.Contravariant f) => Phantom (Star f) where
+  phantom (Star f) = Star (C.phantom . f)
+
+instance (Functor f, Phantom p) => Phantom (Cayley f p) where
+  phantom (Cayley fpab) = Cayley (fmap phantom fpab)
diff --git a/src/Data/Profunctor/Reflector.hs b/src/Data/Profunctor/Reflector.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Reflector.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Data.Profunctor.Reflector where
+
+import Data.Tagged
+
+import Data.Profunctor
+import Data.Profunctor.MStrong
+import Data.Distributive
+
+class MStrong p => Reflector p where
+  reflected :: Applicative f => p a b -> p (f a) (f b)
+
+instance Reflector (->) where
+  reflected = fmap
+
+instance Traversable f => Reflector (Costar f) where
+  reflected (Costar f) = Costar (fmap f . sequenceA)
+
+instance Reflector Tagged where
+  reflected (Tagged b) = Tagged (pure b)
+
+instance Distributive f => Reflector (Star f) where
+  reflected (Star f) = Star (collect f)
+
+-- instance (MStrong p, Corepresentable p, Traversable f, Corep p ~ f) => Reflector p where
+--   reflected p = cotabulate . go $ cosieve p
+--     where
+--       go :: forall g a b. Applicative g => (f a -> b) -> f (g a) -> (g b)
+--       go f fga = f <$> sequenceA fga
diff --git a/src/Data/Profunctor/Remember.hs b/src/Data/Profunctor/Remember.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Remember.hs
@@ -0,0 +1,18 @@
+module Data.Profunctor.Remember where
+
+import Data.Profunctor
+
+newtype Remember r a b = Remember (r -> b)
+  deriving Functor
+
+instance Profunctor (Remember r) where
+  dimap _ g (Remember x) = Remember (g . x)
+
+instance Choice (Remember r) where
+  left' (Remember x) = Remember (Left . x)
+
+instance Closed (Remember r) where
+  closed (Remember x) = Remember (\r _ -> x r)
+
+instance Costrong (Remember r) where
+  unfirst (Remember x) = Remember (fst . x)
diff --git a/src/Data/Profunctor/Withering.hs b/src/Data/Profunctor/Withering.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Profunctor/Withering.hs
@@ -0,0 +1,40 @@
+module Data.Profunctor.Withering where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Control.Applicative
+
+class (Traversing p) => Withering p where
+  cull :: (forall f. Alternative f => (a -> f b) -> (s -> f t)) -> p a b -> p s t
+
+instance Alternative f => Withering (Star f) where
+  cull f (Star amb) = Star (f amb)
+
+instance Monoid m => Withering (Forget m) where
+  cull f (Forget h) = Forget (getAnnihilation . f (AltConst . Just . h))
+    where
+      getAnnihilation (AltConst Nothing) = mempty
+      getAnnihilation (AltConst (Just m)) = m
+
+newtype AltConst a b = AltConst (Maybe a)
+  deriving stock (Eq, Ord, Show, Functor)
+
+instance Monoid a => Applicative (AltConst a) where
+  pure _ = (AltConst (Just mempty))
+  (AltConst Nothing) <*> _ = (AltConst Nothing)
+  _ <*> (AltConst Nothing) = (AltConst Nothing)
+  (AltConst (Just a)) <*> (AltConst (Just b)) = AltConst (Just (a <> b))
+
+instance (Semigroup a) => Semigroup (AltConst a x) where
+  (AltConst Nothing) <> _ = (AltConst Nothing)
+  _ <> (AltConst Nothing) = (AltConst Nothing)
+  (AltConst (Just a)) <> (AltConst (Just b)) = AltConst (Just (a <> b))
+
+instance (Monoid a) => Monoid (AltConst a x) where
+  mempty = (AltConst (Just mempty))
+
+instance Monoid m => Alternative (AltConst m) where
+  empty = (AltConst Nothing)
+  (AltConst Nothing) <|> a = a
+  a <|> (AltConst Nothing) = a
+  (AltConst (Just a)) <|> (AltConst (Just b)) = (AltConst (Just (a <> b)))
diff --git a/src/Examples/Algebraic.hs b/src/Examples/Algebraic.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Algebraic.hs
@@ -0,0 +1,29 @@
+module Examples.Algebraic where
+
+import Proton
+
+pad :: AlgebraicLens String [String] String Int
+pad = listLens id padder
+  where
+    padder :: [String] -> Int -> [String]
+    padder xs n = fmap (\s -> take n $ s <> repeat ' ') xs
+
+padLength :: AlgebraicLens String [String] Int Int
+padLength = listLens length padder
+  where
+    padder :: [String] -> Int -> [String]
+    padder xs n = fmap (\s -> take n $ s <> repeat ' ') xs
+
+-- >>> ["a", "hello", "yo"] & padLength >- maximum
+-- ["a    ","hello","yo   "]
+-- >>> ["a", "hello", "yo"] & padLength >- minimum
+-- ["a","h","y"]
+
+-- >>> ["a", "hello", "yo"] & pad ?. 6
+-- ["a     ","hello ","yo    "]
+-- >>> ["a", "hello", "yo"] & pad ?. 2
+-- ["a ","he","yo"]
+-- >>> ["a", "hello", "yo"] & pad >- maximum . fmap length
+-- ["a    ","hello","yo   "]
+-- >>> ["a", "hello", "yo"] & pad >- minimum . fmap length
+-- ["a","h","y"]
diff --git a/src/Examples/Alt.hs b/src/Examples/Alt.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Alt.hs
@@ -0,0 +1,13 @@
+module Examples.Alt where
+
+-- import Proton
+-- import Debug.Trace
+-- import Data.Functor.Identity
+-- import Data.Foldable
+-- import Linear
+
+-- test = [Just (1 :: Int), Nothing, Just 3] & collapse *% sum
+-- test = [Nothing, Just 2] & collapse *% (*100) . sum
+-- test = (V3 (Just 1) (Just 2) (Just 3)) &  convolving *% (*100) . sum
+
+    -- print $ Measurements [5, 4, 3, 1] & measureNearest .* flowers
diff --git a/src/Examples/Coalgebraic.hs b/src/Examples/Coalgebraic.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Coalgebraic.hs
@@ -0,0 +1,10 @@
+module Examples.Coalgebraic where
+
+-- >>> [Just 1, Just 2, Just 3] & _Just >- sum
+-- Just 6
+
+-- >>> [Just 1, Nothing, Just 3] & _Just >- sum
+-- Nothing
+
+-- >>> [Right 1, Left "whoops", Right 2] & _Right >- sum
+-- Left "whoops"
diff --git a/src/Examples/Diffract.hs b/src/Examples/Diffract.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Diffract.hs
@@ -0,0 +1,14 @@
+module Examples.Diffract where
+
+import Data.Pair
+import Proton
+
+split :: [a] -> Pair [a]
+split x = Pair x (reverse x)
+
+splitter :: (a, a) -> Pair a
+splitter (a, b) = Pair a b
+
+example :: IO ()
+example = do
+    print $ diffract (traversed . traversed) splitter [[(1, 2), (3, 4)], [(5, 6), (7, 8 :: Int)]]
diff --git a/src/Examples/Flowers.hs b/src/Examples/Flowers.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Flowers.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Examples.Flowers where
+
+import Proton
+
+import Data.Profunctor.Rep
+import Data.Profunctor.Strong
+import Data.Profunctor.Sieve
+import Data.Foldable
+
+import qualified Data.Map as M
+import Data.List
+import Data.Ord
+import Data.Function
+import Control.Applicative
+import Debug.Trace
+import Data.Functor.Identity
+import Proton.Algebraic
+import Data.Profunctor
+
+data Species = Setosa | Versicolor | Virginica
+  deriving Show
+
+data Measurements = Measurements {getMeasurements :: [Float]}
+  deriving Show
+
+data Flower = Flower {flowerSpecies :: Species, flowerMeasurements :: Measurements}
+  deriving Show
+
+-- measurements' :: p [Float] [Float] -> p Measurements Measurements
+-- measurements' :: Lens' Measurements [Float]
+-- measurements' p =
+
+measurementDistance :: Measurements -> Measurements -> Float
+measurementDistance (Measurements xs) (Measurements ys) =
+    sqrt . sum $ zipWith diff xs ys
+  where
+    diff a b = (a - b) ** 2
+
+-- aggregate :: Kaleidoscope' Measurements Float
+aggregate :: Kaleidoscope' Measurements Float
+aggregate = iso getMeasurements Measurements . pointWise
+
+-- measureLens :: Lens' Measurements [Float]
+-- measureLens = lens getMeasurements setter
+--   where
+--     setter _ b = Measurements b
+
+classify :: [Flower] -> Measurements -> Maybe Flower
+classify flowers m
+  | null flowers = Nothing
+  | otherwise =
+  let Flower species _ = minimumBy
+                          (comparing (measurementDistance m . flowerMeasurements))
+                          flowers
+   in Just $ Flower species m
+
+-- measurements :: (Corepresentable p, Foldable (Corep p)) => Optic' p Flower Measurements
+-- measurements = listLens flowerMeasurements classify
+
+measurements :: AlgebraicLens Flower (Maybe Flower) Measurements Measurements
+measurements = listLens flowerMeasurements classify
+
+-- strained :: forall s b. ListLens s [s] s Bool
+-- strained = listLens id go
+--   where
+--     -- go :: ([s], [Bool]) -> [s]
+--     -- go  = fmap fst . filter snd . uncurry zip
+--     go  (x, True)  = x
+--     go  (x, False) = []
+
+versicolor :: Flower
+versicolor = Flower Versicolor (Measurements [2, 3, 4, 2])
+
+setosa :: Flower
+setosa = Flower Setosa (Measurements [5, 4, 3, 2.5])
+
+flowers :: [Flower]
+flowers = [versicolor, setosa]
+
+mean :: Fractional a => [a] -> a
+mean [] =  0
+mean xs = sum xs / fromIntegral (length xs)
+
+
+infixr 4 >--
+(>--) :: [s] -> Optic (Costar []) s t a a -> t
+(>--) xs opt = (runCostar $ opt (Costar head)) xs
+
+aggregateWith :: Functor f => (f Float -> Float) -> Optic (Costar []) Measurements Measurements Float Float
+aggregateWith aggregator p = Costar (Measurements . fmap (cosieve p) . transpose . fmap getMeasurements)
+
+avgMeasurement :: Foldable f => f Measurements -> Measurements
+avgMeasurement ms = Measurements (mean <$> groupedMeasurements)
+  where
+    groupedMeasurements :: [[Float]]
+    groupedMeasurements = transpose (getMeasurements <$> toList ms)
+    mean :: [Float] -> Float
+    mean xs = sum xs / fromIntegral (length xs)
+
+applyWeight :: Float -> Measurements -> Measurements
+applyWeight w (Measurements m) = Measurements (fmap (*w) m)
+
+partitioned :: forall f a. (Ord a) => AlgebraicLens a ([a], [a]) a a
+partitioned = listLens id splitter
+  where
+    -- splitter :: f a -> a -> ([a], [a])
+    splitter xs ref
+      = (filter (< ref) (toList xs), filter (>= ref) (toList xs))
+
+onFirst :: Eq a => AlgebraicLens (a, b) (Maybe b) a a
+onFirst = listLens fst picker
+  where
+    picker xs a = lookup a $ toList xs
+
+selectingOn :: (s -> a) -> AlgebraicLens s (Maybe s) a (Maybe Int)
+selectingOn project = listLens project picker
+  where
+    picker xs i = (toList xs !!) <$> i
+
+indexOf :: Eq s => AlgebraicLens s (Maybe Int) s s
+indexOf = listLens id (flip elemIndex . toList)
+
+test :: IO ()
+test = do
+    -- print $ [1..10] & partitioned ?- (5 :: Int)
+    -- print $ [1..10] & partitioned >- mean
+    -- print $ ["banana", "pomegranate", "watermelon"] & selectingOn length >- elemIndex 11
+    -- print $ ["banana", "pomegranate", "watermelon"] & selectingOn length . indexOf ?- 11
+    -- print $ Identity "banana" & selectingOn length . indexOf %~ (+10)
+    -- print $ (flowers >-- (measurements . aggregateWith mean))
+    print $ flowers & (measurements . aggregate >- mean)
+    -- We can use a list-lens as a setter over a single element
+    -- print $ versicolor & measurements . aggregate %~ negate
+
+    -- -- We can explicitly compare to a specific result
+    -- print $ (flowers !! 1) ^. measurements
+    -- print $ (flowers ?. measurements) $ Measurements [5, 4, 3, 1]
+    -- print $ Measurements [5, 4, 3, 1] & (measurements .* flowers)
+    -- print $ Measurements [5, 4, 3, 1] & measurements .* flowers
+
+    -- -- We can provide an aggregator explicitly
+    -- print $ mean & (flowers >- measurements . aggregate)
+    -- print $ flowers & measurements >- avgMeasurement
+    -- print $ M.fromList [(1.2, setosa), (0.6, versicolor)] & measurements >- avgMeasurement . fmap (uncurry applyWeight) . M.toList
+    -- print $ flowers & (measurements . aggregate *% mean)
+    -- print $ flowers & (measurements . aggregate *% mean)
+    -- print $ flowers & (measurements . aggregate *% maximum)
+    -- print $ [[1, 2, 3], [1, 2, 3], [1, 2, 3]] & convolving *% id
+    --
+
+
+allMeasurements :: [[Float]]
+allMeasurements =
+      [ [1  , 2  , 3  , 4  ]
+      , [10 , 20 , 30 , 40 ]
+      , [100, 200, 300, 400]
+      ]
+
+measurementMap :: M.Map String (ZipList Float)
+measurementMap = M.fromList
+      [ ("setosa"    , ZipList [1  , 2  , 3  , 4  ])
+      , ("versicolor", ZipList [10 , 20 , 30 , 40 ])
+      , ("virginica" , ZipList [100, 200, 300, 400])
+      ]
diff --git a/src/Examples/Glass.hs b/src/Examples/Glass.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Glass.hs
@@ -0,0 +1,7 @@
+module Examples.Glass where
+
+import Proton
+import Data.Profunctor
+import Data.List.NonEmpty
+
+-- test =
diff --git a/src/Examples/Layers.hs b/src/Examples/Layers.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Layers.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
+module Examples.Layers where
+
+import Proton
+import Data.Profunctor
+import Data.Profunctor.Rep
+import Data.Profunctor.MStrong
+import Proton.Algebraic
+import qualified Data.Map as M
+import Data.Foldable
+import Data.Maybe
+
+imgLayers :: [[Int]]
+imgLayers = [ [0, 1, 0, 1]
+            , [2, 3, 3, 2]
+            ]
+
+-- done :: [Int]
+-- done = imgLayers & pointWise *% head . dropWhile (== 0)
+
+-- selector :: (Ord k, Corep p ~ M.Map k, Corepresentable p) => Optic p s [Maybe s] s [k]
+-- selector = listLens id (\(m, k) -> flip M.lookup m <$> k)
+
+-- done' = M.fromList [(1 :: Int, [1, 10]), (2, [2, 20]), (3, [3, 30])]  & selector . convolving *% M.findWithDefault 99 1
+
+forward :: Profunctor p => (s -> a) -> Optic p s t a t
+forward f = lmap f
+
+back :: Profunctor p => (x -> t) -> Optic p s t s x
+back f = rmap f
+
+lookup'er :: Eq a => AlgebraicLens (a, b) (a, Maybe b) a a
+lookup'er = listLens fst (\xs i -> (i, lookup i xs))
+
+-- test :: IO ()
+-- test = do
+--     print $ [([1, 2] , "one" :: String), ([10, 0], "two")] & lookup'er . pointWise *% maximum
diff --git a/src/Examples/Loop.hs b/src/Examples/Loop.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Loop.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+module Examples.Loop where
+
+import Proton.Loop
+import Proton
+import Data.Profunctor
+import Data.Monoid
+
+thing :: Loop' Int Int
+thing = loop id step
+  where
+    step 0 = Right 0
+    step n = Left n
+
+-- factorial :: Int -> Maybe (Int, Product Int)
+-- factorial 0 = Nothing
+-- factorial n = Just (n - 1, Product n)
+
+collatz :: Int -> [Int]
+collatz n = n & while (/= 1) (:[]) %~ step
+  where
+    step x
+      | even x = x `div` 2
+      | otherwise = (3 * x) + 1
+
+-- >>> collatz 3
+-- [3,10,5,16,8,4,2]
+-- >>> collatz 5
+-- [5,16,8,4,2]
+
+factorial :: Int -> Product Int
+factorial n = n & while (/= 0) Product %~ subtract 1
+
+-- >>> factorial 3
+-- Product {getProduct = 6}
+-- >>> factorial 6
+-- Product {getProduct = 720}
+
+accum :: forall p next state. (Monoid state, Strong p, Cochoice p)
+      => (next -> Maybe (next, state)) -> Optic p next state next next
+accum check = loop initialize step . _1
+  where
+    initialize n = case check n of
+        Nothing -> (n, mempty)
+        Just (_, s) -> (n, s)
+    step :: (next, state) -> Either (next, state) state
+    step (n, s) =
+        case check n of
+            Nothing -> Right s
+            Just (n', s') -> Left (n', s <> s')
+
+while :: (Monoid state, Strong p, Cochoice p)
+      => (t -> Bool)
+      -> (t -> state)
+      -> Optic p t state t t
+while continue inj = accum $ \x -> if continue x
+    then Just (x, inj x)
+    else Nothing
+
diff --git a/src/Examples/Scrap.hs b/src/Examples/Scrap.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/Scrap.hs
@@ -0,0 +1,78 @@
+module Examples.Scrap where
+
+import Linear
+import Proton
+import Data.Ord
+import Data.List
+import Data.Profunctor.Distributing
+import Proton.Algebraic
+import Data.Profunctor.Closed
+import Data.Profunctor.Rep
+import Debug.Trace
+import qualified Data.Map as M
+import Data.Distributive
+import Control.Applicative
+import Data.Functor.Identity
+import Data.Profunctor.Reflector
+
+data Species = Setosa | Versicolor | Virginica
+  deriving Show
+
+data Measurements = Measurements {getMeasurements :: V4 Float}
+  deriving Show
+
+
+data Flower = Flower {species :: Species, measurements :: Measurements}
+  deriving Show
+
+measurementDistance :: Measurements -> Measurements -> Float
+measurementDistance (Measurements xs) (Measurements ys) = sum . abs $  xs - ys
+
+classify :: Foldable f => f Flower -> Measurements -> Flower
+classify flowers m =
+    let Flower species _ = minimumBy (comparing (measurementDistance m . measurements)) flowers
+     in Flower species m
+
+aggregate :: Kaleidoscope' Measurements Float
+aggregate = iso getMeasurements Measurements . reflected
+
+measureNearest :: AlgebraicLens' Flower Measurements
+measureNearest = listLens measurements classify
+
+flower1 :: Flower
+flower1 = Flower Versicolor (Measurements (V4 2 3 4 2))
+
+flower2 :: Flower
+flower2 = Flower Setosa (Measurements (V4 5 4 3 2.5))
+
+flowers :: [Flower]
+flowers = [flower1, flower2, flower1]
+
+mean :: [Float] -> Float
+mean [] =  0
+mean xs = sum xs / fromIntegral (length xs)
+
+-- compVectors :: (Applicative f) => AlgebraicLens Int (f Int) Int (f Int)
+-- compVectors = algebraic pure _ (liftA2 (+))
+
+aggOnIndex :: (s -> a) -> AlgebraicLens s b a b
+aggOnIndex f = listLens f (flip const)
+
+test :: IO ()
+test = do
+    print ()
+    -- We can use a list-lens as a setter over a single element
+    -- print $ flower1 & measureNearest . aggregate %~ negate
+
+    -- -- We can explicitly compare to a specific result
+    -- print $ Measurements [5, 4, 3, 1] & flowers ?. measureNearest
+    -- print $ Measurements [5, 4, 3, 1] & measureNearest .* flowers
+
+    -- -- We can provide an aggregator explicitly
+    -- print $ mean & (flowers >- measureNearest . aggregate)
+    -- print $ flowers & (measureNearest . aggregate *% mean)
+    -- print $ flowers & measureNearest . aggregate *% maximum . traceShowId
+    -- print . sequenceA $ [V2 1 2, V2 10 20, V2 100 200] & distribute' . compVectors *% const [2, 3, 4]
+    -- print $ flower1 & measureNearest . aggregate %~ (+10)
+    -- print $ flower1 ^. measureNearest . aggregate
+    -- print $ [[1, 2, 3], [3, 4, 5]] & convolving *% mean
diff --git a/src/Proton.hs b/src/Proton.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton.hs
@@ -0,0 +1,27 @@
+module Proton (
+    module P
+    ) where
+
+import Data.Profunctor.Extraction as P
+import Proton.Achromatic as P
+import Proton.Algebraic as P
+import Proton.Coalgebraic as P
+import Proton.Feedback as P
+import Proton.Fold as P
+import Proton.Getter as P
+import Proton.Glass as P
+import Proton.Grate as P
+import Proton.Grid as P
+import Proton.Iso as P
+import Proton.Kaleidoscope as P
+import Proton.Diffraction as P
+import Proton.Lens as P
+import Proton.Loop as P
+import Proton.Prisms as P
+import Proton.Review as P
+import Proton.Setter as P
+import Proton.Traversal as P
+import Proton.Indexed as P
+import Proton.Types as P
+
+import Data.Function as P ((&))
diff --git a/src/Proton/Achromatic.hs b/src/Proton/Achromatic.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Achromatic.hs
@@ -0,0 +1,17 @@
+module Proton.Achromatic where
+
+import Data.Profunctor
+import Data.Profunctor.Strong
+import Proton.Lens
+
+achrom :: forall s t a b
+       . (s -> Maybe (b -> t))
+       -> (s -> a)
+       -> (b -> t)
+       -> Lens s t a b
+achrom try proj rev p = strong go $ lmap proj p
+  where
+    go :: s -> b -> t
+    go s b = case try s of
+        Nothing -> rev b
+        Just f -> f b
diff --git a/src/Proton/Algebraic.hs b/src/Proton/Algebraic.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Algebraic.hs
@@ -0,0 +1,46 @@
+module Proton.Algebraic
+    ( MStrong(..)
+    , AlgebraicLens
+    , AlgebraicLens'
+    , algebraic
+    , listLens
+    , altLens
+    , (>-)
+    , (?.)
+    ) where
+
+import Data.Profunctor
+import Data.Profunctor.MStrong
+import Proton.Types
+import Data.Monoid
+import Control.Applicative
+import Control.Arrow
+
+type AlgebraicLens s t a b = forall p. MStrong p => p a b -> p s t
+type AlgebraicLens' s a = AlgebraicLens s s a a
+
+algebraic :: forall m p s t a b
+           . (Monoid m,  MStrong p)
+           => (s -> m)
+           -> (s -> a)
+           -> (m -> b -> t)
+           -> Optic p s t a b
+algebraic inject project flatten p
+  = dimap (inject &&& id)  (uncurry flatten) $  strengthened
+  where
+    strengthened :: p (m, s) (m, b)
+    strengthened = msecond' (lmap project p)
+
+listLens :: MStrong p => (s -> a) -> ([s] -> b -> t) -> Optic p s t a b
+listLens = algebraic pure
+
+altLens :: (Alternative f, MStrong p) => (s -> a) -> (f s -> b -> t) -> Optic p s t a b
+altLens project flatten = algebraic (Alt . pure)  project (flatten . getAlt)
+
+infixr 4 ?.
+(?.) :: Optic (Costar f) s t a b -> b -> f s -> t
+(?.) opt b xs = (runCostar $ opt (Costar (const b))) xs
+
+infixr 4 >-
+(>-) :: Optic (Costar f) s t a b -> (f a -> b) -> f s -> t
+(>-) opt aggregator xs = (runCostar $ opt (Costar aggregator)) xs
diff --git a/src/Proton/Annotated.hs b/src/Proton/Annotated.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Annotated.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Proton.Annotated where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Data.Profunctor.Coindexed
+import Proton.Types
+import Proton.Setter
+
+
+-- coindexing :: (Coindexable i p q) => (s -> i) -> p s t -> q s t
+-- coindexing f p = lmap (f &&& id) $ coindexed p
+
+-- itraversed :: (Coindexable Int p q, Traversing q) => p a b -> q [a] [b]
+-- vFirst :: CoindexedOptic String p [a] [b] a b
+-- vFirst p = _ $ coindexed p
+
+vView :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a
+vView lns = runForget . runCoindexed $ lns (Forget Right)
+
+-- vToListOf :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a
+-- vToListOf lns = runForget . runCoindexed $ lns (Forget Right)
+
+coindexing :: forall e p s t a b. Profunctor p =>
+    Optic (Coindexed e p) s t a b -> Optic p s (Either e t) a b
+coindexing o p = runCoindexed . o $ Coindexed (rmap Right p)
+
+-- itoListOf :: CoindexedOptic e (Forget [a]) s t a b -> s -> [(i, a)]
+-- itoListOf fld = _ (fld (Forget pure))
+
+vOver :: Optic (Coindexed e (->)) s t a b -> (a -> b) -> s -> Either e t
+vOver modifier f s = over (coindexing modifier) f s
+
+-- vFirst :: forall p a. Choice p => p a a -> Coindexed String p [a] [a]
+-- vFirst p = Coindexed (dimap _ _ $ right' p)
+--   where
+--     -- passThrough :: p (Either [a] (a, [a])) (Either [a] (a, [a]))
+--     passThrough = dimap _ _ $ right' p
+
+vFirst :: forall p a. Traversing p => p a a -> Coindexed String p [a] [a]
+vFirst p = Coindexed (wander go p)
+  where
+    go :: forall f. Applicative f => (a -> f a) -> [a] -> f (Either String [a])
+    go _ [] = pure (Left "No first element to list")
+    go f (x : xs) = Right . (:xs) <$> f x
+
+-- iset :: CoindexedOptic i (->) s t a b -> (i -> b) -> s -> t
+-- iset setter f = iover setter (\i _ -> f i)
diff --git a/src/Proton/Coalgebraic.hs b/src/Proton/Coalgebraic.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Coalgebraic.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE InstanceSigs #-}
+module Proton.Coalgebraic where
+
+import Proton.Types
+import Data.Profunctor
+import Proton.Prisms
+import Proton.Review
+
+type Coalgebraic s t a b = forall p. MChoice p => Optic p s t a b
+type Coalgebraic' s a = Coalgebraic s s a a
+
+swapEither :: Either a b -> Either b a
+swapEither (Left a) = Right a
+swapEither (Right a) = Left a
+
+class Profunctor p => MChoice p where
+  mleft' :: p a b -> p (Either a m) (Either b m)
+  mleft' = dimap swapEither swapEither . mright'
+  mright' :: p a b -> p (Either m a) (Either m b)
+  mright' = dimap swapEither swapEither . mleft'
+
+instance MChoice (->) where
+  mright' = right'
+
+instance Applicative f => MChoice (Star f) where
+  mright' = right'
+
+instance (Monoid r) => MChoice (Forget r) where
+  mright' = right'
+
+instance Traversable f => MChoice (Costar f) where
+  mright' :: forall a b m. Costar f a b -> Costar f (Either m a) (Either m b)
+  mright' (Costar f) = (Costar (fmap f . sequenceA))
+
+coprism :: (b -> t) -> (s -> Either t a) -> Coalgebraic s t a b
+coprism rev split = dimap split (either id rev) . mright'
+
+coalgPrism :: Prism s t a b -> Coalgebraic s t a b
+coalgPrism pr = coprism (review pr) (matching pr)
+
+_Just' :: Coalgebraic (Maybe a) (Maybe b) a b
+_Just' = coalgPrism _Just
+
+_Right' :: Coalgebraic (Either e a) (Either e b) a b
+_Right' = coalgPrism _Right
diff --git a/src/Proton/Coindexed.hs b/src/Proton/Coindexed.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Coindexed.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Proton.Coindexed where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Data.Profunctor.Coindexed
+import Proton.Types
+import Proton.Setter
+import Proton.Prisms
+import Proton.Fold
+import Data.Monoid
+
+
+-- coindexing :: (Coindexable i p q) => (s -> i) -> p s t -> q s t
+-- coindexing f p = lmap (f &&& id) $ coindexed p
+
+-- itraversed :: (Coindexable Int p q, Traversing q) => p a b -> q [a] [b]
+-- vFirst :: CoindexedOptic String p [a] [b] a b
+-- vFirst p = _ $ coindexed p
+
+vView :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a
+vView lns = runForget . runCoindexed $ lns (Forget Right)
+
+vPrism :: (Coindexable e p q, Choice p, Choice q) => (t -> e) -> Prism s t a b -> Optical p q s t a b
+vPrism f pr q = withPrism pr $ \proj match ->
+    coindexed . rmap (either (Left . f) (Right . proj)) . lmap match $ right' q
+
+_Just' :: (Choice p, Choice q, Coindexable String p q) => Optical p q (Maybe a) (Maybe b) a b
+_Just' = vPrism (const "Expected Just but got Nothing") _Just
+
+-- vToListOf :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a
+-- vToListOf lns = runForget . runCoindexed $ lns (Forget Right)
+
+coindexing :: forall e p s t a b. Profunctor p =>
+    Optic (Coindexed e p) s t a b -> Optic p s (Either e t) a b
+coindexing o p = runCoindexed . o $ Coindexed (rmap Right p)
+
+-- itoListOf :: CoindexedOptic e (Forget [a]) s t a b -> s -> [(i, a)]
+-- itoListOf fld = _ (fld (Forget pure))
+
+vOver :: Optic (Coindexed e (->)) s t a b -> (a -> b) -> s -> Either e t
+vOver modifier f s = over (coindexing modifier) f s
+
+-- vFirst :: forall p a. Choice p => p a a -> Coindexed String p [a] [a]
+-- vFirst p = Coindexed (dimap _ _ $ right' p)
+--   where
+--     -- passThrough :: p (Either [a] (a, [a])) (Either [a] (a, [a]))
+--     passThrough = dimap _ _ $ right' p
+
+-- (^??) :: forall e s t a b p q. s -> Optical p q s t a b ->  Either e a
+-- (^??) s o = maybe (undefined) Right (s ^? (o @(Forget (First a)) @(Forget (First a))))
+
+vFirst :: forall p a. Traversing p => p a a -> Coindexed String p [a] [a]
+vFirst p = Coindexed (wander go p)
+  where
+    go :: forall f. Applicative f => (a -> f a) -> [a] -> f (Either String [a])
+    go _ [] = pure (Left "No first element to list")
+    go f (x : xs) = Right . (:xs) <$> f x
+
+-- iset :: CoindexedOptic i (->) s t a b -> (i -> b) -> s -> t
+-- iset setter f = iover setter (\i _ -> f i)
diff --git a/src/Proton/Diffraction.hs b/src/Proton/Diffraction.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Diffraction.hs
@@ -0,0 +1,8 @@
+module Proton.Diffraction where
+
+import Data.Distributive
+import Proton.Types
+import Data.Profunctor
+
+diffract :: Distributive f => Optic (Star f) s t a b -> (a -> f b) -> s -> f t
+diffract opt f = runStar $ opt (Star f)
diff --git a/src/Proton/Feedback.hs b/src/Proton/Feedback.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Feedback.hs
@@ -0,0 +1,36 @@
+module Proton.Feedback where
+
+import Data.Profunctor
+import Proton.Types
+import Proton.Setter
+import Data.Function
+import Debug.Trace
+
+type Feedback s t a b = forall p. Costrong p => p a b -> p s t
+type Feedback' s a = Feedback s s a a
+
+-- Simplified:
+-- feedback :: forall p s t a b state. Costrong p
+--      => ((a, b) -> b) -> (b -> (a, b)) -> Optic' p a b
+feedback :: forall p s t a b. Costrong p
+     => ((s, b) -> a) -> (b -> (t, b)) -> Optic p s t a b
+feedback ping pong = unfirst . dimap ping pong
+
+-- factorial :: Feedback' Int Int
+-- factorial = feedback ping pong
+--   where
+--     ping :: (Int, Int) -> Int
+--     ping ~(new, acc) = new * acc
+--     pong :: Int -> (Int, Int)
+--     pong n = (n - 1, 3)
+
+fib :: Feedback Int [Int] [Int] [Int]
+fib = feedback ping pong
+  where
+    ping :: ((Int, [Int]) -> [Int])
+    ping (n, xs) = take n xs
+    pong :: [Int] -> ([Int], [Int])
+    pong xs = (reverse xs, xs)
+
+-- >>> 10 & fib %~ \xs -> 1 : 1 : zipWith (+) xs (tail xs)
+-- [1,1,2,3,5,8,13,21,34,55,89]
diff --git a/src/Proton/Fold.hs b/src/Proton/Fold.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Fold.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE InstanceSigs #-}
+module Proton.Fold where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Data.Profunctor.Phantom
+import Data.Monoid
+import Proton.Types
+import Data.Foldable
+
+type Fold s t a b = forall p. (Traversing p, Phantom p) => p a b -> p s t
+
+folding :: (Foldable f, Phantom p, Traversing p) => (s -> f a) -> p a b -> p s t
+folding f = phantom . lmap (toList . f) . traverse'
+
+folded :: (Traversing p, Foldable f, Phantom p)
+       => p a b -> p (f a) t
+folded = phantom . lmap toList . traverse'
+
+foldOf :: Monoid a => Fold s t a b -> s -> a
+foldOf f = runForget (f (Forget id))
+
+foldMapOf :: Monoid m => Optic (Forget m) s t a b -> (a -> m) -> s -> m
+foldMapOf f into = runForget (f (Forget into))
+
+toListOf :: Optic (Forget [a]) s t a b -> s -> [a]
+toListOf fld = foldMapOf fld pure
+
+preview :: Optic (Forget (First a)) s t a b -> s -> Maybe a
+preview fld = getFirst . foldMapOf fld (First . Just)
+
+(^?) :: s -> Optic (Forget (First a)) s t a b -> Maybe a
+(^?) = flip preview
+
+(^..) :: s -> Optic (Forget [a]) s t a b -> [a]
+(^..) = flip toListOf
+
+(<+>) :: Semigroup r => Optic (Forget r) s t a b -> Optic (Forget r) s t' a b' -> Optic (Forget r) s t a b
+(fldA <+> fldB) p = 
+    case (fldA p, fldB (phantom p)) of
+        (Forget f, Forget g) -> Forget (\a -> f a <> g a)
diff --git a/src/Proton/Getter.hs b/src/Proton/Getter.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Getter.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+module Proton.Getter where
+
+import Data.Profunctor
+import Data.Profunctor.Phantom
+import Proton.Types
+
+type Getter s t a b = forall p. Phantom p => p a b -> p s t
+
+to :: (s -> a) -> Getter s t a b
+to f = phantom . lmap f
+
+-- Getter without Phantom requirement, may be useful with Grids/Grates
+to' :: Profunctor p => (s -> a) -> Optic p s b a b
+to' f = lmap f
+
+view :: Optic (Forget a) s t a b -> s -> a
+view g = runForget . g $ Forget id
+
+views :: Optic (Forget a) s t a b -> (a -> a') -> s -> a'
+views g f = f . view g
+
+like :: a -> Getter s t a b
+like = to . const
+
+infixl 8 ^.
+(^.) ::  s -> Optic (Forget a) s t a b -> a
+(^.) = flip view
diff --git a/src/Proton/Glass.hs b/src/Proton/Glass.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Glass.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Proton.Glass where
+
+import Data.Profunctor
+import Control.Comonad
+import Proton.Types
+import Proton.Internal.Orphans
+import Proton.Lens
+import Proton.Setter
+import Proton.Getter
+
+type Glass s t a b = forall p. (Strong p, Closed p) => Optic p s t a b
+type Glass' s a = Glass s s a a
+
+-- class Glassy p where
+--   glass :: (((s -> a) -> b) -> s -> t) -> p a b -> p s t
+
+type Glassed p = (Strong p, Closed p)
+glassed :: (Strong p, Closed p) => p a b -> p (s, u -> a) (s, u -> b)
+glassed = second' . closed
+
+glass :: forall p s t a b. Glassed p => (((s -> a) -> b) -> s -> t) -> p a b -> p s t
+glass glasser p = dimap l r $ glassed p
+  where
+    l :: s -> (s, (s -> a) -> a)
+    l s = (s, ($ s))
+    r :: (s, (s -> a) -> b) -> t
+    r (s, f) = glasser f s
+
+glassList :: forall a b. Glass [a] [b] a b
+glassList = glass go
+  where
+    go :: (([a] -> a) -> b) -> [a] -> [b]
+    go f s = undefined
+
+extendOf :: (Comonad w) => Optic (Costar w) s t a b -> (w a -> b) -> w s -> w t
+extendOf gr f = extend (runCostar $ gr (Costar f))
+
+traversed' :: forall f a b. Traversable f => Glass (f a) (f b) a b
+traversed' = glass go
+  where
+    go :: ((f a -> a) -> b) -> f a -> f b
+    go f fa = undefined
+
+-- instance Comonad f => Strong (Costar f) where
+--   first' (Costar f) = (Costar (extract . extend (\x -> (, snd . extract $ x) $ f (fst <$> x))))
+
+
+
+-- instance Comonad f => Glassy (Costar f) where
+--   glass glasser (Costar fab) = Costar (\s -> extract $ fmap (glasser (go s)) s)
+--     where
+--       go fs sToA = fab $ fmap sToA fs
+
+-- instance (Functor f) => Glassy (Costar f) where
+--   glass glasser (Costar fab) = Costar (\fs -> flip glasser $ collect go fs)
+--     where
+--       go :: s -> _ -> b
+--       go = undefined
+--       go s sToA = fab $ fmap sToA fs
+
+
+-- type Glass = Glassy p => p a b -> p s t
+
+-- glass :: Comonad w => (((s -> a) -> b) -> s -> t) -> GrateLike w s t a b
+-- glass glasser f s = (glasser $ \h -> f (h <$> s)) $ extract s
+
+-- Move this somewhere
+-- instance (Comonad w) => Strong (Costar w) where
+--   first' :: forall a b c. Costar w a b -> Costar w (a, c) (b, c)
+--   first' (Costar f) = Costar go
+--     where
+--       go :: (w (a, c) -> (b, c))
+--       go wac = extract $ extendThrough (lensGlass _1) f wac
diff --git a/src/Proton/Grate.hs b/src/Proton/Grate.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Grate.hs
@@ -0,0 +1,49 @@
+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 g = dimap (&) g . closed
+
+distributed :: (Closed p, Representable g) => p a b -> p (g a) (g b)
+distributed = dimap index tabulate . closed
+
+both :: Grate (a, a) (b, b) a b
+both = paired . distributed
+
+zipWithOf :: forall s t a b. Optic (Costar Pair) s t a b -> (a -> a -> b) -> s -> s -> t
+zipWithOf g f s1 s2 = zipFWithOf g (liftPair f) (Pair s1 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 g fab fs = grated fs
+  where
+    grated :: f s -> t
+    Costar grated = g (Costar 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
+
diff --git a/src/Proton/Grid.hs b/src/Proton/Grid.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Grid.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeFamilies #-}
+module Proton.Grid where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Proton.Types
+import Proton.Grate
+import Data.Pair
+import Proton.Setter
+import Proton.Traversal
+
+type Grid s t a b = forall p. (Traversing p, Closed p) => Optic p s t a b
+type Grid' s a = Grid s s a a
+
+-- bothT :: Traversal (a, a) (b, b) a b
+-- bothT p = _ $ traverse' p
+
+-- beside :: Optic p s t a b -> Optic p s' t' a b -> Optic p (s, s') (t, t') a b
+-- beside l r = distributed
diff --git a/src/Proton/Indexed.hs b/src/Proton/Indexed.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Indexed.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Proton.Indexed where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Control.Arrow ((&&&))
+import Data.Profunctor.Indexed
+import Proton.Types
+
+indexing :: (Indexable i p q) => (s -> i) -> p s t -> q s t
+indexing f p = lmap (f &&& id) $ indexed p
+
+-- itraversed :: (Indexable Int p q, Traversing q) => p a b -> q [a] [b]
+itraversed :: Traversing p => IndexedOptic Int p [a] [b] a b
+itraversed p = lmap (zip [(0 :: Int)..]) . traverse' $ indexed p
+
+itoListOf :: IndexedOptic i (Forget [(i, a)]) s t a b -> s -> [(i, a)]
+itoListOf fld = runForget (fld (Indexed (Forget pure)))
+
+iover :: IndexedOptic i (->) s t a b -> (i -> a -> b) -> s -> t
+iover setter f = setter (Indexed (uncurry f))
+
+iset :: IndexedOptic i (->) s t a b -> (i -> b) -> s -> t
+iset setter f = iover setter (\i _ -> f i)
diff --git a/src/Proton/Internal/Orphans.hs b/src/Proton/Internal/Orphans.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Internal/Orphans.hs
@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TupleSections #-}
+module Proton.Internal.Orphans where
+
+import Data.Profunctor
+import Control.Comonad
+-- import Proton.Types
+-- import Proton.Setter
+-- import Proton.Getter
+
+-- Steal this from Cokleisli at some point
+-- instance Comonad w => Choice (Costar w) where
+
+instance Comonad f => Strong (Costar f) where
+  -- Not quite right
+  first' (Costar f) = (Costar (extract . extend (\x -> (, snd . extract $ x) $ f (fst <$> x))))
+
+-- Don't think this is useful for anything; but we can get a Strong instance for Costar
+-- using an adjunction between Star/Costar through (,) (->).
+
+-- instance Strong (Costar ((,) e)) where
+--   second' co = costarFlip $ second' (starFlip co)
+
+-- starFlip :: Costar ((,) e) a b -> Star ((->) e) a b
+-- starFlip (Costar f) = Star (\e a ->  f (a, e))
+
+-- costarFlip :: Star ((->) e) a b -> Costar ((,) e) a b
+-- costarFlip (Star f) = Costar (\(e, a) ->  f a e)
diff --git a/src/Proton/Iso.hs b/src/Proton/Iso.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Iso.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveFunctor #-}
+module Proton.Iso where
+
+import Data.Profunctor
+import Proton.Getter
+import Proton.Review
+
+type Iso s t a b = forall p. Profunctor p => p a b -> p s t
+type Iso' s a = Iso s s a a
+
+iso :: (s -> a) -> (b -> t) -> Iso s t a b
+iso = dimap
+
+from :: Iso s t a b -> Iso b a t s
+from i = withIso i $ flip iso
+
+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
+withIso i handler =
+    case i (Exchange id id) of
+        Exchange f g -> handler f g
+
+under :: Iso s t a b -> (t -> s) -> b -> a
+under i ts b = withIso i $ \sa bt -> (sa . ts . bt $ b)
+
+mapping :: (Functor f, Functor g) => Iso s t a b -> Iso (f s) (g t) (f a) (g b)
+mapping i = dimap (fmap (view i)) (fmap (review i))
+
+involuted :: (a -> a) -> Iso' a a
+involuted f = iso f f
+
+data Exchange a b s t =
+    Exchange (s -> a) (b -> t)
+  deriving Functor
+
+instance Profunctor (Exchange a b) where
+  dimap f' g' (Exchange f g) = Exchange (f . f') (g' . g)
diff --git a/src/Proton/Kaleidoscope.hs b/src/Proton/Kaleidoscope.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Kaleidoscope.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Proton.Kaleidoscope (Reflector(..), Kaleidoscope, Kaleidoscope', pointWise) where
+
+-- ala http://events.cs.bham.ac.uk/syco/strings3-syco5/slides/roman.pdf
+-- https://cs.ttu.ee/events/nwpt2019/abstracts/paper14.pdf
+
+import Data.Profunctor
+import Control.Applicative
+import Data.Profunctor.Reflector
+
+type Kaleidoscope s t a b = forall p. Reflector p => p a b -> p s t
+type Kaleidoscope' s a = Kaleidoscope s s a a
+
+pointWise :: Kaleidoscope [a] [b] a b
+pointWise = dimap ZipList getZipList . reflected
+
+-- collapse :: forall p f a b c g. (Traversable g, Applicative g, Alternative f, Corepresentable p, Corep p ~ g)
+--         => Optic' p (f a) a
+-- collapse p = cotabulate done
+--   where
+--     func :: g (f a) -> (f a)
+--     func = cosieve (convolving p)
+--     done :: g (f a) -> f a
+--     done = func . pure @g . asum
diff --git a/src/Proton/Lens.hs b/src/Proton/Lens.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Lens.hs
@@ -0,0 +1,19 @@
+module Proton.Lens where
+
+import Data.Profunctor
+import Data.Profunctor.Strong
+import Control.Arrow ((&&&))
+
+type Lens s t a b = forall p. Strong p => p a b -> p s t
+type Lens' s a = Lens s s a a
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+-- lens getter setter = strong setter . lmap getter
+lens getter setter = dimap (id &&& getter) (uncurry setter) . second'
+
+_1 :: Lens (a, x) (b, x) a b
+_1 = lens fst (\(_, x) b -> (b, x))
+
+
+_2 :: Lens (x, a) (x, b) a b
+_2 = lens snd (\(x, _) b -> (x, b))
diff --git a/src/Proton/Loop.hs b/src/Proton/Loop.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Loop.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE InstanceSigs #-}
+module Proton.Loop where
+
+import Data.Profunctor
+import Data.Profunctor.Traversing
+import Proton.Types
+import Data.Profunctor.Choice
+
+-- Cochoice represents iteration/looping
+
+type Loop s t a b = forall p. Cochoice p => p a b -> p s t
+type Loop' s a = Loop s s a a
+
+data CoPrism a b s t = CoPrism (s -> a) (b -> Either a t)
+
+instance Profunctor (CoPrism a b) where
+  dimap f g (CoPrism project match) = CoPrism (project . f) (fmap g . match)
+
+instance Cochoice (CoPrism a b) where
+  unright :: forall d a' b'. CoPrism a b (Either d a') (Either d b') -> CoPrism a b a' b'
+  unright (CoPrism project match) = CoPrism (project . Right) (go . match)
+    where
+      go :: Either a (Either d b') -> Either a b'
+      go (Left a) = Left a
+      go (Right (Right b)) = Right b
+      go (Right (Left d)) = Left (project $ Left d)
+
+loop :: forall p s t a b. Cochoice p
+     => (s -> a) -> (b -> Either a t) -> Optic p s t a b
+loop inject step = unright . dimap (either id inject) step
+
+-- loop' :: forall p s t a b. (Cochoice p, Traversing p)
+--      => (s -> a) -> (b -> Either a t) -> Optic p s t a b
+-- loop' inject step = unright . dimap (either id inject) step
+
+
+-- iterM :: forall s t a b . Optic (Star ((,) [a])) s t a b -> (a -> Either a b) -> s -> ([a], t)
+-- iterM o f s = g s
+--   where
+--     Star (g :: s -> ([a], t)) = (o . unright . lmap (either id id)) $ Star (wrapper . f)
+--     wrapper :: Either a b -> ([a], Either a b)
+--     wrapper (Left a) = ([a], Left a)
+--     wrapper (Right b) = ([], Right b)
+
+iterM :: forall s t a . Optic (Star ((,) [a])) s t a a -> (a -> Either a a) -> s -> ([a], t)
+iterM o f s = g s
+  where
+    Star (g :: s -> ([a], t)) = o . unright . lmap (either id id) $ Star (wrapper . f)
+    wrapper :: Either a a -> ([a], Either a a)
+    wrapper (Left a) = ([a], Left a)
+    wrapper (Right b) = ([b], Right b)
+
+
+
+
+tester :: Int -> Either Int Int
+tester a 
+  | a < 10 = Left (succ a)
+  | otherwise = Right (succ a)
+
+
+-- iter :: forall f p s t a b. (Alternative f,  Cochoice p)
+--      => Optic p s t a b
+-- iter = _
diff --git a/src/Proton/Miso.hs b/src/Proton/Miso.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Miso.hs
@@ -0,0 +1,8 @@
+module Proton.Miso where
+
+import Data.Profunctor
+
+data Miso m a b s t = Miso (s -> m a) (b -> m t)
+
+instance Functor m => Profunctor (Miso m a b) where
+  dimap l r (Miso sma bmt) = Miso (sma . l) (fmap r . bmt)
diff --git a/src/Proton/Plated.hs b/src/Proton/Plated.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Plated.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Proton.Plated where
+
+import Data.Profunctor
+import Proton.Traversal
+import Proton.Lens
+import Proton.Fold
+import Control.Monad.State
+import Control.Applicative
+import Proton.Setter
+
diff --git a/src/Proton/PreGrate.hs b/src/Proton/PreGrate.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/PreGrate.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE TupleSections #-}
+module Proton.PreGrate where
+
+import Proton.Grate
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Profunctor
+import Data.Maybe
+import Proton.Types
+import Data.Pair
+import Data.Functor.Rep
+import Data.Distributive
+import Data.Functor.Contravariant
+import Control.Comonad
+import qualified Data.List.NonEmpty as NE
+import Data.Profunctor.MStrong
+import Data.Semigroup
+import Data.Coerce
+
+
+alignMaybeWithDefault :: a -> Grate (Maybe a) (Maybe b) a b
+alignMaybeWithDefault def = dimap (fromMaybe def) Just
+
+aligner :: (s -> k -> a) -> ((k -> b) -> t) -> Grate s t a b
+aligner index generate = dimap index generate . closed
+
+alignMap :: (Ord k) => S.Set k -> Grate (M.Map k a) (M.Map k b) (Maybe a) (Maybe b)
+alignMap keys = dimap (flip M.lookup) project . closed
+  where
+    project f = M.fromList . catMaybes $ ((\k -> (k,) <$> f k) <$> S.toList keys)
+
+alignMapWithDefault :: (Ord k) => S.Set k -> a -> Grate (M.Map k a) (M.Map k b) a b
+alignMapWithDefault keys def = alignMap keys . dimap (fromMaybe def) Just
+
+alignList :: Int -> Grate [a] [b] (Maybe a) (Maybe b)
+alignList bound = dimap (flip safeIndex) (\f -> catMaybes $ fmap f [0..bound-1] ) . closed
+  where
+    safeIndex :: Int -> [x] -> Maybe x
+    safeIndex _ [] = Nothing
+    safeIndex n _ | n < 0 = Nothing
+    safeIndex 0 (x:_) = Just x
+    safeIndex n (_:xs) = safeIndex (n-1) xs
+
+alignListWithDefault :: Int -> a -> Grate [a] [b] a b
+alignListWithDefault bound def = alignList bound . dimap (fromMaybe def) Just
+
+alignMapMonoid :: (Monoid a, Ord k) => (S.Set k) -> Grate (M.Map k a) (M.Map k b) a b
+alignMapMonoid n = alignMapWithDefault n mempty
+
+alignListMonoid :: Monoid a => Int -> Grate [a] [b] a b
+alignListMonoid n = alignListWithDefault n mempty
+
+x :: M.Map Int [String]
+x = M.fromList [(1, ["Gala", "Spartan", "Fuji"])]
+
+y :: M.Map Int [String]
+y = M.fromList [(1, ["Naval", "Mandarin"]), (2, ["Watermelon"])]
+
+l :: Grate (M.Map Int [String]) (M.Map Int [b]) String b
+l = alignMapWithDefault (S.fromList [1, 2, 3]) [] . alignListWithDefault 3 "def"
+
+l' :: Grate (M.Map Int [String]) (M.Map Int [b]) (Maybe String) (Maybe b)
+l' = alignMap (S.fromList [1, 2, 3]) . alignMaybeWithDefault [] . alignList 3
+
+newtype Intersection a = Intersection (S.Set a)
+instance Ord a => Semigroup (Intersection a) where
+  (<>) = coerce S.intersection
+
+fullAlignMap :: (Ord k, MStrong p, Closed p) => p a b -> p (M.Map k a) (M.Map k b)
+fullAlignMap = dimap unpack rebuild . mfirst' . closed
+  where
+    unpack m = (\k -> fromJust $ M.lookup k m, Just . Intersection . M.keysSet $ m)
+    rebuild (f, Just (Intersection ks)) = M.fromSet f ks
+    rebuild (_, Nothing) = mempty
+
+fullAlignList :: (MStrong p, Closed p) => p a b -> p [a] [b]
+fullAlignList = dimap unpack rebuild . mfirst' . closed
+  where
+    unpack m = (\k -> m !! k, Just (Min (length m)))
+    rebuild (_, Nothing) = []
+    rebuild (f, Just (Min len)) = fmap f [0..len-1]
+
+-- instance (Comonad f) => Strong (Costar f) where
+--   first' (Costar f) = Costar ((\a b -> (a (fmap fst b), snd . extract $ b)) f)
+
+-- doAThing :: Distributive f => Optic (Star f) s t a b -> (a -> Pair b) -> s -> Pair t
+-- doAThing o = o (Star )
+
+tester :: M.Map Int [String]
+tester = zipFWithOf (fullAlignMap . fullAlignList) concat [x, y]
+
+
+-- Allow splitting a record into component parts to zip as well as the "monoidal" remainder
+-- Then zip the main components, mappend up the rest, and re-combine.
+zipBy :: forall f p s t a b m. (Representable f, MStrong p, Closed p, Monoid m) => (s -> (f a, m)) -> (f b -> m -> t) -> p a b -> p s t
+zipBy project embed = dimap unpack rebuild . mfirst' . closed
+  where
+    unpack :: s -> (Rep f -> a, m)
+    unpack s = 
+        case project s of
+            (fa, m) -> (index fa, m)
+    rebuild :: (Rep f -> b, m) -> t
+    rebuild (rep, m) = embed (tabulate rep) m
+
+-- Strong & Closed == don't need to specify indexes, maybe I can carry them through??
+
+-- hoistO :: Optic (Star f) s t a b -> Optic (Costar g) s t a b
+
+-- tester :: Star ((->) Bool) a b -> Costar Pair a b
+-- tester (Star f) = Costar (_ f)
+
+-- preZipWithOf :: forall s t a b. Optic (Star ((->) Bool)) s t a b -> (a -> a -> b) -> s -> s -> t
+-- preZipWithOf g f s1 s2 = zipFWithOf g (_) (_)
+--   where
+--     buildPair p = tabulate p
+--     applyPair (Pair a b) = f a b
+--     -- thin :: a -> Bool -> b
+--     -- thing = 
+
+-- -- preZipFWithOf :: forall f s t a b. Optic (Star f) s t a b -> (a -> f b) -> (s -> f t)
diff --git a/src/Proton/Prisms.hs b/src/Proton/Prisms.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Prisms.hs
@@ -0,0 +1,57 @@
+module Proton.Prisms where
+
+import Data.Profunctor
+import Proton.Types
+import Data.Market
+
+type Prism s t a b = forall p. Choice p => p a b -> p s t
+type Prism' s a = Prism s s a a
+
+-- dualPrism :: forall p s t a b. (Choice p, Cochoice p) => (s -> Either t a) -> (b -> Either a t) -> Optic p s t a b
+-- dualPrism l r p = lmap l . go $ rmap r p
+--   where
+--     go :: p a (Either a t) -> p (Either t a) t
+--     go = undefined
+
+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
+prism build split = dimap split (either id build) . right'
+
+prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
+prism' build maybeGet = prism build (\s -> maybe (Left s) Right $ maybeGet s)
+
+_Just :: Prism (Maybe a) (Maybe b) a b
+_Just = prism Just (maybe (Left Nothing) Right)
+
+_Nothing :: Prism' (Maybe a) ()
+_Nothing = prism' (const Nothing) (maybe (Just ()) (const Nothing))
+
+_Left :: Prism (Either a b) (Either a' b) a a'
+_Left = prism Left (either Right (Left . Right))
+
+_Right :: Prism (Either a b) (Either a b') b b'
+_Right = prism Right (either (Left . Left) Right)
+
+_Show :: (Read a, Show a) => Prism' String a
+_Show = prism show $ \s -> case reads s of
+  [(a,"")] -> Right a
+  _ -> Left s
+
+withPrism :: forall s t a b r. Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
+withPrism l f = case l (Market id Right) of
+  Market g h -> f g h
+
+matching :: Prism s t a b -> s -> Either t a
+matching p s = withPrism p (\_ match -> match s)
+
+-- outside :: Representable p => APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r)
+
+-- aside :: Prism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
+-- aside pr = _ . pr . _
+
+-- without :: APrism s t a b -> APrism u v c d -> Prism (Either s u) (Either t v) (Either a c) (Either b d)
+
+-- below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
+--
+-- isn't :: Prism s t a b -> s -> Bool
+
+-- matching :: APrism s t a b -> s -> Either t a
diff --git a/src/Proton/Review.hs b/src/Proton/Review.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Review.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+
+module Proton.Review where
+
+import Data.Profunctor
+import Data.Tagged
+import Data.Bifunctor
+import Proton.Getter
+import Data.Void
+
+type Review s t a b = forall p. (Profunctor p, Bifunctor p) => p a b -> p s t
+
+retagged :: forall p a b s. (Profunctor p, Bifunctor p) => p a b -> p s b
+retagged = first absurd . lmap absurd
+
+review :: (Tagged a b -> Tagged s t) -> b -> t
+review pab b = unTagged . pab $ Tagged b
+
+infixr 8 #
+(#) :: (Tagged a b -> Tagged s t) -> b -> t
+(#) = review
+
+reviews :: (Tagged a b -> Tagged s t) -> (t -> t') -> b -> t'
+reviews r f = f . review r
+
+re :: (Tagged a b -> Tagged s t) -> Getter b a t s
+re r = to (review r)
+
+unto :: forall (s :: *) t (a :: *) b. (b -> t) -> (Tagged a b -> Tagged s t)
+unto f = rmap f . retagged
+
+un :: Getter s t a b -> (Tagged t s -> Tagged b a)
+un g = unto (view g)
diff --git a/src/Proton/Setter.hs b/src/Proton/Setter.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Setter.hs
@@ -0,0 +1,29 @@
+module Proton.Setter where
+
+import Data.Profunctor
+
+type Setter s t a b = (a -> b) -> (s -> t)
+type Setter' s a = Setter s s a a
+
+set :: Setter s t a b -> s -> b -> t
+set l s b = l (const b) s
+
+over :: Setter s t a b -> (a -> b) -> s -> t
+over l f s = l f s
+
+sets :: (forall p. Profunctor p => p a b -> p s t) -> Setter s t a b
+sets = id
+
+setter :: (s -> a) -> (b -> t) -> Setter s t a b
+setter f g = dimap f g
+
+mapped :: Functor f => Setter (f a) (f b) a b
+mapped = fmap
+
+infixr 4 %~
+(%~) :: Setter s t a b -> (a -> b) -> s -> t
+(%~) = over
+
+infixr 4 .~
+(.~) :: Setter s t a b -> b -> s -> t
+(.~) l b s = set l s b
diff --git a/src/Proton/Traversal.hs b/src/Proton/Traversal.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Traversal.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+module Proton.Traversal where
+
+import Control.Applicative
+import Control.Monad.State
+import Data.Bitraversable
+import Data.Profunctor
+import Data.Profunctor.Rep
+import Data.Profunctor.Sieve
+import Data.Profunctor.Traversing
+import Proton.Fold
+import Proton.Lens
+import Proton.Setter
+import Proton.Types
+
+type Traversal s t a b = forall p. (Traversing p) => p a b -> p s t
+type Traversal' s a = forall p. Traversing p => p a a -> p s s
+
+traversed :: Traversable f => Traversal (f a) (f b) a b
+traversed = traverse'
+
+filtered :: (a -> Bool) -> Traversal' a a
+filtered predicate = dimap partition (either id id) . left'
+  where
+    partition a
+        | predicate a = Left a
+        | otherwise = Right a
+
+traverseOf :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t
+traverseOf t = runStar . t . Star
+
+beside :: forall s t a b s' t' p r. (Representable p, Bitraversable r, Applicative (Rep p)) => Optic p s t a b -> Optic p s' t' a b -> Optic p (r s s') (r t t') a b
+beside t1 t2 p = tabulate go
+  where
+    go :: r s s' -> Rep p (r t t')
+    go rss = bitraverse (sieve $ t1 p) (sieve $ t2 p) rss
+
+
+unsafePartsOf :: forall s t a b. (forall p. Traversing p => p a b -> p s t) -> Lens s t [a] [b]
+unsafePartsOf t = lens getter setter'
+  where
+    getter :: s -> [a]
+    getter = toListOf t
+    setter' :: s -> [b] -> t
+    setter' s bs = flip evalState bs $ traverseOf t insert s
+    insert :: x -> State [b] b
+    insert _ = gets head <* modify tail
+
+partsOf :: forall s a. (forall p. Traversing p => p a a -> p s s) -> Lens' s [a]
+partsOf t = lens getter setter'
+  where
+    getter :: s -> [a]
+    getter = toListOf t
+    setter' :: s -> [a] -> s
+    setter' s as =
+        set (unsafePartsOf t) s (getZipList (ZipList as <|> ZipList (getter s)))
+
+taking :: forall q s a. Traversing q => Int -> (forall p. Traversing p => p a a -> p s s) -> Optic' q s a
+taking n t = partsOf t . wander go
+  where
+    go :: forall f x. Applicative f => (x -> f x) -> [x] -> f [x]
+    go handler as =
+      case splitAt n as of
+        (prefix, suffix) -> liftA2 (<>) (traverse handler prefix) (pure suffix)
+
+dropping :: forall s a. Int -> Traversal' s a -> Traversal' s a
+dropping n t = partsOf t . wander go
+  where
+    go :: Applicative f => (a -> f a) -> [a] -> f [a]
+    go handler as =
+      case splitAt n as of
+        (prefix, suffix) -> liftA2 (<>) (pure prefix) (traverse handler suffix)
+
+
+-- failing :: (forall p. Traversing p => p a b -> p s t) -> (forall p. Traversing p => p a b -> p s t) -> (Traversing p => p a b -> p s t)
+-- failing f _ pab = undefined $ foldMapOf f (const (Sum 1))
+    -- _ $ traverse' @_ @[] p
+
+-- both
+-- failing ()
diff --git a/src/Proton/Types.hs b/src/Proton/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Types.hs
@@ -0,0 +1,14 @@
+module Proton.Types where
+
+import Data.Profunctor.Indexed
+import Data.Profunctor.Coindexed
+
+type Optic p s t a b = p a b -> p s t
+type Optic' p s a = Optic p s s a a
+
+type Optical p q s t a b = p a b -> q s t
+type Optical' p q s a = Optical p q s s a a
+type IndexedOptic i q s t a b = forall p. Indexable i p q => Optical p q s t a b
+type IndexedOptic' i p s a = IndexedOptic i p s s a a
+type CoindexedOptic e p s t a b = Optical p (Coindexed e p) s t a b
+type CoindexedOptic' e p s a = CoindexedOptic e p s s a a
diff --git a/src/Proton/Wither.hs b/src/Proton/Wither.hs
new file mode 100644
--- /dev/null
+++ b/src/Proton/Wither.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Proton.Wither where
+
+import Data.Profunctor
+import Data.Profunctor.Withering
+import Control.Applicative
+import Proton.Types
+import Proton.Prisms
+
+type Wither s t a b = forall p. Withering p => Optic p s t a b
+type Wither' s a = Wither s s a a
+
+-- type Selector' s a = Selector s s a a
+-- type Selector s t a b = forall p. (Withering p, Depending p) => Optic p s t a b
+
+
+guarding :: Alternative f => (a -> Bool) -> a -> f a
+guarding p a
+    | p a = pure a
+    | otherwise = empty
+
+guarded :: forall a b. (a -> Bool) -> Wither a b a b
+guarded p = cull guarded'
+  where
+    guarded' :: forall f. Alternative f => (a -> f b) -> a -> f b
+    guarded' f a
+      | p a = f a
+      | otherwise = empty
+
+-- selectResult :: forall a b. (b -> Bool) -> Selector a b a b
+-- selectResult p = cull _collapse . depend check
+--   where
+--     -- collapse :: forall f. Alternative f => (a -> f (b)) -> a -> f b
+--     check :: forall f. Monad f => (a -> f b) -> a -> f (Maybe b)
+--     check f a = do
+--         f a >>= \b ->
+--             if p b then pure $ Just b
+--                    else pure $ Nothing
+
+filterOf :: Optic (Star Maybe) s t a a -> (a -> Bool) -> s -> Maybe t
+filterOf w p s = runStar (w (Star (guarding p))) s
+
+witherPrism :: forall p s t a b. Withering p => Prism s t a b -> Optic p s t a b
+witherPrism prsm =
+    withPrism prsm $ \embed match ->
+      let
+        go :: Alternative f => (a -> f b) -> s -> f t
+        go f s = 
+            case match s of
+                Left _ -> empty
+                Right a -> fmap embed $ f a
+      in cull go