The Comonad.Reader

catamorphism · only

newtype Later a = Later a deriving Functor
instance Applicative Later where
    pure = Later
    Later f < *> Later x = Later (f x)

lfix :: (Later a -> a) -> a
lfix f = fix (f . pure)

data Stream a =
    Nil
    | Cons a (Later (Stream a)

sinterleave :: Stream a -> Stream a -> Stream a
sinterleave = lfix $ \f s1 s2 -> case s1 of
    (Cons x xs) -> Cons x (f < *> pure s2 < *> xs)
    _ -> s2

repMin1 :: (Traversable t, Ord a) => t a -> t a
repMin1 xs =
     let (ans,m) = fmap minimum . runWriter $
                    traverse (\x -> tell [x] >> pure m) xs in ans

repMin2 :: (Traversable t, Ord a) => t a -> t a
repMin2 xs =
  let res = fix go in fst res
   where
    go res = fmap minimum . runWriter $
               traverse (\x -> tell [x] >> pure (snd res)) xs

repMin3 :: (Traversable t, Ord a) => t a -> t (Later a)
repMin3 xs =
  let res = lfix go in fst res
   where
    go res = fmap minimum . runWriter $
                traverse (\x -> tell [x] >> pure (snd < $> res)) xs

class Functor w => Comonad w where
    extract :: w a -> a
    duplicate :: w a -> w (w a)
    extend :: (w a -> b) -> w a -> w b

cfix f :: Comonad w => (w a -> a) -> w a
cfix f = fix (extend f)

lcfix :: Comonad w => (Later (w b) -> w a) -> (w a -> b) -> w b
lcfix conv f = lfix (extend f . conv)

lcfix2 :: (Comonad w, Predict w) => (w (Later a) -> a) -> w a
lcfix2 f = lfix (extend f . predict)

{-# language DeriveFunctor #-}

import Control.Comonad
import Data.Semigroup

data Store s a = Store
  { peek :: s -> a, pos :: s }
  deriving Functor

instance Comonad (Store s) where
  extract (Store f s) = f s
  duplicate (Store f s) = Store (Store f) s

instance
 (Semigroup s, Monoid s) =>
 Applicative (Store s) where
  pure a = Store (const a) mempty
  Store f s < *> Store g t = Store (\m -> f m (g m)) (mappend s t)

instance
 Semigroup s =>
 ComonadApply (Store s) where
  Store f s < @> Store g t = Store (\m -> f m (g m)) (s <> t)

instance
 (Semigroup s, Monoid s) =>
 Monad (Store s) where
  return = pure
  m >>= k = Store
    (\s -> peek (k (peek m s)) s)
    (pos m `mappend` pos (k (peek m mempty)))

newtype State s a = State
  { runState :: s -> (a, s) }
  deriving Functor

instance Applicative (State s) where
  pure a = State $ \s -> (a, s)
  State mf < *> State ma = State $ \s -> case mf s of
    (f, s') -> case ma s' of
      (a, s'') -> (f a, s'')

instance Monad (State s) where
  return = pure
  State m >>= k = State $ \s -> case m s of
    (a, s') -> runState (k a) s'

instance
 Monoid s =>
 Comonad (State s) where
  extract m = fst $ runState m mempty

  duplicate m = State $ \s ->
   (State $ \t -> runState m (mappend s t)
   , s
   )

extract (duplicate m)
= extract $ State $ \s -> (State $ \t -> runState m (mappend s t), s)
= State $ \t -> runState m (mappend s mempty)
= State $ \t -> runState m t
= State $ runState m
= m

fmap extract (duplicate m)
= fmap extract $ State $ \s -> (State $ \t -> runState m (mappend s t), s)
= State $ \s -> (extract $ State $ \t -> runState m (mappend s t), s)
= State $ \s -> (fst $ runState m (mappend s mempty), s)
= State $ \s -> (evalState m s, s)

  duplicate m = State $ \s ->
    ( State $ \t -> runState m (mappend s t)
    , snd $ runState m s
    )

extract (duplicate m)
= extract $ State $ \s -> (State $ \t -> runState m (mappend s t), snd $ runState m s)
= State $ \t -> runState m (mappend mempty t)
= State $ \t -> runState m t
= State $ runState m
= m

fmap extract (duplicate m)
= fmap extract $ State $ \s -> (State $ \t -> runState m (mappend s t), snd $ runState m s)
= State $ \s -> (extract $ State $ \t -> runState m (mappend s t), snd $ runState m s)
= State $ \s -> (fst $ runState m (mappend s mempty), snd $ runState m s)
= State $ \s -> (fst $ runState m s, snd $ runState m s)
= State $ \s -> runState m s
= State $ runState m
= m

instance Monoid s => ComonadApply (State s) where
  (< @>) = (< *>)

F ⊣ G ⊣ H
F ⊣ G, G ⊣ H

colim ⊣ Δ ⊣ lim

∃ ⊣ Const ⊣ ∀
Σ ⊣ Const ⊣ Π

Hom(FGA, B)     Hom(GFA, B)
    ~=              ~=
Hom(GA, GB)     Hom(FA, HB)
    ~=              ~=
Hom(A, HGB)     Hom(A, GHB)

FG ⊣ HG,  GF ⊣ GH

alg   : GFA -> A
coalg : A -> GHA

Σ Π : (A -> Type) -> Type
Const : Type -> (A -> Type)

ΣConst : Type -> Type
ΣConst B = A × B
ΠConst : Type -> Type
ΠConst B = A -> B

A × - ⊣ A -> -

forall x. f x -> g x

U : Func -> Con

F ⊣ U ⊣ C
F, C : Con -> Func

data F f a = forall e. F (e -> a) (f e)
newtype C f a = C (forall r. (a -> r) -> f r)

FU ⊣ CU : Func -> Func
UF ⊣ UC : Con -> Con

eta :: f a -> F f a
eta = F id

transform :: (forall x. f x -> g x) -> F f a -> F g a
transform tr (F g x) = F g (tr x)

mu :: F (F f) a -> F f a
mu (F g (F h x)) = F (g . h) x

epsilon :: C f a -> f a
epsilon (C e) = e id

transform' :: (forall x. f x -> g x) -> C f a -> C g a
transform' tr (C e) = C (tr . e)

delta :: C f a -> C (C f) a
delta (C e) = C $ \h -> C $ \g -> e (g . h)

alg :: forall e. (e -> a, f e) -> f a
alg (id, x) = x
alg (g . h, x) = alg (g, alg (h, x))

coalg :: f a -> forall r. (a -> r) -> f r
coalg x id = x
coalg x (g . h) = coalg (coalg x h) g

type Name = String

data Exp
  = Var Name
  | App Exp Exp
  | Lam Name Exp
  deriving (Eq,Show,Read)

main = do
  print $ Var "x"
  print $ Lam "x" (Var "x")
  print $ Lam "x" (Lam "y" (Var "x"))

Lam "x" (Var "y")

Lam "y" (Var "z")

Lam "y" (Lam "x" (Var "y"))

Lam "x" (Var "x")

Lam "y" (Var "y")

import Data.List (union, span, (\\))

type Name = String

data Exp
  = Var Name
  | App Exp Exp
  | Lam Name Exp
  deriving (Eq,Show,Read)

freeVars :: Exp -> [Name]
freeVars (Var x) = [x]
freeVars (App a b) = freeVars a `union` freeVars b
freeVars (Lam n x) = freeVars x \\ [n]

allVars :: Exp -> [Name]
allVars (Var x) = [x]
allVars (App a b) = allVars a `union` allVars b
allVars (Lam n x) = allVars x

subst :: Name -> Exp -> Exp -> Exp
subst x s b = sub vs0 b where
  sub _ e@(Var v)
    | v == x = s
    | otherwise = e
  sub vs e@(Lam v e')
    | v == x = e
    | v `elem` fvs = Lam v' (sub (v':vs) e'')
    | otherwise = Lam v (sub vs e') where
    v' = newId vs
    e'' = subst v (Var v') e'
  sub vs (App f a) = sub vs f `App` sub vs a
  fvs = freeVars s
  vs0 = fvs `union` allVars b

newId :: [Name] -> Name
newId vs = head (names \\ vs)

names :: [Name]
names = [ [i] | i <- ['a'..'z']] ++ [i : show j | j <- [1..], i <- ['a'..'z'] ]

-- show and we can see that this deals with capture avoidance
main = print $ subst "z" (Lam "x" (Var "y")) (Lam "y" (Var "z"))

data Exp a
  = Var a
  | Lam (Exp a -> Exp a)
  | App (Exp a) (Exp a)

main = putStrLn "It typechecks, but a Show instance here is hard!"

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Data.Foldable
import Data.Traversable

data Exp a
  = Free a
  | Bound !Int
  | App (Exp a) (Exp a)
  | Lam (Exp a)
  deriving (Eq,Show,Read,Functor,Foldable,Traversable)

main = putStrLn "It typechecks, but it is boring."

abstract :: Eq a => a -> Exp a -> Exp a
instantiate :: Exp a -> Exp a -> Exp a

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Data.Foldable
import Data.Traversable

newtype Scope f a = Scope (f a) deriving (Eq,Show,Read,Functor,Foldable,Traversable)
data Exp a
  = Free a
  | Bound !Int
  | App (Exp a) (Exp a)
  | Lam (Scope Exp a)

  deriving (Eq,Show,Read,Functor,Foldable,Traversable)
main = putStrLn "It typechecks, and is even slightly interesting."

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Data.Foldable
import Data.Traversable

newtype Scope f a = Scope (f a) deriving (Eq,Show,Read,Functor,Foldable,Traversable)
data Exp a
  = F a
  | B !Int
  | App (Exp a) (Exp a)
  | Lam (Scope Exp a)
  deriving (Eq,Show,Read,Functor,Foldable,Traversable)

abstract :: Eq a => a -> Exp a -> Scope Exp a
abstract me expr = Scope (letmeB 0 expr) where
  letmeB this (F you) | you == me = B this
                      | otherwise = F you
  letmeB this (B that)            = B that
  letmeB this (App fun arg)       = letmeB this fun `App` letmeB this arg
  letmeB this (Lam (Scope body))  = Lam $ Scope $ letmeB (succ this) body

instantiate :: Exp a -> Scope Exp a -> Exp a
instantiate what (Scope body) = what'sB 0 body where
  what'sB this (B that) | this == that = what
                        | otherwise    = B that
  what'sB this (F you)                 = F you
  what'sB this (App fun arg)           = what'sB this fun `App` what'sB this arg
  what'sB this (Lam (Scope body))      = Lam $ Scope $ what'sB (succ this) body

main = putStrLn "It typechecks, and is even slightly interesting."

Using these we can define combinators like

import Data.Foldable as Foldable
import Data.Traversable

closed :: Traversable f => f a -> Maybe (f b)
closed = traverse (const Nothing)

isClosed :: Foldable f => f a -> Bool
isClosed = Foldable.all (const False)

main = putStrLn "The types check out."

to check for closed terms, and we can use `Exp Void` directly as a closed term.

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Data.Foldable
import Data.Traversable

data Exp a
  = Var a
  | App (Exp a) (Exp a)
  | Lam (Exp (Maybe a))
  deriving (Functor, Foldable, Traversable)

instance Monad Exp where
  return = Var
  Var a >>= f = f a
  App l r >>= f = App (l >>= f) (r >>= f)
  Lam xs >>= f = undefined -- go for it!

main = print "Did you finish (>>=)?"

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Control.Monad
import Control.Monad.Trans
import Data.Foldable
import Data.Functor
import Data.Traversable

newtype Scope f a = Scope { runScope :: f (Maybe a) }
  deriving (Functor, Foldable, Traversable)

instance Monad f => Monad (Scope f) where
  return = Scope . return . Just
  Scope m >>= f = undefined -- go for it!

instance MonadTrans Scope where
  lift = Scope . liftM Just

main = print "Scope scopes out, but did you finish (>>=)?"

abstract :: (Functor f, Eq a) => a -> f a -> Scope f a
abstract x xs = Scope (fmap go xs) where
  go y = y <$ guard (x /= y)

instantiate :: Monad f => f a -> Scope f a -> f a
instantiate x (Scope xs) = xs >>= go where
  go Nothing = x
  go (Just y) = return y

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Control.Monad
import Control.Monad.Trans
import Data.Foldable
import Data.Functor
import Data.Traversable

newtype Scope f a = Scope { runScope :: f (Maybe a) }
  deriving (Functor, Foldable, Traversable)

instance Monad f => Monad (Scope f) where
  return = Scope . return . Just
  Scope m >>= f = Scope $ m >>= maybe (return Nothing) (runScope . f)

instance MonadTrans Scope where
  lift = Scope . liftM Just

abstract :: (Functor f, Eq a) => a -> f a -> Scope f a
abstract x xs = Scope (fmap go xs) where
  go y = y <$ guard (x /= y)

instantiate :: Monad f => f a -> Scope f a -> f a
instantiate x (Scope xs) = xs >>= go where
  go Nothing  = x
  go (Just y) = return y

data Exp a
  = Var a
  | App (Exp a) (Exp a)
  | Lam (Scope Exp a)
  deriving (Functor, Foldable, Traversable)

instance Monad Exp where
  return = Var
  Var a >>= f    = f a
  App l r >>= f  = App (l >>= f) (r >>= f)
  Lam body >>= f = Lam (body >>= lift . f)

main = putStrLn "Now we're getting somewhere!"

data Exp a
  = Var a
  | App (Exp a) (Exp a)
  | Lam (Exp (Maybe (Exp a)))

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Control.Monad
import Control.Monad.Trans
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.Traversable

newtype Scope f a = Scope { runScope :: f (Maybe (f a)) }
  deriving (Functor, Foldable, Traversable)

instance Monad f => Monad (Scope f) where
  return = Scope . return . Just . return
  Scope e >>= f = Scope $ e >>= \v -> case v of
    Nothing -> return Nothing
    Just ea -> ea >>= runScope . f

instance MonadTrans Scope where
  lift = Scope . return . Just

abstract :: (Monad f, Eq a) => a -> f a -> Scope f a
abstract a e = Scope (liftM k e) where
  k b = return b <$ guard (a /= b)

instantiate :: Monad f => f a -> Scope f a -> f a
instantiate k (Scope e) = e >>= fromMaybe k

main = putStrLn "Almost there!"

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Control.Monad
import Control.Monad.Trans
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.Traversable

-- show Var
data Var b a
  = B b
  | F a
  deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)

instance Monad (Var b) where
  return = F
  F a >>= f = f a
  B b >>= _ = B b

-- show Scope
newtype Scope b f a = Scope { runScope :: f (Var b (f a)) }
  deriving (Functor,Foldable,Traversable)

instance Monad f => Monad (Scope b f) where
  return = Scope . return . F . return
  Scope e >>= f = Scope $ e >>= \v -> case v of
    B b  -> return (B b)
    F ea -> ea >>= runScope . f

instance MonadTrans (Scope b) where
  lift = Scope . return . F

-- show Abstraction and Instantiation
abstract :: Monad f => (a -> Maybe b) -> f a -> Scope b f a
abstract f e = Scope (liftM k e) where
  k y = case f y of
    Just z  -> B z
    Nothing -> F (return y)

instantiate :: Monad f => (b -> f a) -> Scope b f a -> f a
instantiate k e = runScope e >>= \v -> case v of
  B b -> k b
  F a -> a

main = putStrLn "It typechecks, therefore it must be correct!"

This is a complete example syntax tree example that supports the use of `Foldable`/`Traversable`/`Monad`
to extract information about the free variables, and do capture-avoiding substitution!

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Data.Foldable
import Data.Traversable
import Bound

data Exp a
 = Var a
 | App (Exp a) (Exp a)
 | Lam (Scope () Exp a)
 | Let [Scope Int Exp a] (Scope Int Exp a)
 deriving (Functor,Foldable,Traversable)

instance Monad Exp where
  return = Var
  Var a >>= f = f a
  App l r >>= f = App (l >>= f) (r >>= f)
  Lam s >>= f = Lam (s >>>= f)
  Let xs b >>= f = Let (map (>>>= f) xs) (b >>>= f)

main = putStrLn "That's it!"

class Eq1 t where
  (==#) :: Eq a => t a -> t a -> Bool
  (/=#) :: Eq a => t a -> t a -> Bool

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Bound
import Control.Applicative
import Control.Monad
import Data.Foldable
import Data.Traversable
import Prelude.Extras

data Exp a
  = Var a
  | App (Exp a) (Exp a)
  | Lam (Scope () Exp a)
  deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)

instance Eq1 Exp
instance Ord1 Exp
instance Show1 Exp
instance Read1 Exp
instance Applicative Exp where
  pure = Var
  (<*>) = ap

instance Monad Exp where
  return = Var
  Var a   >>= f = f a
  App x y >>= f = App (x >>= f) (y >>= f)
  Lam e   >>= f = Lam (e >>>= f)

whnf :: Exp a -> Exp a
whnf (App f a) = case whnf f of
  Lam b -> whnf (instantiate1 a b)
  f'    -> App f' a
whnf e = e

lam :: Eq a => a -> Exp a -> Exp a
lam v b = Lam (abstract1 v b)

nf :: Exp a -> Exp a
nf e@Var{}   = e
nf (Lam b) = Lam $ toScope $ nf $ fromScope b
nf (App f a) = case whnf f of
  Lam b -> nf (instantiate1 a b)
  f' -> nf f' `App` nf a

main = putStrLn "It compiles"

lam :: Eq a => a -> Exp a -> Exp a
lam v b = Lam (abstract1 v b)

whnf :: Exp a -> Exp a
whnf (App f a) = case whnf f of
  Lam b -> whnf (instantiate1 a b)
  f'    -> App f' a
whnf e = e

nf :: Exp a -> Exp a
nf e@V{}   = e
nf (Lam b) = Lam $ toScope $ nf $ fromScope b
nf (App f a) = case whnf f of
  Lam b -> nf (instantiate1 a b)
  f' -> nf f' `App` nf a

class Bound t where
  (>>>=) :: Monad f => t f a -> (a -> f b) -> t f b
  default (>>>=) :: (MonadTrans t, Monad f) => t f a -> (a -> f b) -> t f b
  m >>>= f = m >>= lift . f

m >>>= return ≡ m

m >>>= (λ x → k x >>= h) ≡ (m >>>= k) >>>= h

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}

{-# LANGUAGE GADTs, Rank2Types, KindSignatures, ScopedTypeVariables, TypeOperators, DataKinds, PolyKinds, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, DoRec, ExtendedDefaultRules #-}

import Control.Applicative
import Control.Category
import Control.Comonad
import Control.Monad.Fix
import Control.Monad (ap)
import Data.Functor.Identity
import Data.Typeable
import Data.Monoid
import Data.Unique
import System.IO.Unsafe
import Unsafe.Coerce
import Prelude hiding ((.),id)

infixl 1 >>>-, >>-

type Nat f g = forall x. f x -> g x

class HFunctor t where
  hmap :: Nat f g -> Nat (t f) (t g)

class HFunctor t => HTraversable t where
  htraverse :: Applicative m => (forall x. f x -> m (g x)) -> t f a -> m (t g a)

class HFunctor t => HMonad t where
  hreturn :: Nat f (t f)
  (>>-)   :: t f a -> Nat f (t g) -> t g a

infixr 1 -<<
(-<<) :: HMonad t => Nat f (t g) -> Nat (t f) (t g)
f -<< m = m >>- f

class HBound s where
  (>>>-) :: HMonad t => s t f a -> Nat f (t g) -> s t g a

class HMonadTrans s where
  hlift :: HMonad t => Nat (t f) (s t f)

data Var b f a where
  B :: b a -> Var b f a
  F :: f a -> Var b f a

instance HFunctor (Var b) where
  hmap _ (B b) = B b
  hmap f (F a) = F (f a)

instance HTraversable (Var b) where
  htraverse _ (B b) = pure (B b)
  htraverse f (F a) = F <$> f a

instance HMonad (Var b) where
  hreturn   = F
  B b >>- _ = B b
  F a >>- f = f a

newtype Scope b t f a = Scope { unscope :: t (Var b (t f)) a }

instance HFunctor t => HFunctor (Scope b t) where
  hmap f (Scope b) = Scope (hmap (hmap (hmap f)) b)

instance HTraversable t => HTraversable (Scope b t) where
  htraverse f (Scope b) = Scope <$> htraverse (htraverse (htraverse f)) b

instance HMonad t => HMonad (Scope b t) where
  hreturn = Scope . hreturn . F . hreturn
  Scope e >>- f  = Scope $ e >>- \v -> case v of
    B b -> hreturn (B b)
    F ea -> ea >>- unscope . f

instance HMonadTrans (Scope b) where
  hlift = Scope . hreturn . F

instance HBound (Scope b) where
  Scope m >>>- f = Scope (hmap (hmap (>>- f)) m)

data Equal a b where
   Refl :: Equal a a

instance Category Equal where
  id = Refl
  Refl . Refl = Refl

abstract :: HMonad t => (forall x. f x -> Maybe (b x)) -> Nat (t f) (Scope b t f)
abstract f = Scope . hmap (\y -> case f y of
  Just b -> B b
  Nothing -> F (hreturn y))

instantiate :: HMonad t => Nat b (t f) -> Nat (Scope b t f) (t f)
instantiate k (Scope e) = e >>- \v -> case v of
  B b -> k b
  F a -> a

data Ix :: [*] -> * -> * where
  Z :: Ix (a ': as) a
  S :: Ix as b -> Ix (a ': as) b

data Vec :: (* -> *) -> [*] -> * where
  HNil :: Vec f '[]
  (:::) :: f b -> Vec f bs -> Vec f (b ': bs)

infixr 5 :++, :::

type family (:++) (as :: [*]) (bs :: [*]) :: [*]
type instance '[] :++ bs = bs
type instance (a ': as) :++ bs = a ': (as :++ bs)

happend :: Vec f as -> Vec f bs -> Vec f (as :++ bs)
happend HNil bs = bs
happend (a ::: as) bs = a ::: happend as bs

hsingleton :: f a -> Vec f '[a]
hsingleton x = x ::: HNil

instance HFunctor Vec where
  hmap _ HNil = HNil
  hmap f (x ::: xs) = f x ::: hmap f xs

instance HTraversable Vec where
  htraverse _ HNil = pure HNil
  htraverse f (x ::: xs) = (:::) <$> f x <*> htraverse f xs

class EqF f where
  (==?) :: f a -> f b -> Maybe (Equal a b)

data Lit t where
  Integer :: Integer -> Lit Integer
  Double  :: Double -> Lit Double
  String :: String -> Lit String

instance EqF Lit where
  Integer a ==? Integer b = Just Refl
  ...

value :: Lit a -> a
value (Integer i) = i
value (Double d) = d
value (String s) = s

class Literal a where
  literal :: a -> Lit a

instance Literal Integer where
  literal = Integer

instance Literal String where
  literal = String

data Remote :: (* -> *) -> * -> * where
  Var :: f a -> Remote f a
  Lit :: Lit a -> Remote f a
  Lam :: Scope (Equal b) Remote f a -> Remote f (b -> a)
  Let :: Vec (Scope (Ix bs) Remote f) bs -> Scope (Ix bs) Remote f a -> Remote f a
  Ap  :: Remote f (a -> b) -> Remote f a -> Remote f b

lam_ :: EqF f => f a -> Remote f b -> Remote f (a -> b)
lam_ v f = Lam (abstract (v ==?) f)

lit :: Literal a => a -> Remote f a
lit = Lit . literal

instance HFunctor Remote where
  hmap f (Var a)    = Var (f a)
  hmap _ (Lit t)    = Lit t
  hmap f (Lam b)    = Lam (hmap f b)
  hmap f (Let bs b) = Let (hmap (hmap f) bs) (hmap f b)
  hmap f (Ap x y)   = Ap (hmap f x) (hmap f y)

instance HTraversable Remote where
  htraverse f (Var a)    = Var <$> f a
  htraverse _ (Lit t)    = pure $ Lit t
  htraverse f (Lam b)    = Lam <$> htraverse f b
  htraverse f (Let bs b) = Let <$> htraverse (htraverse f) bs <*> htraverse f b
  htraverse f (Ap x y)   = Ap <$> htraverse f x <*> htraverse f y

data MyF a where
  Mean :: MyF (Double -> Double)

instance HMonad Remote where
  hreturn        = Var
  Var a    >>- f = f a
  Lit t    >>- _ = Lit t
  Lam b    >>- f = Lam (b >>>- f)
  Let bs b >>- f = Let (hmap (>>>- f) bs) (b >>>- f)
  Ap x y   >>- f = Ap (x >>- f) (y >>- f)

(!) :: Vec f v -> Ix v a -> f a
(b ::: _)  ! Z   = b
(_ ::: bs) ! S n = bs ! n

eval :: Remote Identity a -> a
eval (Var w) = extract w
eval (Lit i) = value i
eval (Lam b) = \a -> eval (instantiate (\Refl -> Var (Identity a)) b)
eval (Let bs b) = eval (instantiate (vs !) b) where vs = hmap (instantiate (vs !)) bs
eval (Ap x y) = eval x (eval y)

closed :: HTraversable t => t f a -> Maybe (t g a)
closed = htraverse (const Nothing)

newtype V (a :: *) = V Unique

instance EqF V where
  V a ==? V b
    | a == b    = Just (unsafeCoerce Refl)
    | otherwise = Nothing

lam :: (Remote V a -> Remote V b) -> Remote V (a -> b)
lam f = unsafePerformIO $ do
  x <- fmap V newUnique
  return $ Lam $ abstract (x ==?) $ f $ Var x

data Binding a = V a := Remote V a

rhs :: Binding a -> Remote V a
rhs (_ := a) = a

data Bindings = forall bs. Bindings (Vec Binding bs)

elemIndex :: Vec Binding bs -> V a -> Maybe (Ix bs a)
elemIndex HNil              _ = Nothing
elemIndex ((x := r) ::: xs) y = case x ==? y of
  Just Refl -> Just Z
  Nothing   -> S <$> elemIndex xs y

instance Monoid Bindings where
  mempty = Bindings HNil
  Bindings xs `mappend` Bindings ys = Bindings (happend xs ys)

-- Allow the use of DoRec to define let statements

newtype Def a = Def { runDef :: IO (a, Bindings) }

instance Functor Def where
  fmap f (Def m) = Def $ do
    (a,w) <- m
    return (f a, w)

instance Applicative Def where
  pure = return
  (<*>) = ap

instance Monad Def where
  return a = Def $ return (a, mempty)
  Def m >>= f = Def $ do
    (a, xs) <- m
    (b, ys) <- runDef (f a)
    return (b, xs <> ys)

instance MonadFix Def where
  mfix m = Def $ mfix $ \ ~(a, _) -> runDef (m a)

def :: Remote V a -> Def (Remote V a)
def v@Var{} = Def $ return (v, mempty) -- this thing already has a name
def r = Def $ do
  v <- fmap V newUnique
  return (Var v, Bindings (hsingleton (v := r)))

let_ :: Def (Remote V a) -> Remote V a
let_ (Def m) = unsafePerformIO $ do
    (r, Bindings bs) <- m
    return $ Let (hmap (abstract (elemIndex bs) . rhs) bs)
                 (abstract (elemIndex bs) r)

class Num a => IntegralDomain a

instance IntegralDomain Integer
instance IntegralDomain Rational
instance IntegralDomain Float
instance IntegralDomain Double

F(N) = X*F(N-1) + Y*(F(N-2))

leo n = leonardo n + 1 = leonardo (n-1) + leonardo (n-2) + 2 = leo (n-1) + leo (n-2)

leo n = 2 * fib (n+1)

leonardo n = 2 * fib (n+1) - 1

φ = (1+√5)/2

φ^2 = φ+1

(aφ+b)(cφ+d) = ac(φ+1) + (ad+bc)φ + bd = (ac+ad+bc)φ + (ac+bd) = (a(c+d)+bc)φ + (ac+bd)

data Fib a = Fib a a deriving
  (Show, Functor, Foldable, Traversable, Eq)

instance IntegralDomain a => Num (Fib a) where
  Fib a b + Fib c d = Fib (a + c) (b + d)
  Fib a b * Fib c d = Fib (a*(c + d) + b*c) (a*c + b*d)
  Fib a b - Fib c d = Fib (a - c) (b - d)
  negate (Fib a b) = Fib (negate a) (negate b)
  abs x = x
  signum _ = Fib 0 1 -- meh
  fromInteger n = Fib 0 (fromInteger n)

instance IntegralDomain a => IntegralDomain (Fib a)

φ = Fib 1 0

class (IntegralDomain a, Fractional a) => Field a
instance (IntegralDomain a, Fractional a) => Field a

instance (IntegralDomain a, Fractional a) => Fractional (Fib a) where
  recip (Fib a b) = Fib (-a/d) ((a+b)/d) where
    d = b*b + a*b - a*a
  fromRational r = Fib 0 (fromRational r)

φ^2 = φ+1

φ = φ^(-1) * φ^2 = φ^(-1) * (φ+1) = 1 + φ^(-1)

φ^(-1) = φ - 1

recip φ = recip (Fib 1 0) = Fib (-1 / -1) (1/ -1) = Fib (-1 * -1) (1 * -1) = Fib 1 (-1)

√5 = 2*φ - 1

instance (IntegralDomain a, Ord a) => Ord (Fib a) where
  compare (Fib a b) (Fib c d) = case compare a c of
    LT | b <= d    -> LT
       | otherwise -> go compare (a-c) (b-d)
    EQ -> compare b d
    GT | b >= d    -> GT
       | otherwise -> go (flip compare) (a-c) (b-d)
   where
     go k e f = k (sq (e+2*f)) (5*sq e)
     sq x = x*x

instance (IntegralDomain a, Ord a) => Eq (Fib a) where
  x == y = compare x y == EQ

instance Applicative Fib where
  pure a = Fib a a
  Fib a b <*> Fib c d = Fib (a c) (b d)

instance Monad Fib where
  return a = Fib a a
  Fib a b >>= f = Fib a' b' where
    Fib a' _ = f a
    Fib _ b' = f b

instance MonadZip Fib where
  mzipWith f (Fib a b) (Fib c d) = Fib (f a c) (f b d)
  munzip (Fib (a,b) (c,d)) = (Fib a c, Fib b d)

instance Additive Fib where
  zero = Fib 0 0
  (^+^) = (+)
  (^-^) = (-)

  Fib a b * Fib c d = Fib (a*(c + d) + b*c) (a*c + b*d)

Fib a b * φ = Fib a b * Fib 1 0 = Fib (a*(1+0)+b*1) (a*1 + b*0) = Fib (a+b) a

Fib (fib n) (fib (n-1)) * φ = Fib (fib (n+1)) (fib n)

getPhi :: Fib a -> a
getPhi (Fib a _) = a

-- | Compute the nth Fibonacci number in O(log n)
fib :: IntegralDomain a => Integer -> a
fib n
  | n >= 0 = getPhi (Fib 1 0 ^ n)
  | otherwise = getPhi (Fib 1 (-1) ^ negate n)

search :: (Natural -> Bool) -> Natural
search p
  | p 0 = 0
  | otherwise = bound 0 1
  where
    bound !a !b
     | p b = go 0 a b
     | bb <- b*b = bound (a*a+bb) (bb+2*a*b)
    -- the answer lies in the interval (l,l+k], i,j,k are consecutive Fibonacci numbers.
    go !l !j !k
      | k == 1    = l + 1
      | p m       = go l (j-i) i
      | otherwise = go m i j
      where
        m = l + i
        i = k - j

>>> search (>12389012380128301283012381203912380192830123801283120931203)
12389012380128301283012381203912380192830123801283120931204

lca D E = A
lca F I = E
lca G H = G
lca H J = E

type Id = Int

data Path = [Id] :# !Int

empty :: Path
empty = [] :# 0

cons :: Id -> Path -> Path
cons a (ys :# n) = (a:ys) :# (n + 1)

x = [5,4,3,2,1] :# 5
y =   [6,3,2,1] :# 4

x' = [4,3,2,1] :# 4
y' = [6,3,2,1] :# 4

lca x y = [3,2,1] :# 3

lca :: Path -> Path -> Path
lca (xs0 :# i) (ys0 :# j) = go k (drop (i-k) xs0) (drop (j-k) ys0) where
  k = min i j
  go !n xxs@(x:xs) (y:ys)
    | x == y   = xxs :# n
    | otherwse = go (n - 1) xs ys

data Nat    = Zero | Succ    Nat
data IdList = Nil  | Cons Id IdList

n     731                      n
--    ---                      --
 0:   000 --                    0
 1:   001 --             1*1 =  1
 2:   002 --             2*1 =  2
 3:   010 --       1*3       =  3
 4:   011 --       1*3 + 1*1 =  4
 5:   012 --       1*3 + 2*1 =  5
 6:   020 --       2*3       =  6
 7:   100 -- 1*7             =  7
 8:   101 -- 1*7    +    1*1 =  8
 9:   102 -- 1*7    +    2*1 =  9
10:   110 -- 1*7 + 1*3       = 10
11:   111 -- 1*7 + 1*3 + 1*1 = 11
12:   112 -- 1*7 + 1*3 + 2*1 = 12
13:   120 -- 1*7 + 2*3       = 13
14:   200 -- 2*7             = 14
...

data Skew = Two !Int Skew | One !Int Skew | Zero

succ :: Skew -> Skew
succ (Two x (One y ys)) | x*2+1 == y = Two y ys
succ (Two x xs) = One (x*2+1) xs
succ (One 1 xs) = Two 1 xs
succ xs         = One 1 xs

data Skew = One !Int Skew | Zero

type Skew = [Int]

succ :: Skew -> Skew
succ (x:y:zs) | x == y = x+y+1 : zs
succ xs = 1:xs

data Tree
  = Tip
  | Bin !Int !Id Tree Tree

size :: Tree -> Int
size (Tip _) = 1
size (Bin n _ _ _) = n

type Path = [Tree]

cons :: Id -> Path -> Path
cons a (x:y:zs) | size x == size y = Bin (size x*2+1) a x y : zs
cons a xs = Tip a : xs

data Path
  = Nil
  | Cons !Int -- `n` entries in this path
         !Int -- `w` entries in this particular tree
         Tree -- a complete tree with @w@ elements
         Path
  deriving (Show, Read)

data Tree
  = Bin !Id Tree Tree
  | Tip !Id
  deriving (Show, Read)

consT :: Int -> Tree -> Path -> Path
consT w t ts = Cons (w + size ts) w t ts

cons :: Id -> Path -> Path
cons k (Cons n w t (Cons _ w' t2 ts))
  | w == w' = Cons (n + 1) (2 * w + 1) (Bin k t t2) ts
cons k ts = Cons (size ts + 1) 1 (Tip k) ts

uncons :: Path -> Maybe (Id, Path)
uncons Nil = Nothing
uncons (Cons _ _ (Tip k) ts)     = Just (k, ts)
uncons (Cons _ w (Bin k l r) ts) = Just (k, consT w2 l (consT w2 r ts))
  where w2 = div w 2

keep k (xs :# n) = drop (n-k) xs :# max 0 (n-k)

keep :: Int -> Path -> Path
keep _ Nil = Nil
keep k xs@(Cons n w t ts)
  | k >= n = xs
  | otherwise = case compare k (n - w) of
     GT -> keepT (k - n + w) w t ts
     EQ -> ts
     LT -> keep k ts

keepT :: Int -> Int -> Tree -> Path -> Path
keepT n w (Bin _ l r) ts = case compare n w2 of
  LT -> keepT n w2 r ts
  EQ -> consT w2 r ts
  GT | n == w - 1 -> consT w2 l (consT w2 r ts)
     | otherwise -> keepT (n - w2) w2 l (consT w2 r ts)
 where w2 = div w 2
keepT _ _ _ ts = ts

instance Eq Path where
  Nil == Nil = True
  Cons _ _ s _ == Cons _ _ t _ = s == t

instance Eq Tree where
  Tip a     == Tip b     = a == b
  Bin a _ _ == Bin b _ _ = a == b
  _         == _         = False

lca' :: Path -> Path -> Path
lca' h@(Cons _ w x xs) (Cons _ _ y ys)
  | x == y = h
  | xs == ys = lcaT w x y ys
  | otherwise = lca' xs ys
lca' _ _ = Nil

lcaT :: Int -> Tree -> Tree -> Path -> Path
lcaT w (Bin _ la ra) (Bin _ lb rb) ts
  | la == lb = consT w2 la (consT w2 ra ts)
  | ra == rb = lcaT w2 la lb (consT w ra ts)
  | otherwise = lcaT w2 ra rb ts
  where w2 = div w 2
lcaT _ _ _ ts = ts

lca :: Path -> Path -> Path
lca xs ys = case compare nxs nys of
  LT -> lca' xs (keep nxs ys)
  EQ -> lca' xs ys
  GT -> lca' (keep nys xs) ys
 where
  nxs = size xs
  nys = size ys

import Data.List (unfoldr)
type Id = Int

data Tree
  = Bin {-# UNPACK #-} !Id Tree Tree
  | Tip {-# UNPACK #-} !Id
  deriving (Show, Read)

instance Eq Tree where
  Tip a     == Tip b     = a == b
  Bin a _ _ == Bin b _ _ = a == b
  _         == _         = False

data Path
  = Nil
  | Cons {-# UNPACK #-} !Int
         {-# UNPACK #-} !Int
         Tree
         Path
  deriving (Show, Read)

instance Eq Path where
  Nil == Nil = True
  Cons _ _ s _ == Cons _ _ t _ = s == t

size :: Path -> Int
size Nil = 0
size (Cons n _ _ _) = n

consT :: Int -> Tree -> Path -> Path
consT w t ts = Cons (w + size ts) w t ts

cons :: Id -> Path -> Path
cons k (Cons n w t (Cons _ w' t2 ts))
  | w == w' = Cons (n + 1) (2 * w + 1) (Bin k t t2) ts
cons k ts = Cons (size ts + 1) 1 (Tip k) ts

uncons :: Path -> Maybe (Id, Path)
uncons Nil = Nothing
uncons (Cons _ _ (Tip k) ts)     = Just (k, ts)
uncons (Cons _ w (Bin k l r) ts) = Just (k, consT w2 l (consT w2 r ts))
  where w2 = div w 2

keep :: Int -> Path -> Path
keep _ Nil = Nil
keep k xs@(Cons n w t ts)
  | k >= n = xs
  | otherwise = case compare k (n - w) of
     GT -> keepT (k - n + w) w t ts
     EQ -> ts
     LT -> keep k ts

keepT :: Int -> Int -> Tree -> Path -> Path
keepT n w (Bin _ l r) ts = case compare n w2 of
  LT -> keepT n w2 r ts
  EQ -> consT w2 r ts
  GT | n == w - 1 -> consT w2 l (consT w2 r ts)
     | otherwise -> keepT (n - w2) w2 l (consT w2 r ts)
 where w2 = div w 2
keepT _ _ _ ts = ts

lca' :: Path -> Path -> Path
lca' h@(Cons _ w x xs) (Cons _ _ y ys)
  | x == y = h
  | xs == ys = lcaT w x y ys
  | otherwise = lca' xs ys
lca' _ _ = Nil

lcaT :: Int -> Tree -> Tree -> Path -> Path
lcaT w (Bin _ la ra) (Bin _ lb rb) ts
  | la == lb = consT w2 la (consT w2 ra ts)
  | ra == rb = lcaT w2 la lb (consT w ra ts)
  | otherwise = lcaT w2 ra rb ts
  where w2 = div w 2
lcaT _ _ _ ts = ts

lca :: Path -> Path -> Path
lca xs ys = case compare nxs nys of
  LT -> lca' xs (keep nxs ys)
  EQ -> lca' xs ys
  GT -> lca' (keep nys xs) ys
 where
  nxs = size xs
  nys = size ys

fromList :: [Int] -> Path
fromList = foldr cons Nil

toList :: Path -> [Int]
toList = unfoldr uncons

xs = fromList [6,4,3,2,1]
ys = fromList [5,3,2,1]

main = print $ toList (lca xs ys)

data DLL = DLL (IORef (Maybe DLL)) (IORef (Maybe DLL))

DLL ~> IORef (Maybe DLL) ~> MutVar# RealWorld (Maybe DLL) ~> Maybe DLL ~> DLL

data DLL = DLL !(IORef DLL) !(IORef DLL) | Nil

DLL ~> MutVar# RealWorld DLL ~> DLL

data DLL = DLL (MutableArray# RealWorld DLL) | Nil

data DLL = DLL (SmallMutableArray# RealWorld DLL) | Nil

data DLL = DLL (MutableArrayArray# RealWorld)

next :: DLL -> IO DLL
next (DLL m) = IO $ \s -> case readMutableArrayArray# s of
   (# s', n #) -> (# s', DLL n #)

data DLL = DLL !Int !(IORef DLL) !(IORef DLL) | Nil

swap (x, y) = (y, x)

setup = do
  r1 < - newIORef True
  r2 <- newIORef True
  v1 <- unsafeInterleaveIO $ do writeIORef r2 False ; readIORef r1
  v2 <- unsafeInterleaveIO $ do writeIORef r1 False ; readIORef r2
  return (v1, v2)

main = do
  p1 <- setup
  p2 <- setup
  print p1
  print . swap $ p2

(True, False)
(True, False)

f e e

let x = e in f x x

main = let m = setup
  in do p1 < - m
        p2 <- m
        print p1
        print . swap $ p2

unsafeInterleaveIO :: IO a -> IO a
unsafeInterleaveIO action = do
  iv < - new
  forkIO $
    randomRIO (1,5) >>= threadDelay . (*1000) >>
    action >>= write iv
  return . read $ iv

new :: IO (IVar a)
write :: IVar a -> a -> IO ()
read :: IVar a -> a

deref = runPar . get

randomDelay = randomRIO (1,10) >>= threadDelay . (1000*)

myHandle m = m `catch` \(_ :: SomeExpression) -> putStrLn "Bombed"

mySpawn :: IO a -> IO (IVar a)
mySpawn action = do
  iv < - runParIO new
  forkIO $ randomDelay >> action >>= runParIO . put_ iv
  return iv

main = do
  iv < - mySpawn (return True)
  myHandle . print $ deref iv
  randomDelay
  myHandle . print $ deref iv

data Moore a b = Moore b (a -> Moore a b)

data Cofree f a = Cofree a (f (Cofree f a))

data Fix f = In { out :: f (Fix f) }

ana :: Functor f => (s -> f s) -> s -> Nu f

data Nu f where
  Nu :: (s -> f s) -> s -> Nu f

ana = Nu

Cofree f b =
Nu (Compose ((,) b) f) =
∃s. (s -> Compose ((,) b) f s, s) =
∃s. (s -> (b, f s), s) =
∃s. (s -> b, s -> f s, s)

Moore a b =
Cofree ((->) a) b =
∃s. (s -> b, s -> a -> s, s)

data Moore a b where
  Moore :: (s -> b) -> (s -> a -> s) -> s -> Moore a b

class Functor g => Distributive g where
  distribute :: Functor f => f (g a) -> g (f a)
  collect :: Functor f => (a -> g b) -> f a -> g (f b)

class Distributive f => Representable f where
  type Rep f
  tabulate :: (Rep f -> a) -> f a
  index :: f a -> Rep f -> a

instance Representable ((->) x) where
  type Rep ((->) x) = x
  tabulate = id
  index = id

data Cofree f a where
  Cofree :: Representable k => k a -> k (f (Rep k)) -> Rep k -> Cofree f a

instance Functor (Cofree f) where
  fmap f (Cofree k u s) = Cofree (fmap f k) u s

instance Comonad (Cofree f) where
  extract (Cofree k _ s) = index k s
  duplicate (Cofree k u s) = Cofree (tabulate (Cofree k u)) u s

data Moore a b where
  Moore :: Representable k => k b -> k (a -> Rep k) -> Rep k -> Moore a b

data Moore a b where
  Moore :: Representable k => k b -> (a -> k (Rep k)) -> Rep k -> Moore a b

instance Functor (Moore a) where
  fmap f (Moore k u b) = Moore (fmap f k) u b

instance Comonad (Moore a) where
  extract (Moore k _ s)   = index k s
  duplicate (Moore k u s) = Moore (tabulate (Moore k u)) u s
  extend f (Moore k u s)  = Moore (tabulate (f . Moore k u)) u s

instance Representable Identity where
  type Rep Identity = ()
  tabulate f = Identity (f ())
  index (Identity a) () = a

instance (Representable f, Representable g) => Representable (Compose f g) where
  type Rep (Compose f g) = (Rep f, Rep g)
  index (Compose fg) (i,j) = index (index fg i) j
  tabulate = Compose . tabulate . fmap tabulate . curry

instance Applicative (Moore a) where
  pure a = Moore (Identity a) (\_ -> Identity ()) ()
  Moore kf uf sf <*> Moore ka ua sa =
    Moore (Compose ((<$> ka) <$> kf))
          (\x -> Compose $ (\y -> (,) y <$> ua x) <$> uf x)
          (sf, sa)

instance ComonadApply (Moore a) where
  (<@>) = (<*>)

instance Profunctor Moore where
  dimap f g (Moore k u s) = Moore (g <$> k) (u . f) s

step1 :: a -> Moore a b -> b
step1 a (Moore k u s) = index k (index (u a) s)

step :: a -> Moore a b -> Moore a b
step a (Moore k u s) = Moore k u (index (u a) s)

newtype Tab f = Tab { getTab :: f (Rep f) }

instance Representable f => Monoid (Tab f) where
  mempty = Tab $ tabulate id
  mappend (Tab fs) (Tab gs) = Tab (index gs <$> fs)

feed :: Foldable f => f a -> Moore a b -> Moore a b
feed as (Moore k u s) = Moore k u (index (getTab $ foldMap (Tab . u) as) s)

data Token a = Token {-# UNPACK #-} !Int a deriving (Eq, Ord)
data LZ78 a
  = Cons {-# UNPACK #-} !(Token a) (LZ78 a)
  | Nil

encodeEq :: Eq a => [a] -> LZ78 a
encodeEq = go [] 1 0 where
  go _ _ _ [] = Nil
  go _ _ p [c] = Cons (Token p c) Nil
  go d f p (c:cs) = let t = Token p c in case List.lookup t d of
    Just p' -> go d f p' cs
    Nothing -> Cons t (go ((t, f):d) (succ f) 0 cs)

encodeOrd :: Ord a => [a] -> LZ78 a
encodeOrd = go Map.empty 1 0 where
  go _ _ _ [] = Nil
  go _ _ p [c] = Cons (Token p c) Nil
  go d f p (c:cs) = let t = Token p c in case Map.lookup t d of
    Just p' -> go d f p' cs
    Nothing -> Cons t (go (Map.insert t f d) (succ f) 0 cs)

encode :: (Hashable a, Eq a) => [a] -> LZ78 a
encode = go HashMap.empty 1 0 where
  go _ _ _ [] = Nil
  go _ _ p [c] = Cons (Token p c) Nil
  go d f p (c:cs) = let t = Token p c in case HashMap.lookup t d of
    Just p' -> go d f p' cs
    Nothing -> Cons t (go (HashMap.insert t f d) (succ f) 0 cs)

instance Foldable LZ78 where
  foldMap f = go (Seq.singleton mempty) mempty where
    go _ m Nil = m
    go s m (Cons (Token w c) ws) = m `mappend` go (s |> v) v ws where
      v = Seq.index s w `mappend` f c

class (Functor f, Representable g) => f -| g where
  leftAdjunct :: (f a -> b) -> a -> g b
  rightAdjunct :: (a -> g b) -> f a -> b

Moore :: (f -| g) => g b -> f (a -> g (f ())) -> Moore a b
Moore :: (f -| g) => g b -> f (g (a -> f ())) -> Moore a b
Moore :: (f -| g) => f (g b) -> (a -> g (f ())) -> Moore a b

(-> r) -| (-> r)

Wat :: (b -> r -> r) -> a -> (() -> r) -> r

type Transducer a b = forall r. (b -> r -> r) -> (a -> r -> r)

>>> :t foldl
foldl :: (b -> a -> b) -> b -> [a] -> b
>>> :t foldl.foldl
foldl.foldl :: (b -> a -> b) -> b -> [[a]] -> b
...

type Transducer a b = forall f. Representable f => (b -> f (Rep f)) -> a -> f (Rep f)

type Transducer a b = forall f. Representable f => (b -> Tab f) -> a -> Tab f

transduce :: Moore b c -> Transducer a b -> Moore a c
transduce (Moore k u s) t = Moore k (getD #. t (D #. u)) s

type Transducer a b = forall f. Monoid m => (b -> m) -> a -> m

type Fold a b = forall f. (Contravariant f, Applicative f) => (b -> f b) -> a -> f a

newtype Set f = Set { getSet :: f Bool }

instance Representable f => Monoid (Set f) where
  mempty = Set $ tabulate (const False)
  mappend (Set as) (Set bs) = Set $ tabulate $ \i -> index as i || index bs i

singleton :: (Representable f, Eq (Rep f)) => Rep f -> Set f
singleton i = Set $ tabulate (i==)

insert :: (Representable f, Eq (Rep f)) => Rep f -> Set f -> Set f
insert i (Set is) = Set $ tabulate $ \j -> index is j || (i==j)

contains :: Set f -> Rep f -> Bool
contains (Set is) i = index is i

newtype N f = N { getN :: f (Set f) }

newtype Transformer f g = Transform { ($$) :: forall i. f i ~> g i }

type family (~>) :: k -> k -> * where
  (~>) = (->)
  (~>) = Transformer

type a < -> b = (a -> b, b -> a)
type a < ~> b = (a ~> b, b ~> a)

  Int ~> Char = Int -> Char
  Maybe ~> [] = forall a. Maybe a -> [a]
  Either ~> (,) = forall a b. Either a b -> (a, b)
  StateT ~> ReaderT = forall s m a. StateT s m a -> ReaderT s m a

class Morph (p :: k -> k -> *) where
  id :: p a a
  (.) :: p b c -> p a b -> p a c

instance Morph (->) where
  id x = x
  (g . f) x = g (f x)

instance Morph ((~>) :: k -> k -> *)
      => Morph (Transformer :: (i -> k) -> (i -> k) -> *) where
  id = Transform id
  Transform f . Transform g = Transform $ f . g

  k = *
  σ = Monoid :: * -> Constraint

  Sum Integer, Product Integer, [Integer] :: (*, Monoid)

  f :: (Monoid m, Monoid n) => m -> n
    if f mempty = mempty
       f (m <> n) = f m <> f n

  Forget σ :: (k,σ) -> k
  Free   σ :: k -> (k,σ)
  Cofree σ :: k -> (k,σ)

  Free σ ⊣ Forget σ ⊣ Cofree σ

  p : C -> C'
  f : C -> D
  Ran p f : C' -> D
  Lan p f : C' -> D

  Ran p f c' = end (c : C). Hom_C'(c', p c) ⇒ f c
  Lan p f c' = coend (c : c). Hom_C'(p c, c') ⊗ f c

  if L ⊣ R
  then L = Ran R Id and R = Lan L Id

  if Ran R Id exists and is absolute
  then Ran R Id ⊣ R

  if Lan L Id exists and is absolute
  then L ⊣ Lan L Id

  Kan P F is absolute iff forall G. (G . Kan P F) ~= Kan P (G . F)

  p = Forget σ :: (k,σ) -> k
  f = Id :: (k,σ) -> (k,σ)

  Free   σ = Ran (Forget σ) Id :: k -> (k,σ)
  Cofree σ = Lan (Forget σ) Id :: k -> (k,σ)

  g :: (k,σ) -> j
  g . Free   σ = Ran (Forget σ) g
  g . Cofree σ = Lan (Forget σ) g

newtype Ran0 σ p (f :: k -> *) a =
  Ran0 { ran0 :: forall r. σ r => (a ~> p r) -> f r }

newtype Ran1 σ p (f :: k -> j -> *) a b =
  Ran1 { ran1 :: forall r. σ r => (a ~> p r) -> f r b }

-- ...

data RanOp0 σ p (f :: k -> *) a =
  forall e. σ e => RanOp0 (a ~> p e) (f e)

-- ...

data Lan0 σ p (f :: k -> *) a =
  forall e. σ e => Lan0 (p e ~> a) (f e)

data Lan1 σ p (f :: k -> j -> *) a b =
  forall e. σ e => Lan1 (p e ~> a) (f e b)

-- ...

data LanOp0 σ p (f :: k -> *) a =
  LanOp0 { lan0 :: forall r. σ r => (p r -> a) -> f r }

-- ...

type family Free   :: (k -> Constraint) -> k -> k
type family Cofree :: (k -> Constraint) -> k -> k

newtype Free0 σ a = Free0 { gratis0 :: forall r. σ r => (a ~> r) -> r }
type instance Free = Free0

newtype Free1 σ f a = Free1 { gratis1 :: forall g. σ g => (f ~> g) -> g a }
type instance Free = Free1

-- ...

data Cofree0 σ a = forall e. σ e => Cofree0 (e ~> a) e
type instance Cofree = Cofree0

data Cofree1 σ f a = forall g. σ g => Cofree1 (g ~> f) (g a)
type instance Cofree = Cofree1

-- ...

class Covariant (f :: i -> j) where
  comap :: (a ~> b) -> (f a ~> f b)

class Contravariant f where
  contramap :: (b ~> a) -> (f a ~> f b)

class Covariant m => Monad (m :: i -> i) where
  pure :: a ~> m a
  join :: m (m a) ~> m a

class Covariant w => Comonad (w :: i -> i) where
  extract :: w a ~> a
  split :: w a ~> w (w a)

class Couniversal σ f | f -> σ where
  couniversal :: σ r => (a ~> r) -> (f a ~> r)

class Universal σ f | f -> σ where
  universal :: σ e => (e ~> a) -> (e ~> f a)

instance Covariant (Free0 σ) where
  comap f (Free0 e) = Free0 (e . (.f))

instance Monad (Free0 σ) where
  pure x = Free0 $ \k -> k x
  join (Free0 e) = Free0 $ \k -> e $ \(Free0 e) -> e k

instance Couniversal σ (Free0 σ) where
  couniversal h (Free0 e) = e h

-- ...

free0Absolute0 :: forall g σ a. (Covariant g, σ (Free σ a))
               => g (Free0 σ a) < -> Ran σ Forget g a
free0Absolute0 = (l, r)
 where
 l :: g (Free σ a) -> Ran σ Forget g a
 l g = Ran0 $ \k -> comap (couniversal $ remember0 . k) g

 r :: Ran σ Forget g a -> g (Free σ a)
 r (Ran0 e) = e $ Forget0 . pure

free0Absolute1 :: forall (g :: * -> * -> *) σ a x. (Covariant g, σ (Free σ a))
               => g (Free0 σ a) x < -> Ran σ Forget g a x
free0Absolute1 = (l, r)
 where
 l :: g (Free σ a) x -> Ran σ Forget g a x
 l g = Ran1 $ \k -> comap (couniversal $ remember0 . k) $$ g

 r :: Ran σ Forget g a x -> g (Free σ a) x
 r (Ran1 e) = e $ Forget0 . pure

free0Absolute0Op :: forall g σ a. (Contravariant g, σ (Free σ a))
                 => g (Free0 σ a) < -> RanOp σ Forget g a
free0Absolute0Op = (l, r)
 where
 l :: g (Free σ a) -> RanOp σ Forget g a
 l = RanOp0 $ Forget0 . pure

 r :: RanOp σ Forget g a -> g (Free σ a)
 r (RanOp0 h g) = contramap (couniversal $ remember0 . h) g

-- ...

freeAbsolute
  :: forall g σ a. (Covariant g, σ (Free σ a))
  => g (Free σ a) < ~> Ran σ Forget g a

cofreeAbsolute
  :: forall g σ a. (Covariant g, σ (Cofree σ a))
  => g (Cofree σ a) < ~> Lan σ Forget g a

freeAbsoluteOp
  :: forall g σ a. (Contravariant g, σ (Free σ a))
  => g (Free σ a) < ~> RanOp σ Forget g a

cofreeAbsoluteOp
  :: forall g σ a. (Contravariant g, σ (Cofree σ a))
  => g (Cofree σ a) < ~> LanOp σ Forget g a

instance Functor (Free1 Functor f) where
  fmap f (Free1 e) = Free1 $ fmap f . e

instance Functor (Cofree1 Functor f) where
  fmap f (Cofree1 h e) = Cofree1 h (fmap f e)

data CoYo f a = forall e. CoYo (e -> a) (f e)

instance Covariant CoYo where
  comap f = Transform $ \(CoYo h e) -> CoYo h (f $$ e)

instance Monad CoYo where
  pure = Transform $ CoYo id
  join = Transform $ \(CoYo h (CoYo h' e)) -> CoYo (h . h') e

instance Functor (CoYo f) where
  fmap f (CoYo h e) = CoYo (f . h) e

instance Couniversal Functor CoYo where
  couniversal tr = Transform $ \(CoYo h e) -> fmap h (tr $$ e)

newtype Yo f a = Yo { oy :: forall r. (a -> r) -> f r }

instance Covariant Yo where
  comap f = Transform $ \(Yo e) -> Yo $ (f $$) . e

instance Comonad Yo where
  extract = Transform $ \(Yo e) -> e id
  split = Transform $ \(Yo e) -> Yo $ \k -> Yo $ \k' -> e $ k' . k

instance Functor (Yo f) where
  fmap f (Yo e) = Yo $ \k -> e (k . f)

instance Universal Functor Yo where
  universal tr = Transform $ \e -> Yo $ \k -> tr $$ fmap k e

coyoIso :: CoYo < ~> Free Functor
coyoIso = (Transform $ couniversal pure, Transform $ couniversal pure)

yoIso :: Yo < ~> Cofree Functor
yoIso = (Transform $ universal extract, Transform $ universal extract)

yoneda :: Ran Id f < ~> f

coyoneda :: Lan Id f < ~> f

             F
 Haskrete -----> Hask
      |        /|
      |       /
      |      /
Incl  |     /
      |    /  Ran/Lan Incl F
      |   /
      |  /
      v /
    Hask

type I a = a

undo m = do
  s <- get
  a <- m
  put s
  return a

class Monoid m => RightMonoidAction s m where
  act :: s -> m -> s

act s mempty = s
act s (mappend m n) = act (act s m) n

newtype State s a = State { runState :: s -> (a, s) }

newtype State i j a = State { runState :: i -> (a, j) }

newtype Update s m a = Update { runUpdate :: s -> (m, a) }

instance RightMonoidAction s m => Applicative (Update s m) where
  pure a = Update $ \s -> (mempty, a)
  Update ff <*> Update fa = Update $ \s -> case ff s of
    (m, f) -> case fa (act s m) of
      (n, a) -> (mappend m n, f a)

instance RightMonoidAction s m => Monad (Update s m) where
  return a = Update $ \s -> (mempty, a)
  Update f >>= k = Update $ \s -> case f s of
    (m, a) -> case runUpdate (k a) (act s m) of
      (n, b) -> (mappend m n, b)

get = Update $ \s -> (mempty, s)

instance RightMonoidAction s (Endo s) where
  act s (Endo f) = f s

put s = Update $ \_ -> (Endo (const s), ())

instance RightMonoidAction s (Last s) where
  act s (Last m) = fromMaybe s m

put s = Update $ \_ -> (Last (Just s), ())

instance Monoid m => RightMonoidAction () m where
  act () m = ()

instance RightMonoidAction e () where
  act e () = e

data Parser a = Parser { runParser :: String -> [(a, String)] }

newtype Drop = Drop Int

instance Monoid Drop where
  mempty = Drop 0
  mappend (Drop a) (Drop b) = Drop (a + b)

instance RightMonoidAction [a] Drop where
  act s (Drop n) = drop n s

data Parser a = Parser { runParser :: String -> [(Drop, a)] }

data Parser a = Parser { runParser :: String -> [(Int, a)] }

data Parser a = Parser { runParser :: String -> IntMap [a] }

type Heap a = [(Int, a)]

-- fair interleaving, because, well, why not? i guess we'll see.
merge :: Heap a -> Heap a -> Heap a
merge [] as = as
merge as [] = as
merge aas@(a:as) bbs@(b:bs)
  | fst a <= fst b = a : merge bbs as
  | otherwise      = b : merge bs aas

gather :: Heap a -> Heap [a]
gather [] = []
gather ((i0, a0) : as0) = go i0 [a0] as0 where
  go i acc [] = [(i,acc)]
  go i acc ((j, a) : as)
    | i == j    = go i (a:acc) as
    | otherwise = (i, acc) : go j [a] as

newtype Parser i o = Parser { runParser :: [i] -> Heap o }
  deriving Functor

instance Profunctor Parser where
  dimap f g (Parser m) = Parser $ map (second g) . m . map f

instance Applicative (Parser i) where
  pure a = Parser $ \_ -> [(0,a)]
  Parser mf <*> Parser ma = Parser $ \s0 -> go 0 s0 (gather (mf s0)) [] where
    go i s ((j, fs) : fss) acc
      | s' <- drop (j-i) s = go j s' fss
                           $ merge acc
                           $ ma s' >>= \(k,a) -> fmap (\f -> (j+k,f a)) fs
    go _ _ [] acc = acc

instance Alternative (Parser i) where
  empty = Parser $ \_ -> []
  Parser m <|> Parser n = Parser $ \s -> m s `merge` n s

instance Monad (Parser i) where
  return a = Parser $ \_ -> [(0,a)]
  Parser ma >>= amb = Parser $ \s0 -> go 0 s0 (ma s0) [] where
    go i s ((j, a) : fss) acc
      | s' <- drop (j-i) s = go j s' fss
                           $ merge acc
                           $ (\(k,b) -> (j+k,b)) <$> runParser (amb a) s'
    go _ _ [] acc = acc
  (>>) = (*>)
  fail _ = empty

instance MonadPlus (Parser i) where
  mzero = empty
  mplus = (<|>)

instance Parsing (Parser i) where
  -- do or do not, there is no try
  try = id
  m <?> _ = m
  unexpected _ = empty
  eof = Parser $ \s -> case s of
    [] -> [(0,())]
    _  -> []
  notFollowedBy (Parser m) = Parser $ \s ->
    if null (m s)
    then [(0,())]
    else []

instance (c ~ Char) => CharParsing (Parser c) where
  satisfy p = Parser $ \s -> case s of
    c:_ | p c -> [(1,c)]
    _         -> []

instance LookAheadParsing (Parser i) where
  lookAhead (Parser m) = Parser $ \s -> first (const 0) <$> m s

parse :: Parser i o -> [i] -> [(o, [i])]
parse (Parser m) s0 = go 0 s0 (m s0) where
  go i s ((j,o):xs) | s' <- drop (j-i) s = (o,s') : go j s' xs
  go _ _ [] = []

(drop 10000 s, drop (10000+123) s)

let s' = drop 10000 s in (s', drop 123 s')`

instance Category Parser where
  id = Parser $ \ case
    a:_ -> [(1,a)]
    _   -> []
  ...

newtype Hyp = Hyp ((Hyp -> Int) -> Int)

data LNat = Zero | Succ (() -> LNat)

foldMap :: Foldable f => f a -> FreeMonoid a

foldMap  :: (Foldable t   , Monoid m)      => (a -> m)   -> t a -> m
traverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)

newtype FM a = FM (forall m. Monoid m => (a -> m) -> m) deriving (Functor)

instance Applicative FM where
  pure x = FM ($ x)
  FM ef < *> FM ex = FM $ \k -> ef $ \f -> ex $ \x -> k (f x)

instance Monoid (FM a) where
  mempty = FM $ \_ -> mempty
  mappend (FM l) (FM r) = FM $ \k -> l k <> r k

instance Foldable FM where
  foldMap f (FM e) = e f

newtype Ap f b = Ap { unAp :: f b }

instance (Applicative f, Monoid b) => Monoid (Ap f b) where
  mempty = Ap $ pure mempty
  mappend (Ap l) (Ap r) = Ap $ (<>) < $> l < *> r

instance Traversable FM where
  traverse f (FM e) = unAp . e $ Ap . fmap pure . f

toFreeMonoid :: Traversable t => t a -> FM a
toFreeMonoid f = FM $ \k -> getConst $ traverse (Const . k) f

data Cheat a = Empty | Single a | Append (Cheat a) (Cheat a)

instance Monoid (Cheat a) where
  mempty = Empty
  mappend = Append

newtype Cheating b a =
  Cheating { prosper :: Cheat b -> a } deriving (Functor)

instance Applicative (Cheating b) where
  pure x = Cheating $ \_ -> x

  Cheating f < *> Cheating x = Cheating $ \c -> case c of
    Append l r -> f l (x r)

relabel :: Traversable t => t a -> FM b -> t b
relabel t (FM m) = propser (traverse (const hope) t) (m Single)
 where
 hope = Cheating $ \c -> case c of
   Single x -> x

slowTraverse
  :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
slowTraverse f t = fmap (relabel t) . traverse f . toFreeMonoid $ t

newtype Bazaar a b t =
  Bazaar { runBazaar :: forall f. Applicative f => (a -> f b) -> f t }

howBizarre :: Traversable t => t a -> Bazaar a b (t b)
howBizarre t = Bazaar $ \k -> traverse k t

newtype Free p f a =
  Free { gratis :: forall g. p g => (forall x. f x -> g x) -> g a }

type f ~> g = forall x. f x -> g x

embed :: f ~> Free p f
embed fx = Free $ \k -> k fx

translate :: (f ~> g) -> Free p f ~> Free p g
translate tr (Free e) = Free $ \k -> e (k . tr)

collapse :: Free p (Free p f) ~> Free p f
collapse (Free e) = Free $ \k -> e $ \(Free e') -> e' k

data At key i j where
  At :: key -> At key i i

type Atkey m i j a = m (At a j) i

ireturn :: IMonad m => a -> Atkey m i i a
ireturn = ...

ibind :: IMonad m => Atkey m i j a -> (a -> Atkey m j k b) -> Atkey m i k b
ibind = ...

hence :: Bazaar a b t -> Atkey (Free Applicative) t b a
hence bz = Free $ \tr -> runBazaar bz $ tr . At

forth :: Atkey (Free Applicative) t b a -> Bazaar a b t
forth fa = Bazaar $ \g -> gratis fa $ \(At a) -> g a

imap :: (a -> b) -> Bazaar a i j -> Bazaar b i j
imap f (Bazaar e) = Bazaar $ \k -> e (k . f)

ipure :: a -> Bazaar a i i
ipure x = Bazaar ($ x)

(>>>=) :: Bazaar a j i -> (a -> Bazaar b k j) -> Bazaar b k i
Bazaar e >>>= f = Bazaar $ \k -> e $ \x -> runBazaar (f x) k

(>==>) :: (s -> Bazaar i o t) -> (i -> Bazaar a b o) -> s -> Bazaar a b t
(f >==> g) x = f x >>>= g

  s -> Bazaar a b t
    ~
  s -> forall f. Applicative f => (a -> f b) -> f t
    ~
  forall f. Applicative f => (a -> f b) -> s -> f t

instance Functor (Bazaar a b) where
  fmap f (Bazaar e) = Bazaar $ \k -> fmap f (e k)

instance Applicative (Bazaar a b) where
  pure x = Bazaar $ \_ -> pure x
  Bazaar ef < *> Bazaar ex = Bazaar $ \k -> ef k < *> ex k

bfoldMap :: Monoid m => (a -> m) -> Bazaar a b t -> m
bfoldMap f (Bazaar e) = getConst $ e (Const . f)

newtype Comp g f a = Comp { getComp :: g (f a) } deriving (Functor)

instance (Applicative f, Applicative g) => Applicative (Comp g f) where
  pure = Comp . pure . pure
  Comp f < *> Comp x = Comp $ liftA2 (< *>) f x

btraverse
  :: (Applicative f) => (a -> f a') -> Bazaar a b t -> Bazaar a' b t
btraverse f (Bazaar e) = getComp $ e (c . fmap ipure . f)

extract :: Bazaar b b t -> t
extract (Bazaar e) = runIdentity $ e Identity

honestTraverse
  :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
honestTraverse f = fmap extract . btraverse f . howBizarre

newtype Bizarre p a b t =
  Bizarre { bizarre :: forall f. p f => (a -> f b) -> f t }

leonardo 0 = 1
leonardo 1 = 1
leonardo n = leonardo (n - 2) + leonardo (n - 1) + 1

next i j = i + j + 1

prev i j = j - i - 1

prev2 i j = prev (prev i j) i

prev2 i j = 2*i - j

leonardo n = 2 * fibonacci (n+1) - 1

data Tree a = Bin a (Tree a) (Tree a) | Tip a deriving Show

  1
  +---,
  |   |
  2   3
      +----,
      |    |
      4    5

  1
  +-------+
  |       |
  2       5
  +---,   +---,
  |   |   |   |
  3   4   6   7
              +---,
              |   |
              8   9

data Leonardo a = Cons !Int !Int (Tree a) (Leonardo a) | Nil deriving Show

cons :: a -> Leonardo a -> Leonardo a
cons a (Cons i j bs (Cons j' k cs zs))
  | j == j' = Cons k (next j k) (Bin a bs cs) zs
cons a rs = Cons 1 1 (Tip a) rs

1
1,1
3
1,3
5
1,5
1,1,5
3,5
9
1,9
1,1,9
3,9
1,3,9
5,9
15
1,15
...

size :: Leonardo a -> Int
size (Cons _ i _ as) = i + size as
size Nil = 0

(!) :: Leonardo a -> Int -> a
Nil ! i = undefined
Cons j k a as ! i
  | i < k     = go i (prev j k) j a
  | otherwise = as ! (i - k)
  where
    go 0 _ _ (Tip a) = a
    go 0 _ _ (Bin a _ _) = a
    go i j k (Bin _ l r)
      | i <= j    = go (i-1)  (prev2 j k) (prev j k) l
      | otherwise = go (i-j-1) (prev j k) j r

data SL a = Empty | SL a :> a

instance Monoid (SL a) where
  mempty = Empty
  mappend ys Empty = ys
  mappend ys (xs :> x) = (mappend ys xs) :> x

single :: a -> SL a
single x = Empty :> x

h [] = Empty
h (xs <> ys) = h xs <> h ys
h [x] = single x

h [1] = single 1

h [1,1..] = h ([1] <> [1,1..]) -- [1,1..] is an infinite list of 1s
    = h [1] <> h [1,1..]

x = h [1] <> x = fix (single 1 <>)
h [1,1..] = x

[1,1..] <> [n] = [1,1..] -- true for all n
h [1,1..] = ⊥
h ([1,1..] <> [1]) = h [1,1..] <> h [1]
       = ⊥ <> single 1
       = ⊥ :> 1
       ≠ ⊥

pure x <> ⊥ = ⊥
h ⊥ = ⊥
h (pure x <> ⊥) = [x] <> h ⊥
    = [x] ++ ⊥
    = x:⊥
    ≠ ⊥

forall a m. Monoid m => (a -> m) -> FM a -> m

newtype FM a = FM { unFM :: forall m. Monoid m => (a -> m) -> m }

embed :: a -> FM a
embed x = FM $ \k -> k x

instance Monoid (FM a) where
  mempty = FM $ \_ -> mempty
  mappend (FM e1) (FM e2) = FM $ \k -> e1 k <> e2 k

data FMG a = None | Single a | FMG a :<> FMG a

None :<> x = x = x :<> None
x :<> (y :<> z) = (x :<> y) :<> z

unFMG :: forall a m. Monoid m => FMG a -> (a -> m) -> m
unFMG None _ = mempty
unFMG (Single x) k = k x
unFMG (x :<> y) k = unFMG x k <> unFMG y k

ones1 = embed 1 <> ones1
ones2 = ones2 <> embed 1

ones1 = embed 1 <> (embed 1 <> ...)
      ... reassociate ...
      = (... <> embed 1) <> embed 1
      = ones2

x <> (y <> z) = (x <> y) <> z

foldMap :: (Foldable f, Monoid m) => (a -> m) -> f a -> m

Foldable f => f a -> (forall m. Monoid m => (a -> m) -> m)

g . h = k . f

$map g . fmap h = fmap k . $map f

<edwardk> @free fmap :: (a -> b) -> (F a -> F b)
<lambdabot> g . h = k . f => $map_F g . fmap h = fmap k . $map_F f

fmap f = $map f

fmap f
= {- by $map id = id -}
$map id . fmap f
= {- by free theorem, using g = k = id, h = f -}
fmap id . $map f
= {- by fmap id = id -}
$map f

f . g = id . (f . g)

fmap f . fmap g = fmap (f . g)

fmap f . fmap g
= {- by lemma 1, fmap f = $map f -}
$map f . fmap g
= {- by the free theorem for fmap using lemma 2 for the precondition -}
fmap id . $map (f . g)
= {- by fmap id = id -}
$map (f . g)
= {- by fmap _ = $map _ -}
fmap (f . g)

data Name = Name String Int
   deriving (Show,Read)

hint :: Name -> String
hint (Name n _) = n

nameId :: Name -> Int
nameId (Name _ i) = i

instance Eq Name where
  (==) = (==) `on` nameId

instance Ord Name where
  compare = compare `on` nameId

prime :: String -> Int -> Name
prime n i = Name n (i + 1)

type Level = Int

data Constant
  = Level
  | LevelLiteral {-# UNPACK #-} !Level
  | Omega
  deriving (Eq,Ord,Show,Read,Typeable)

data Term a
  = Free a
  | Bound {-# UNPACK #-} !Name
  | Constant !Constant
  | Term a :+ {-# UNPACK #-} !Level
  | Max  [Term a]
  | Type !(Term a)
  | Lam   {-# UNPACK #-} !Name !(Term a) !(Term a)
  | Pi    {-# UNPACK #-} !Name !(Term a) !(Term a)
  | Sigma {-# UNPACK #-} !Name !(Term a) !(Term a)
  | App !(Term a) !(Term a)
  | Fst !(Term a)
  | Snd !(Term a)
  | Pair !(Term a) !(Term a) !(Term a)
  deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable,Typeable)

subst :: Eq a => a -> Term a -> Term a -> Term a
subst a x y = y >>= \a' ->
  if a == a'
    then x
    else return a'

class Bindable t where
  bound :: t -> Int

instance Bindable (Term a) where
  bound Free{}        = 0
  bound Bound{}       = 0 -- intentional!
  bound Constant{}    = 0
  bound (a :+ _)      = bound a
  bound (Max xs)      = foldr (\a r -> bound a `max` r) 0 xs
  bound (Type t)      = bound t
  bound (Lam b t _)   = nameId b `max` bound t
  bound (Pi b t _)    = nameId b `max` bound t
  bound (Sigma b t _) = nameId b `max` bound t
  bound (App x y)     = bound x `max`  bound y
  bound (Fst t)       = bound t
  bound (Snd t)       = bound t
  bound (Pair t x y)  = bound t `max` bound x `max` bound y

binder :: Bindable t =>
  (Name -> t) ->
  (Name -> t -> r) ->
  String -> (t -> t) -> r
binder bd c n e = c b body where
  body = e (bd b)
  b = prime n (bound body)

lam, pi, sigma :: String -> Term a -> (Term a -> Term a) -> Term a
lam s t   = binder Bound (`Lam` t) s
pi s t    = binder Bound (`Pi` t) s
sigma s t = binder Bound (`Sigma` t) s

lam_, pi_, sigma_ :: Term a -> (Term a -> Term a) -> Term a
lam_   = lam "_"
pi_    = pi "_"
sigma_ = sigma "_"

instantiate :: Name -> t -> IntMap t -> IntMap t
instantiate = IntMap.insert . nameId

rebind :: IntMap (Term b) -> Term a -> (a -> Term b) -> Term b
rebind env xs0 f = go xs0 where
  go = \case
    Free a       -> f a
    Bound b      -> env IntMap.! nameId b
    Constant c   -> Constant c
    m :+ n       -> go m :+ n
    Type t       -> Type (go t)
    Max xs       -> Max (fmap go xs)
    Lam b t e    -> lam   (hint b) (go t) $ \v ->
      rebind (instantiate b v env) e f
    Pi b t e     -> pi    (hint b) (go t) $ \v ->
      rebind (instantiate b v env) e f
    Sigma b t e  -> sigma (hint b) (go t) $ \v ->
      rebind (instantiate b v env) e f
    App x y      -> App (go x) (go y)
    Fst x        -> Fst (go x)
    Snd x        -> Snd (go x)
    Pair t x y   -> Pair (go t) (go x) (go y)

instance Applicative Term where
  pure = Free
  (< *>) = ap

instance Monad Term where
  return = Free
  (>>=) = rebind IntMap.empty

apply :: Term a -> [Term a] -> Term a
apply = foldl App

rwhnf :: IntMap (Term a) ->
  [Term a] -> Term a -> Term a
rwhnf env stk     (App f x)
  = rwhnf env (rebind env x Free:stk) f
rwhnf env (x:stk) (Lam b _ e)
  = rwhnf (instantiate b x env) stk e
rwhnf env stk (Fst e)
  = case rwhnf env [] e of
  Pair _ e' _ -> rwhnf env stk e'
  e'          -> Fst e'
rwhnf env stk (Snd e)
  = case rwhnf env [] e of
  Pair _ _ e' -> rwhnf env stk e'
  e'          -> Snd e'
rwhnf env stk e
  = apply (rebind env e Free) stk

whnf :: Term a -> Term a
whnf = rwhnf IntMap.empty []

alphaEq :: Eq a => Term a -> Term a -> Bool
alphaEq = (==) `on` liftM id

data Heap a = Heap !Int a [Heap a] deriving Show

mix :: Heap a -> Heap a -> Heap a
mix x@(Heap i a as) y@(Heap j b bs)
  | i <= j    = Heap i a (y:as)
  | otherwise = Heap j b (x:bs)

top :: Heap a -> (Int, a)
top (Heap i a _) = (i, a)

pop :: Heap a -> Maybe (Heap a)
pop (Heap _ _ [])    = Nothing
pop (Heap _ _ (x:xs) = Just (merge x xs)

merge :: Heap a -> [Heap a] -> Heap a
merge x (y:ys) = case ys of
  (z:zs) -> mix x y `mix` merge z zs
  []     -> mix x y
merge x [] = x

data Steque a = Steque [a] [a] deriving (Show,Read)

instance Functor Steque where
  fmap f (Steque fs rs) = Steque (fmap f fs) (fmap f rs)

instance Foldable Steque where
  foldMap f (Steque fs rs) = foldMap f fs `mappend` getDual (foldMap (Dual . f) rs)

instance Traversable Steque where
  traverse f (Steque fs rs) = Steque <$> traverse f fs <*> backwards traverse f rs

instance Eq a => Eq (Steque a) where
  (==) = (==) `on` toList

instance Ord a => Ord (Steque a) where
  compare = compare `on` toList

instance Applicative Steque where
  pure a = Steque [a] []
  (<*>) = ap

instance Monad Steque where
  return a = Steque [a] []
  Steque fs bs >>= f = Steque (fs >>= toList . f) (bs >>= toListOf (backwards folded) . f)

instance (Choice p, Applicative f) => Cons p f (Steque a) (Steque b) a b where
  _Cons = prism (\(x,Steque fs bs) -> Steque (x:fs) bs) $ \ (Steque fs bs) -> case fs of
     x:xs -> Right (x,Steque xs bs)
     []   -> case reverse bs of
       x:xs -> Right (x,Steque xs [])
       [] -> Left (Steque [] [])

_Cons :: Prism (Steque a) (Steque b) (a, Steque a) (b, Steque b)

cons a as = _Cons # (a,as)
uncons as = as^?_Cons

_head = _Cons._1
_tail = _Cons._2

instance (p ~ Reviewed, f ~ Identity, a ~ b) => Snoc p f (Steque a) (Steque b) a b where
  _Snoc = unto $ \(Steque f b,x) -> Steque f (x:b)

snoc as a = _Snoc # (as,a)

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
import Control.Applicative
import Control.Monad
import Control.Lens
import Control.Lens.Internal.Review
import Data.Foldable
import Data.Functor.Identity
import Data.Monoid
import Data.Function (on)

data Steque a = Steque [a] [a] deriving (Show,Read)

instance Eq a => Eq (Steque a) where
  (==) = (==) `on` toList

instance Ord a => Ord (Steque a) where
  compare = compare `on` toList

instance Functor Steque where
  fmap f (Steque fs rs) = Steque (fmap f fs) (fmap f rs)

instance Foldable Steque where
  foldMap f (Steque fs rs) = foldMap f fs `mappend` getDual (foldMap (Dual . f) rs)

instance Traversable Steque where
  traverse f (Steque fs rs) = Steque <$> traverse f fs <*> backwards traverse f rs

instance Applicative Steque where
  pure a = Steque [a] []
  (<*>) = ap

instance Alternative Steque where
  Steque fs rs <|> Steque fs' rs' = Steque (fs ++ reverse rs ++ fs') rs'
  empty = Steque [] []

instance Monad Steque where
  return a = Steque [a] []
  Steque fs bs >>= f = Steque (fs >>= toList . f) (bs >>= toListOf (backwards folded) . f)

instance MonadPlus Steque where
  mplus = (<|>)
  mzero = Steque [] []

instance Monoid (Steque a) where
  mappend = (<|>)
  mempty = Steque [] []

instance (Choice p, Applicative f) => Cons p f (Steque a) (Steque b) a b where
  _Cons = prism (\(x,Steque fs bs) -> Steque (x:fs) bs) $ \ (Steque fs bs) -> case fs of
     x:xs -> Right (x,Steque xs bs)
     []   -> case reverse bs of
       x:xs -> Right (x,Steque xs [])
       [] -> Left (Steque [] [])

instance (p ~ Reviewed, f ~ Identity, a ~ b) => Snoc p f (Steque a) (Steque b) a b where
  _Snoc = unto $ \(Steque f b,x) -> Steque f (x:b)

main = print $ uncons (snoc (cons 1 (cons 2 (snoc (empty :: Steque Int) 4))) 5)

Steque fs rs <|> Steque fs' rs' = Steque (fs ++ reverse rs ++ fs') rs'

data Catenable f a = Empty | Cons a (f (Catenable f a))

data Catenable f a = Cons a (f (Catenable f a))

data CSteque a = Cons a (Steque (CSteque a))

instance Semigroup (CSteque a) where
  CSteque a as <> bs = CSteque a (snoc as bs)

data CSteque a = Cons a [CSteque a] [CSteque a]

data Heap a = Heap {-# UNPACK #-} !Int a [Heap a] [Heap a] [Heap a]

fby :: Heap a -> Heap a -> Heap a
fby (Heap i a as ls rs) r = Heap i a as ls (r:rs)

top :: Heap a -> (Key, a)
top (Heap i a _ _ _) = (i, a)

singleton :: Key -> a -> Heap a
singleton k v = Heap k v [] [] []

fromList :: [(Key,a)] -> Heap a
fromList ((k0,v0):xs) = Prelude.foldr (\(k,v) r -> mix (singleton k v) r) (singleton k0 v0) xs
fromList [] = error "empty Heap"

fromAscList :: [(Key,a)] -> Heap a
fromAscList ((k0,v0):xs) = Prelude.foldr (\(k,v) r -> fby (singleton k v) r) (singleton k0 v0) xs
fromAscList [] = error "empty Heap"

pop :: [Heap a] -> [Heap a] -> [Heap a] -> Maybe (Heap a)
pop (x:xs) ls     rs = Just $ fbys (merge x xs) ls rs
pop []     (l:ls) rs = Just $ fbys l ls rs
pop []     []     rs = case reverse rs of
  f:fs -> Just (fbys f fs [])
  []   -> Nothing

fbys :: Heap a -> [Heap a] -> [Heap a] -> Heap a
fbys (Heap i a as [] []) ls' rs' = Heap i a as ls' rs'
fbys (Heap i a as ls []) ls' rs' = Heap i a as ls $ rs' <> reverse ls'
fbys (Heap i a as ls rs) ls' rs' = Heap i a as ls $ rs' <> reverse ls' <> rs

mix :: Heap a -> Heap a -> Heap a
mix x@(Heap i a as al ar) y@(Heap j b bs bl br)
  | i <= j    = Heap i a (y:pops as al ar) [] []
  | otherwise = Heap j b (x:pops bs bl br) [] []

merge :: Heap a -> [Heap a] -> Heap a
merge x (y:ys) = case ys of
  (z:zs) -> mix x y `mix` merge z zs
  []     -> mix x y
merge x [] = x

pops :: [Heap a] -> [Heap a] -> [Heap a] -> [Heap a]
pops xs     []     [] = xs
pops (x:xs) ls     rs = [fbys (merge x xs) ls rs]
pops []     (l:ls) rs = [fbys l ls rs]
pops []     []     rs = case reverse rs of
  f:fs -> [fbys f fs []]
  _    -> [] -- caught above

data HeapState a
  = Start !(Heap a)
  | Ready {-# UNPACK #-} !Key a !(Heap a)
  | Final {-# UNPACK #-} !Key a
  | Finished

streamHeapWith :: Monad m => (a -> a -> a) -> Maybe (Heap a) -> Stream m (Key, a)
streamHeapWith f h0 = Stream step (maybe Finished Start h0) Unknown where
  step (Start (Heap i a xs ls rs))     = return $ Skip $ maybe (Final i a) (Ready i a) $ pop xs ls rs
  step (Ready i a (Heap j b xs ls rs)) = return $ case compare i j of
    LT -> Yield (i, a)      $ maybe (Final j b) (Ready j b) $ pop xs ls rs
    EQ | c <- f a b -> Skip $ maybe (Final i c) (Ready i c) $ pop xs ls rs
    GT -> Yield (j, b)      $ maybe (Final i a) (Ready i a) $ pop xs ls rs
  step (Final i a) = return $ Yield (i,a) Finished
  step Finished    = return Done
  {-# INLINE [1] step #-}
{-# INLINE [0] streamHeapWith #-}

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Applicative
import Control.Lens
import Data.Bits
import Data.Foldable
import Data.Monoid
import Data.Vector.Fusion.Stream.Monadic hiding (singleton, fromList)
import Data.Vector.Fusion.Stream.Size
import Data.Vector.Fusion.Util
import Data.Word
import Prelude

type Key = Int

-- | Bootstrapped _catenable_ non-empty pairing heaps
data Heap a = Heap {-# UNPACK #-} !Key a [Heap a] [Heap a] [Heap a]
  deriving (Show,Read)

-- | Append two heaps where we know every key in the first occurs before every key in the second
fby :: Heap a -> Heap a -> Heap a
fby (Heap i a as ls rs) r = Heap i a as ls (r:rs)

-- | Interleave two heaps making a new 'Heap'
mix :: Heap a -> Heap a -> Heap a
mix x@(Heap i a as al ar) y@(Heap j b bs bl br)
  | i <= j    = Heap i a (y:pops as al ar) [] []
  | otherwise = Heap j b (x:pops bs bl br) [] []

merge :: Heap a -> [Heap a] -> Heap a
merge x (y:ys) = case ys of
  (z:zs) -> mix x y `mix` merge z zs
  []     -> mix x y
merge x [] = x

top :: Heap a -> (Key, a)
top (Heap i a _ _ _) = (i, a)

pop :: [Heap a] -> [Heap a] -> [Heap a] -> Maybe (Heap a)
pop (x:xs) ls     rs = Just $ fbys (merge x xs) ls rs
pop []     (l:ls) rs = Just $ fbys l ls rs
pop []     []     rs = case reverse rs of
  f:fs -> Just (fbys f fs [])
  []   -> Nothing

singleton :: Key -> a -> Heap a
singleton k v = Heap k v [] [] []

fromList :: [(Key,a)] -> Heap a
fromList ((k0,v0):xs) = Prelude.foldr (\(k,v) r -> mix (singleton k v) r) (singleton k0 v0) xs
fromList [] = error "empty Heap"

fromAscList :: [(Key,a)] -> Heap a
fromAscList ((k0,v0):xs) = Prelude.foldr (\(k,v) r -> fby (singleton k v) r) (singleton k0 v0) xs
fromAscList [] = error "empty Heap"

-- * Internals

fbys :: Heap a -> [Heap a] -> [Heap a] -> Heap a
fbys (Heap i a as [] []) ls' rs' = Heap i a as ls' rs'
fbys (Heap i a as ls []) ls' rs' = Heap i a as ls $ rs' <> reverse ls'
fbys (Heap i a as ls rs) ls' rs' = Heap i a as ls $ rs' <> reverse ls' <> rs

pops :: [Heap a] -> [Heap a] -> [Heap a] -> [Heap a]
pops xs     []     [] = xs
pops (x:xs) ls     rs = [fbys (merge x xs) ls rs]
pops []     (l:ls) rs = [fbys l ls rs]
pops []     []     rs = case reverse rs of
  f:fs -> [fbys f fs []]
  _    -> [] -- caught above by the 'go as [] []' case

-- * Instances

instance Functor Heap where
  fmap f (Heap k a xs ls rs) = Heap k (f a) (fmap f <$> xs) (fmap f <$> ls) (fmap f <$> rs)

instance FunctorWithIndex Key Heap where
  imap f (Heap k a xs ls rs) = Heap k (f k a) (imap f <$> xs) (imap f <$> ls) (imap f <$> rs)

instance Foldable Heap where
  foldMap f = go where
    go (Heap _ a xs ls rs) = case pop xs ls rs of
      Nothing -> f a
      Just h  -> f a `mappend` go h
  {-# INLINE foldMap #-}

instance FoldableWithIndex Key Heap where
  ifoldMap f = go where
    go (Heap i a xs ls rs) = case pop xs ls rs of
      Nothing -> f i a
      Just h  -> f i a `mappend` go h
  {-# INLINE ifoldMap #-}

-- this linearizes the heap
instance Traversable Heap where
  traverse f xs = fromAscList <$> traverse (traverse f) (itoList xs)
  {-# INLINE traverse #-}

instance TraversableWithIndex Key Heap where
  itraverse f xs = fromAscList <$> traverse (\(k,v) -> (,) k <$> f k v) (itoList xs)
  {-# INLINE itraverse #-}

data HeapState a
  = Start !(Heap a)
  | Ready {-# UNPACK #-} !Key a !(Heap a)
  | Final {-# UNPACK #-} !Key a
  | Finished

streamHeapWith :: Monad m => (a -> a -> a) -> Maybe (Heap a) -> Stream m (Key, a)
streamHeapWith f h0 = Stream step (maybe Finished Start h0) Unknown where
  step (Start (Heap i a xs ls rs))     = return $ Skip $ maybe (Final i a) (Ready i a) $ pop xs ls rs
  step (Ready i a (Heap j b xs ls rs)) = return $ case compare i j of
    LT -> Yield (i, a)      $ maybe (Final j b) (Ready j b) $ pop xs ls rs
    EQ | c <- f a b -> Skip $ maybe (Final i c) (Ready i c) $ pop xs ls rs
    GT -> Yield (j, b)      $ maybe (Final i a) (Ready i a) $ pop xs ls rs
  step (Final i a) = return $ Yield (i,a) Finished
  step Finished    = return Done
  {-# INLINE [1] step #-}
{-# INLINE [0] streamHeapWith #-}

streamHeapWith0 :: Monad m => (a -> a -> Maybe a) -> Maybe (Heap a) -> Stream m (Key, a)
streamHeapWith0 f h0 = Stream step (maybe Finished Start h0) Unknown where
  step (Start (Heap i a xs ls rs))     = return $ Skip $ maybe (Final i a) (Ready i a) $ pop xs ls rs
  step (Ready i a (Heap j b xs ls rs)) = return $ case compare i j of
    LT -> Yield (i, a) $ maybe (Final j b) (Ready j b) $ pop xs ls rs
    EQ -> case f a b of
      Nothing -> Skip  $ maybe Finished Start $ pop xs ls rs
      Just c  -> Skip  $ maybe (Final i c) (Ready i c) $ pop xs ls rs
    GT -> Yield (j, b) $ maybe (Final i a) (Ready i a) $ pop xs ls rs
  step (Final i a) = return $ Yield (i,a) Finished
  step Finished = return Done
  {-# INLINE [1] step #-}
{-# INLINE [0] streamHeapWith0 #-}

main = print $ (fromList [(10,"hi"),(20,"there")] `mix` singleton 100 "hello") `fby` singleton 200 "goodbye"

type Algebra f a = f a -> a

newtype Mu f = InF { outF :: f (Mu f) }

cata :: Functor f => Algebra f a -> Mu f -> a
cata f = f . fmap (cata f) . outF

cata f = hylo f outF
cata f = para (f . fmap fst)

cata phi . InF = phi . fmap (cata phi)
cata InF = id
f . phi = phi . fmap f => 
f . cata phi = cata phi
eps :: forall x. f x -> g x =>
cata phi . cata (In . eps) =
cata (phi . eps)
data StrF x = Cons Char x | Nil
type Str = Mu StrF

nil :: Str
nil = InF Nil

cons :: Char -> Str -> Str
cons x xs = InF (Cons x xs)

instance Functor StrF where
  fmap f (Cons a as) = Cons a (f as)
  fmap f Nil = Nil

length :: Str -> Int
length = cata phi where
  phi (Cons a b) = 1 + b
  phi Nil = 0

data NatF a = S a | Z deriving (Eq,Show)

type Nat = Mu NatF

instance Functor NatF where
  fmap f Z = Z
  fmap f (S z) = S (f z)

plus :: Nat -> Nat -> Nat
plus n = cata phi where
  phi Z = n
  phi (S m) = s m

Multiplication as a catamorphism:

times :: Nat -> Nat -> Nat
times n = cata phi where
  phi Z = z
  phi (S m) = plus n m

z :: Nat
z = InF Z

s :: Nat -> Nat
s = InF . S

type MendlerAlgebra f c = forall a. (a -> c) -> f a -> c

mcata :: MendlerAlgebra f c -> Mu f -> c
mcata phi = phi (mcata phi) . outF

cata :: Functor f => Algebra f c -> Mu f -> c
cata phi = mcata (\f -> phi . fmap f)

data CoYoneda f a = forall b. CoYoneda (b -> a) (f b)

toCoYoneda :: f a -> CoYoneda f a
toCoYoneda = CoYoneda id

fromCoYoneda :: Functor f => CoYoneda f a -> f a
fromCoYoneda (CoYoneda f v) = fmap f v

Algebra (CoYoneda f) a
= (by definition)           CoYoneda f a -> a
~ (by definition)           (exists b. (b -> a, f b)) -> a
~ (lifting the existential) forall b. (b -> a, f b) -> a
~ (by currying)             forall b. (b -> a) -> f b -> a
= (by definition)           MendlerAlgebra f a

type Dist f w = forall a. f (w a) -> w (f a)
type FWAlgebra f w a = f (w a) -> a

g_cata :: (Functor f, Comonad w) =>
          Dist f w -> FWAlgebra f w a -> Mu f -> a
g_cata k g = extract . c where
  c = liftW g . k . fmap (duplicate . c) . outF

lowerAlgebra :: (Functor f, Comonad w) =>
                Dist f w -> FWAlgebra f w a -> Algebra f (w a)
lowerAlgebra k phi = liftW phi . k . fmap duplicate

g_cata :: (Functor f, Comonad w) =>
          Dist f w -> FWAlgebra f w a -> Mu f -> a
g_cata k phi = extract . cata (lowerAlgebra k phi)

liftAlgebra :: (Functor f, Comonad w) =>
               Algebra f a -> FWAlgebra f w a

liftAlgebra phi = phi . fmap extract

cata :: Functor f => Algebra f a -> Mu f -> a
cata f = g_cata (Identity . fmap runIdentity) (liftAlgebra f)

data ExpF a
  = App a a
  | Lam (a -> a)

class Invariant f where
  invmap :: (a -> b) -> (b -> a) -> f a -> f b

instance Invariant ExpF where
  invmap ab ba (App x y) = App (ab x) (ab y)
  invmap ab ba (Lam aa)  = Lam (ab.aa.ba)

newtype Mu f = In { out :: f (Mu f) }

cata :: Invariant f => (f a -> a) -> (a -> f a) -> Mu f -> a
cata f g (In x) = f (invmap (cata f g) (ana f g) x)

ana :: Invariant f => (f a -> a) -> (a -> f a) -> a -> Mu f
ana f g x = In (invmap (ana f g) (cata f g) (g x))

data Rec f a = Place a | Roll (f (Rec f a))

cata :: Invariant f => (f a -> a) -> Rec f a -> a
cata f (Roll x) = f (invmap (cata f) Place x)
cata f (Place x) = x

cata f . Place = id

type Exp = Rec ExpF

lam :: (Exp a -> Exp a) -> Exp a
lam f = Roll (Lam f)

app :: Exp a -> Exp a -> Exp a
app x y = Roll (App x y)

type Rec f a = (f a -> a) -> a

cata :: (f a -> a) -> Rec f a -> a
cata f x = x f

roll :: Invariant f => f (Rec f a) -> Rec f a
roll x f = f (invmap (cata f) place x)

place :: a -> Rec f a
place = const

type Exp a = Rec ExpF a

lam :: (Exp a -> Exp a) -> Exp a
lam f = roll (Lam f)

app :: Exp a -> Exp a -> Exp a
app x y = roll (App x y)

var :: a -> Exp a
var = place

type ClosedExp = forall x. Exp x

data Exp a
  = Var a
  | Lam (a -> Exp a)
  | App (Exp a) (Exp a)

lam :: (Exp a -> Exp a) -> Exp a

lam :: (a -> Exp a) -> Exp a

class Profunctor p where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d

lmap :: Profunctor p => (a -> b) -> p b c -> p a c
rmap :: Profunctor p => (b -> c) -> p a b -> p a c

data ExpF a b
  = App b b
  | Lam (a -> b)

instance Profunctor ExpF where
  dimap f g (App x y) = App (g x) (g y)
  dimap f g (Lam h)   = Lam (g.h.f)

data Exp a
  = Var a
  | Lam (a -> Exp a)
  | Abs (Exp a) (Exp a)

data Rec p a b
  = Place b
  | Roll (p a (Rec p a b))

type Exp = Rec ExpF

instance Profunctor p => Monad (Rec p a) where
  return = Place
  Place b  >>= f = f b
  Roll bs >>= f = Roll $ rmap (>>= f) bs

cata :: Profunctor p => (p a b -> b) -> Rec p a b -> b
cata phi (Place b)  = b
cata phi (Roll bs) = phi (rmap (cata phi) bs)

lam :: (a -> Exp a b) -> Exp a b
lam f = Roll (Lam f)

app :: Exp a b -> Exp a b -> Exp a b
app x y = Roll (App x y)

var :: b -> Exp a b
var = return

foo :: Exp a a
foo = lam $ \x -> lam $ \y -> app (var x) (var y)

type End p = forall x. p x x

iter0 :: Profunctor p => (p a a -> a) -> End (Rec p) -> a
iter0 phi x = cata phi x

type Rec f a = (f a -> a) -> a

newtype Rec p a b = Rec { runRec :: (p a b -> a) -> b }

instance Profunctor p => Profunctor (Rec p) where
  dimap f g (Rec h) = Rec $ \pab2a -> g $ h $ f . pab2a . dimap f g

data Rec p a b = Rec
  { runRec :: forall r.
    (b -> r) -> (p a r -> r) -> r
  }

instance Profunctor p => Profunctor (Rec p) where
  dimap f g m = Rec $ \kp kf -> runRec m (kp.g) (kf.lmap f)

instance Profunctor p => Monad (Rec p a) where
  return b = Rec $ \ br _ -> br b
  m >>= f  = Rec $ \kp kf ->
    runRec m (\a -> runRec (f a) kp kf) kf

type End p = forall x. p x x

cata :: Profunctor p => (p a b -> b) -> Rec p a b -> b
cata phi m = runRec m id phi

roll :: Profunctor p => p a (Rec p a b) -> Rec p a b
roll w = Rec $ \kp kf -> kf (rmap (\r -> runRec r kp kf) w)

iter0 :: Profunctor p => (p a a -> a) -> End (Rec p) -> a
iter0 phi x = cata phi x

lam :: (a -> Exp a b) -> Exp a b
lam f = roll (Lam f)

app :: Exp a b -> Exp a b -> Exp a b
app x y = roll (App x y)

var :: b -> Exp a b
var = return

foo :: Exp a a
foo = lam $ \x -> lam $ \y -> app (var x) (var y)

data Partial a = Stop a | Step (Partial a)

instance Monad Partial where
  return = Stop
  Stop a >>= f = f a
  Step m >>= f = Step (m >>= f)

main = putStrLn "It typechecks!"

run :: Int -> Partial a -> Partial a
run 0 m = m
run n m@Stop{} = m
run n (Step m) = run (n-1) m

step :: Partial ()
step = Step (return ())

never :: Partial a
never = Step never

newSTRef :: a -> ST s (STRef s a)
readSTRef :: STRef s a -> ST s a
writeSTRef :: STRef s a -> a -> ST s ()
...

runST :: (forall s. ST s a) -> a

walkST :: (forall s. Free (ST s) a) -> Free Identity a

walkST :: (forall s. Free (ST s) a) -> Partial a

newtype IterT m a = IterT
  { runIterT :: m (Either a (IterT m a))
  }

instance Monad m => Monad (IterT m) where
  return = IterT . return . Left
  IterT m >>= k = IterT $
    m >>= either (runIterT . k) (return . Right . (>>= k))
  fail = IterT . fail

main = putStrLn "It typechecks!"

step :: Monad m => IterT m ()
step = IterT . return . Right . return

walkST :: (forall s. IterT (ST s) a) -> Partial a

unsafePerformIO :: IO a -> a
unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)

unsafeInterleaveIO :: IO a -> a
unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)

unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST (ST m) = ST ( \ s ->
    let
        r = case m s of (# _, res #) -> res
    in
    (# s, r #)
  )

{-# LANGUAGE RankNTypes #-}

import Control.Monad.ST
import System.IO.Unsafe as Unsafe
import Control.Monad.ST.Unsafe as Unsafe

walkST :: (forall s. IterT (ST s) a) -> Partial a
walkST m = go m where
  go (IterT m) =
    case Unsafe.unsafePerformIO $
         Unsafe.unsafeSTToIO m of
      Left a  -> Stop a
      Right m -> Step (go m)

newtype IterT m a = IterT
  { runIterT :: m (Either a (IterT m a))
  }

instance Monad m => Monad (IterT m) where
  return = IterT . return . Left
  IterT m >>= k = IterT $
    m >>= either (runIterT . k) (return . Right . (>>= k))
  fail = IterT . fail

data Partial a = Stop a | Step (Partial a)

instance Monad Partial where
  return = Stop
  Stop a >>= f = f a
  Step m >>= f = Step (m >>= f)

main = putStrLn "It typechecks!"

newtype First a = First { getFirst :: a }

instance Semigroup (First a) where
  m <> _ = m

newtype First a = First { getFirst :: Maybe a }

instance Semigroup (First a) where
  First Nothing <> m = m
  m             <> _ = m

instance Monoid (First a) where
  mempty = First Nothing

  First Nothing `mappend` m = m
  m             `mappend` _ = m

extract empty :: a

Codensity ((->) s) a ~
forall r. (a -> s -> r) -> s -> r

Ran Identity ((->) s) a ~
Yoneda ((->) s) a ~
forall r. (a -> r) -> s -> r

type Rule m a = (m -> a) -> a

data Move = R | S | L deriving (Eq, Enum, Bounded, Show, Read)

rule :: Word8 -> Rule Move Bool
rule w f = testBit w $ 0 L.& partsOf L.bits .~ (f <$> [minBound .. maxBound])

data Move2 = RR | R | S | L | LL deriving (Eq, Enum, Bounded, Show, Read)

rule :: (Enum m, Bounded m, Num n, Bits n) => n -> Rule m Bool
rule w f = testBit w $ 0 L.& partsOf L.bits .~ (f <$> [minBound .. maxBound])

type Act m s = m -> s -> s

flat :: Act Move Int
flat L i = i-1
flat S i = i
flat R i = i+1

modulo :: Int -> Act Move Int
modulo n m i = flat m i `mod` n

step :: Act m s -> Rule m a -> Context s s a -> a

[03:35] edwardk:   @djinn a -> a
[03:35] lambdabot: f a = a
[03:35] edwardk:   @djinn a -> b -> c
[03:35] lambdabot: -- f cannot be realized.
[03:35] edwardk:   @djinn a -> b -> a
[03:35] lambdabot: f a _ = a

[03:35] edwardk: @djinn-add data Context a b t = Context (b -> t) a

[03:37] edwardk:   @djinn Context a a t -> t
[03:37] lambdabot: f a =
[03:37] lambdabot:  case a of
[03:37] lambdabot:  Context b c -> b c

[03:39] edwardk:   @djinn (Context b c t -> r) -> Context a c t -> Context a b r
[03:39] lambdabot: f a b =
[03:39] lambdabot:  case b of
[03:39] lambdabot:  Context c d -> Context (\ e -> a (Context c e)) d

[03:42] edwardk: @djinn-add type Rule m a = (m -> a) -> a
[03:42] edwardk: @djinn-add type Act m s = m -> s -> s

[03:43] edwardk:   @djinn Act m s -> Rule m a -> Context s s a -> a
[03:43] lambdabot: f _ a b =
[03:43] lambdabot:  case b of
[03:43] lambdabot:  Context c d -> a (\ _ -> c d)

[03:45] edwardk:   @djinn (Context a a t -> r) -> Context a a t -> Context a a r
[03:45] lambdabot: f a b =
[03:45] lambdabot:      case b of
[03:45] lambdabot:      Context c d -> Context (\ e -> a (Context (\ _ -> c d) e)) d

[03:46] edwardk:   @djinn-add type Acts m s t = m -> s -> t
[03:46] edwardk:   @djinn Acts m s t -> Rule m a -> Context s t a -> a
[03:46] lambdabot: f a b c =
[03:46] lambdabot:  case c of
[03:46] lambdabot:  Context d e -> b (\ f -> d (a f e))

step :: Act m s -> Rule m a -> Context s s a -> a
step a b (Context d e) = b (\f -> d (a f e))

step :: Act m s -> Rule m a -> Context s s a -> a
step top r (Context f s) = r (f . flip top s)

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
import Codec.Compression.Zlib
import Control.Comonad
import Control.Lens as L
import Control.Lens.Internal.Context
import Data.Binary
import Data.Binary.Put
import Data.Bits
import Data.Bits.Lens as L
import Data.ByteString.Lazy as Lazy
import Data.Foldable as F
import Data.List as List
import Data.MemoCombinators
import Data.Monoid
import Data.Vector.Unboxed as Unboxed
import Yesod

type Rule m a = (m -> a) -> a

data Move = R | S | L deriving (Eq, Enum, Bounded, Show, Read)

rule :: (Enum m, Bounded m) => Word8 -> Rule m Bool
rule w f = testBit w $ 0 L.& partsOf L.bits .~ (f <$> [minBound .. maxBound])

type Act m s = m -> s -> s

modulo :: Int -> Act Move Int
modulo m L i = (i-1) `mod` m
modulo _ S i = i
modulo m R i = (i+1) `mod` m

step :: Act m s -> Rule m a -> Context s s a -> a
step top r (Context f s) = r (f . flip top s)

loop :: Integral s => (Context s s a -> a) -> Context s s a -> [Context s s a]
loop f = List.iterate (tab . extend f) . tab where
  tab (Context g s) = Context (integral g) s

run :: Word8 -> Int -> Int -> [[Word8]]
run r x m0 = fmap line $ loop (step (modulo m0) (rule r)) $ Context (==0) 0 where
  line = fmap bw . window (x `div` 2)
  bw True  = 0
  bw False = 255
  window w = iexperiment $ \ s -> [s-w..s+w]

crc32 :: Lazy.ByteString -> Word32
crc32 = complement . Lazy.foldl' f 0xffffffff where
  f r b = unsafeShiftR r 8 `xor` crcs Unboxed.! fromIntegral (xor r (fromIntegral b) .&. 0xff)
  crcs = Unboxed.generate 256 (go.go.go.go.go.go.go.go.fromIntegral)
  go c = unsafeShiftR c 1 `xor` if c .&. 1 /= 0 then 0xedb88320 else 0

putChunk :: Lazy.ByteString -> Lazy.ByteString -> Put
putChunk h b = do
  putWord32be $ fromIntegral (Lazy.length b)
  putLazyByteString h
  putLazyByteString b
  putWord32be $ crc32 (h <> b)

png :: Int -> Int -> [[Word8]] -> Lazy.ByteString
png w h fs = runPut $ do
  putLazyByteString "\x89PNG\r\n\x1a\n"
  putChunk "IHDR" $ runPut $ do
    putWord32be (fromIntegral w)
    putWord32be (fromIntegral h)
    putWord8 8 -- 8 bit
    putWord8 0 -- greyscale
    putWord8 0
    putWord8 0
    putWord8 0
  putChunk "IDAT" $
    compressWith defaultCompressParams { compressLevel = bestSpeed } $
    runPut $ F.forM_ (Prelude.take h fs) $ \xs -> do
      putWord8 0
      F.forM_ (Prelude.take w xs) put
  putChunk "IEND" mempty

data App = App
instance Yesod App
mkYesod "App" [parseRoutes| / ImageR GET |]

main :: IO ()
main = warpEnv App

getImageR :: MonadHandler m => m TypedContent
getImageR = sendResponse $ toTypedContent (typePng, toContent img) where
  img = png 280 280 $ run 110 280 30

class Recursive t where
  data D t :: * -> *
  walk   :: Applicative f => (a -> f b) -> D t a -> f (D t b)
  ...

instance Recursive t => Functor (D t) where
  fmap = fmapDefault

instance Recursive t => Foldable (D t) where
  foldMap = foldMapDefault

instance Recursive t => Traversable (D t) where
  traverse = walk

class Recursive t where
  ...
  plug   :: D t t -> t -> t

class Recursive t where
  ...
  path :: t -> Maybe (D t t, t)

class Recursive t where
  data D t :: * -> *
  plug :: D t t -> t -> t
  walk :: Applicative f => (a -> f b) -> D t a -> f (D t b)
  path :: t -> Maybe (D t t, t)

type Z t = [D t t]

divide :: Recursive t => t -> Z t
divide = unfoldr path

zipped :: Recursive t => Z t -> t -> t
zipped dt t = Prelude.foldr plug t dt

data Nat = Z | S Nat

instance Recursive Nat where
  data D Nat a = Succ
  plug Succ = S
  walk _ Succ = pure Succ
  path (S n) = Just (Succ, n)
  path Z     = Nothing

data Conquer t a = forall b. Monoid b => Conquer (b -> a) (D t b -> b)

newtype M a p = M { runM :: a }

instance Reifies p (a -> a -> a, a)  => Monoid (M a p) where
  mempty = M $ snd $ reflect (Proxy :: Proxy p)
  mappend (M a) (M b) = M $ fst (reflect (Proxy :: Proxy p)) a b

conquer :: forall t a b. Recursive t =>
  (b -> a) -> (D t b -> b) -> (b -> b -> b) -> b -> Conquer t a
conquer k h m z = reify (m,z) $ \(Proxy :: Proxy p) -> Conquer
   (k . runM :: M b p -> a) (M . h . fmap runM)

run :: Recursive t => Conquer t a -> t -> a
run (Conquer k h) = k . go where
  go = foldMap (h . fmap go) . divide

data Pair a b = Pair { pi1 :: !a, pi2 :: !b }

instance (Monoid a, Monoid b) => Monoid (Pair a b) where
  mempty = Pair mempty mempty
  mappend (Pair a b) (Pair c d) = Pair (mappend a c) (mappend b d)

instance Functor (Conquer t) where
  fmap f (Conquer k h) = Conquer (f.k) h

instance Comonad (Conquer t) where
  extract (Conquer k h) = k mempty
  duplicate (Conquer k h) = Conquer (\b -> Conquer (k . mappend b) h) h

instance Recursive t => Applicative (Conquer t) where
  pure a = Conquer (const a) (const ())
  Conquer kf hf <*> Conquer ka ha = Conquer
    (\(Pair bf ba) -> kf bf (ka ba))
    (\dab -> Pair (hf (pi1 <$> dab)) (ha (pi2 <$> dab)))

instance Recursive t => ComonadApply (Conquer t) where
  (<@>) = (<*>)

above :: Recursive t => Z t -> Conquer t a -> Conquer t a
above t0 (Conquer k h) = let x = go t0 in Conquer (k . mappend x) h where
  go = foldMap (h . fmap (go . divide))

below :: Recursive t => Conquer t a -> Z t -> Conquer t a
below (Conquer k h) t0 = let y = go t0 in Conquer (\x -> k (mappend x y)) h where
  go = foldMap (h . fmap (go . divide))

instance Recursive [a] where
  data D [a] b = Cons { getCons :: a} deriving (Show,Read)
  plug (Cons a) as = a : as
  walk _ = pure . Cons . getCons
  path (x:xs)   = Just (Cons x, xs)
  path []       = Nothing

sumList :: Conquer [Int] Int
sumList = Conquer getSum (Sum . getCons)

>>> run sumList [1,2,3]
6

>>> run (run (duplicate sumList) [1,2,3]) [4,5]
15

>>> run (above (divide [1,2,3]) sumList) [4,5]
15

data Tree a
  = Bin (Tree a) a (Tree a)
  | Tip deriving (Show,Read)

instance Recursive (Tree a) where
  data D (Tree a) b = L a b | R b a deriving (Show,Read)

  plug (L a r) l = Bin l a r
  plug (R l a) r = Bin l a r

  walk f (L a b) = L a <$> f b
  walk f (R b a) = (`R` a) <$> f b

  path (Bin l a r) = Just (L a r, l)
  path Tip = Nothing

sumTree :: Num a => Conquer (Tree a) a
sumTree = Conquer getSum $ \ case
  L a (Sum b) -> Sum (a + b)
  R (Sum b) a -> Sum (a + b)

>>> run sumTree (Bin (Bin Tip 1 Tip) 2 Tip)
3

unfoldTree :: (s -> Maybe (s, a, s)) -> s -> Tree a
unfoldTree f s = case f s of
  Nothing -> Tip
  Just (l, a, r) -> Bin (unfoldTree f l) a (unfoldTree f r)

takeTree :: Int -> Tree a -> Tree a
takeTree 0 _   = Tip
takeTree n Tip = Tip
takeTree n (Bin l a r) = Bin (takeTree (n-1) l) a (takeTree (n-1) r)

sternBrocot :: Tree Rational
sternBrocot = unfoldTree
  (\(Pair a b) -> Just (Pair (a+1) b, a % b, Pair a (b+1)))
  (Pair 1 1)

>>> run sumTree $ takeTree 12 sternBrocot
26859127 % 5544

mpw :: (Num a, Ord a) => Conquer (Tree a) a
mpw = conquer k h m (Pair 0 0) where
  k (Pair a _) = a
  h (L n m) = Pair (n + k m) n
  h (R m n) = Pair (n + k m) n
  m (Pair m1 w1) (Pair m2 w2) = Pair (max m1 (w1 + m2)) (w1 + w2)

>>> run mpw (Bin (Bin Tip 1 Tip) 2 (Bin (Bin Tip 2 Tip) 3 Tip))
7

height :: Conquer (Tree a) Int
height = conquer k h m (Pair 0 0) where
  k (Pair a _) = a + 1
  h (L n m) = Pair (k m) 1
  h (R m n) = Pair (k m) 1
  m (Pair m1 w1) (Pair m2 w2) = Pair (max m1 (w1 + m2)) (w1 + w2)

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

import Control.Applicative
import Control.Comonad
import Control.Parallel.Strategies
import Data.Foldable
import Data.List (unfoldr)
import Data.Monoid
import Data.Proxy
import Data.Ratio
import Data.Reflection (reify, Reifies(..))
import Data.Traversable

class Recursive t where
  data D t :: * -> *
  plug   :: D t t -> t -> t
  walk   :: Applicative f => (a -> f b) -> D t a -> f (D t b)
  path :: t -> Maybe (D t t, t)

instance Recursive t => Functor (D t) where
  fmap = fmapDefault

instance Recursive t => Foldable (D t) where
  foldMap = foldMapDefault

instance Recursive t => Traversable (D t) where
  traverse = walk

type Z t = [D t t]

divide :: Recursive t => t -> Z t
divide = unfoldr path

zipped :: Recursive t => Z t -> t -> t
zipped dt t = Prelude.foldr plug t dt

run :: Recursive t => Conquer t a -> t -> a
run (Conquer k h) = k . go where
  go = foldMap (h . fmap go) . divide
{-# INLINE run #-}

runPar :: Recursive t => Conquer t a -> t -> a
runPar (Conquer k h) = k . go where
  go = foldMap (h . (`using` parTraversable rseq) . fmap go) . divide
{-# INLINE runPar #-}

above :: Recursive t => Z t -> Conquer t a -> Conquer t a
above t0 (Conquer k h) = let x = go t0 in Conquer (k . mappend x) h where
  go = foldMap (h . fmap (go . divide))
{-# INLINE above #-}

below :: Recursive t => Conquer t a -> Z t -> Conquer t a
below (Conquer k h) t0 = let y = go t0 in Conquer (\x -> k (mappend x y)) h where
  go = foldMap (h . fmap (go . divide))
{-# INLINE below #-}

newtype M a p = M { runM :: a }

instance Reifies p (a -> a -> a, a)  => Monoid (M a p) where
  mempty = M $ snd $ reflect (Proxy :: Proxy p)
  mappend (M a) (M b) = M $ fst (reflect (Proxy :: Proxy p)) a b

conquer :: forall t a b. Recursive t => (b -> a) -> (D t b -> b) -> (b -> b -> b) -> b -> Conquer t a
conquer k h m z = reify (m,z) $ \(Proxy :: Proxy p) -> Conquer
   (k . runM :: M b p -> a) (M . h . fmap runM)

-- * The Main Attraction

data Conquer t a = forall b. Monoid b => Conquer (b -> a) (D t b -> b)

-- * Instances

data Pair a b = Pair { pi1 :: !a, pi2 :: !b }

instance (Monoid a, Monoid b) => Monoid (Pair a b) where
  mempty = Pair mempty mempty
  mappend (Pair a b) (Pair c d) = Pair (mappend a c) (mappend b d)

instance Functor (Conquer t) where
  fmap f (Conquer k h) = Conquer (f.k) h

instance Comonad (Conquer t) where
  extract (Conquer k h) = k mempty
  duplicate (Conquer k h) = Conquer (\b -> Conquer (k . mappend b) h) h

instance Recursive t => ComonadApply (Conquer t) where
  (<@>) = (<*>)

instance Recursive t => Applicative (Conquer t) where
  pure a = Conquer (const a) (const ())
  Conquer kf hf <*> Conquer ka ha = Conquer
    (\(Pair bf ba) -> kf bf (ka ba))
    (\dab -> Pair (hf (pi1 <$> dab)) (ha (pi2 <$> dab)))

-- * Naturals

data Nat = Z | S Nat

instance Recursive Nat where
  data D Nat a = Succ
  plug Succ = S
  walk _ Succ = pure Succ
  path (S n) = Just (Succ, n)
  path Z     = Nothing

nat :: Conquer Nat Int
nat = Conquer getSum (\Succ -> Sum 1)

-- * Lists

instance Recursive [a] where
  data D [a] b = Cons { getCons :: a} deriving (Show,Read)
  plug (Cons a) as = a : as
  walk _ = pure . Cons . getCons
  path (x:xs)   = Just (Cons x, xs)
  path []       = Nothing

sumList :: Conquer [Int] Int
sumList = Conquer getSum (Sum . getCons)

-- * Trees

data Tree a
  = Bin (Tree a) a (Tree a)
  | Tip deriving (Show,Read)

instance Recursive (Tree a) where
  data D (Tree a) b = L a b | R b a deriving (Show,Read)

  plug (L a r) l = Bin l a r
  plug (R l a) r = Bin l a r

  walk f (L a b) = L a <$> f b
  walk f (R b a) = (`R` a) <$> f b

  path (Bin l a r) = Just (L a r, l)
  path Tip = Nothing

unfoldTree :: (s -> Maybe (s, a, s)) -> s -> Tree a
unfoldTree f s = case f s of
  Nothing -> Tip
  Just (l, a, r) -> Bin (unfoldTree f l) a (unfoldTree f r)

sternBrocot :: Tree Rational
sternBrocot = unfoldTree (\(Pair a b) -> Just (Pair (a+1) b, a % b, Pair a (b+1))) (Pair 1 1)

takeTree :: Int -> Tree a -> Tree a
takeTree 0 _   = Tip
takeTree n Tip = Tip
takeTree n (Bin l a r) = Bin (takeTree (n-1) l) a (takeTree (n-1) r)

sumTree :: Num a => Conquer (Tree a) a
sumTree = Conquer getSum h where
  h (L a (Sum b)) = Sum (a + b)
  h (R (Sum b) a) = Sum (a + b)

mpw :: (Num a, Ord a) => Conquer (Tree a) a
mpw = conquer k h m (Pair 0 0) where
  k (Pair a _) = a
  h (L n m) = Pair (n + k m) n
  h (R m n) = Pair (n + k m) n
  m (Pair m1 w1) (Pair m2 w2) = Pair (max m1 (w1 + m2)) (w1 + w2)
{-# INLINE mpw #-}

height :: Conquer (Tree a) Int
height = conquer k h m (Pair 0 0) where
  k (Pair a _) = a + 1
  h (L n m) = Pair (k m) 1
  h (R m n) = Pair (k m) 1
  m (Pair m1 w1) (Pair m2 w2) = Pair (max m1 (w1 + m2)) (w1 + w2)
{-# INLINE height #-}

main = do
  print $ run height Tip
  print $ run height (Bin (Bin Tip 1 Tip) 2 (Bin Tip 3 Tip))
  print $ run ((/) <$> mpw <*> sumTree) (takeTree 10 sternBrocot)

runPar :: Recursive t => Conquer t a -> t -> a
runPar (Conquer k h) = k . go where
  go = foldMap (h . (`using` parTraversable rseq) . fmap go) . divide

{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-}
import Data.Bits
import Data.ByteString.Lazy as Lazy
import Data.ByteString.Lazy.Char8 ()
import Data.Vector.Unboxed as Unboxed
import Data.Word

data L b a = forall x. L (x -> b -> x) x (x -> a)

runL :: L Word8 a -> Lazy.ByteString -> a
runL (L xbx x xa) bs = xa (Lazy.foldl' xbx x bs)

crc32 :: L Word8 Word32
crc32 = L step 0xffffffff complement where
  step r b = unsafeShiftR r 8
     `xor` crcs Unboxed.! fromIntegral (xor r (fromIntegral b) .&. 0xff)

crcs :: Unboxed.Vector Word32
crcs = Unboxed.generate 256 (go.go.go.go.go.go.go.go.fromIntegral) where
  go c = unsafeShiftR c 1 `xor` if c .&. 1 /= 0 then 0xedb88320 else 0

main = print $ runL crc32 "12345689"

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Data.Bits
import Data.Word

newtype GF = GF { runGF :: Word32 } deriving (Eq,Show,Read,Bits)

poly :: GF
poly = GF 0xedb88320 -- -- x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1

-- | compute x * p(x)
xtimes :: GF -> GF
xtimes c = unsafeShiftR c 1 + if testBit c 0 then poly else 0

instance Num GF where
  (+) = xor
  (-) = xor
  _ * 0 = 0
  a * b = xtimes a * unsafeShiftL b 1 + if testBit b 31 then a else 0
  negate = id
  abs = id
  signum = fromIntegral . signum . runGF
  fromInteger i
    | odd i     = GF 0x80000000 -- x^0
    | otherwise = GF 0          -- 0

main = putStrLn "It compiles, so it is obviously correct."

x :: GF
x = GF 0x40000000

-- | peasant exponentiation
xpow :: Int -> GF
xpow 0 = 1
xpow 1 = x
xpow n = case divMod n 2 of
  (q,0) ->          square (xpow q)
  (q,1) -> xtimes $ square (xpow q)
  _     -> error "unimplemented: extended Euclidean algorithm"
  where square a = a * a

-- | @x^31 + x^30 + ... + x + 1@
ones :: GF
ones = GF 0xffffffff

data CRC32 = CRC32
  {-# UNPACK #-} !GF
  {-# UNPACK #-} !GF
  deriving (Eq,Read,Show)

instance Monoid CRC32 where
  CRC32 p m `mappend` CRC32 q n = CRC32 (p*n+q) (m*n)
  mempty = CRC32 0 1

crcs :: UArray Word8 GF
crcs = listArray (0,255) $ map (xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.GF) [0..255]

byte :: Word8 -> CRC32
byte a = CRC32 (crcs ! a) (x^8) -- x^8 = GF 0x800000

runCRC :: CRC32 -> Word32
runCRC (CRC32 p m) = runGF (ones * m + p + ones)

{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

import Control.Comonad
import Data.Bits
import Data.Foldable as Foldable
import Data.Monoid
import Data.Profunctor
import Data.Array.Unboxed
import Data.Word

newtype GF = GF { runGF :: Word32 } deriving (Eq,Show,Read,Bits,IArray UArray)

poly :: GF
poly = GF 0xedb88320 -- x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1

-- | compute x * p(x)
xtimes :: GF -> GF
xtimes c = unsafeShiftR c 1 + if testBit c 0 then poly else 0

instance Num GF where
  (+) = xor
  (-) = xor
  _ * 0 = 0
  a * b = xtimes a * unsafeShiftL b 1 + if testBit b 31 then a else 0
  negate = id
  abs = id
  signum = fromIntegral . signum . runGF
  fromInteger i
    | odd i     = GF 0x80000000 -- x^0
    | otherwise = GF 0          -- 0

x :: GF
x = GF 0x40000000 -- x^1

ones :: GF
ones = GF 0xffffffff -- | x^31+x^30+...+x+1

data CRC32 = CRC32 {-# UNPACK #-} !GF {-# UNPACK #-} !GF deriving (Eq,Read,Show)

instance Monoid CRC32 where
  CRC32 p m `mappend` CRC32 q n = CRC32 (p*n+q) (m*n)
  mempty = CRC32 0 1

crcs :: UArray Word8 GF
crcs = listArray (0,255) $ map (xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.GF) [0..255]

runCRC :: CRC32 -> Word32
runCRC (CRC32 p m) = runGF (ones * m + p + ones)

byte :: Word8 -> CRC32
byte a = CRC32 (crcs ! a) (x^8)

main = print $ runCRC $ foldMap (byte.fromIntegral.fromEnum) "123456789"

data M a b = forall r. M (r -> b) (a -> r) (r -> r -> r) r

instance Profunctor M where
  dimap f g (M k h m e) = M (g.k) (h.f) m e

runM :: Foldable f => M a b -> f a -> b
runM (M k h m z) xs = k (Foldable.foldr (m.h) z xs)

newtype Slow a = Slow { runSlow :: (a -> a -> a) -> a -> a }

instance Monoid (Slow a) where
  mempty = Slow (\_ e -> e)
  mappend (Slow f) (Slow g) = Slow $ \p e = runSlow f p e `p` runShow g p e

newtype N a s = N { runN :: a }

instance Reifies s (a -> a -> a, a) => Monoid (N a s) where
  mempty = N $ snd $ reflect (Proxy :: Proxy s)
  mappend (N a) (N b) = N $ fst (reflect (Proxy :: Proxy s)) a b

runM :: Foldable f => M a b -> f a -> b
runM (M k h m (z :: m)) s = reify (m, z) $
    \ (_ :: Proxy s) -> k $ runN (foldMap (N #. h) s :: N m s)

instance Comonad (L a) where
  extract (L k _ z) = k z
  duplicate (L k h z) = L (L k h) h z

duplicate :: L a b -> L a (L a b)

instance Comonad (M b) where
  extract (M k _ _ z) = k z
  duplicate (M k h m z) = M (\n -> M (k . m n) h m z) h m z

extract = more []
more xs =<= more ys = more (xs ++ ys)

more (xs ++ ys) = more xs =<= more ys = more xs . extend (more ys)

more xs . extend (more ys) = more xs . fmap (more ys) . duplicate

more (xs ++ ys) = more ys . more xs . duplicate

{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleContexts, UndecidableInstances #-}

import Control.Comonad
import Data.Bits
import Data.Foldable as Foldable
import Data.Monoid
import Data.Profunctor.Unsafe
import Data.Proxy
import Data.Reflection
import Data.Array.Unboxed
import Data.Word

newtype GF = GF { runGF :: Word32 } deriving (Eq,Show,Read,Bits,IArray UArray)

-- | @x^32 + x^26 + x^23 + x^22 + x^16 + x^12 + x^11 + x^10 + x^8 + x^7 + x^5 + x^4 + x^2 + x + 1@
poly :: GF
poly = GF 0xedb88320 -- the polynomial we're working modulo in GF(2^32) for CRC32.

-- | compute x * p(x)
xtimes :: GF -> GF
xtimes c = unsafeShiftR c 1 + if testBit c 0 then poly else 0

instance Num GF where
  (+) = xor
  (-) = xor
  _ * 0 = 0
  a * b = xtimes a * unsafeShiftL b 1 + if testBit b 31 then a else 0
  negate = id
  abs = id
  signum = fromIntegral . signum . runGF
  fromInteger i
    | odd i     = GF 0x80000000 -- x^0
    | otherwise = GF 0          -- 0

-- | @x^1@
x :: GF
x = GF 0x40000000

-- | @x^31 + x^30 + ... + x + 1@
ones :: GF
ones = GF 0xffffffff

data CRC32 = CRC32 {-# UNPACK #-} !GF {-# UNPACK #-} !GF deriving (Eq,Read,Show)

instance Monoid CRC32 where
  CRC32 p m `mappend` CRC32 q n = CRC32 (p*n+q) (m*n)
  mempty = CRC32 0 1

crcs :: UArray Word8 GF
crcs = listArray (0,255) $ map (xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.GF) [0..255]

runCRC :: CRC32 -> Word32
runCRC (CRC32 p m) = runGF (ones * m + p + ones)

byte :: Word8 -> CRC32
byte a = CRC32 (crcs ! a) (x^8)

data M a b where
  M :: (r -> b) -> (a -> r) -> (r -> r -> r) -> r -> M a b

instance Functor (M a) where
  fmap f (M k h m z) = M (f.k) h m z

instance Profunctor M where
  dimap f g (M k h m z) = M (g.k) (h.f) m z

instance Comonad (M a) where
  extract (M k _ _ z) = k z
  duplicate (M k h m z) = M (\n -> M (k . m n) h m z) h m z

newtype N a s = N { runN :: a }

instance Reifies s (a -> a -> a, a) => Monoid (N a s) where
  mempty = N $ snd $ reflect (Proxy :: Proxy s)
  mappend (N a) (N b) = N $ fst (reflect (Proxy :: Proxy s)) a b

runM :: Foldable f => M a b -> f a -> b
runM (M k h m (z :: m)) s = reify (m, z) $
    \ (_ :: Proxy s) -> k $ runN (foldMap (N #. h) s :: N m s)

runR :: Foldable f => M a b -> f a -> b
runR (M k h m z) xs = k (Foldable.foldr (m.h) z xs)

runL :: Foldable f => M a b -> f a -> b
runL (M k h m z) xs = k (Foldable.foldl' (\r -> m r . h) z xs)

crc32 :: M Word8 Word32
crc32 = M runCRC byte mappend mempty

main = print $ runM crc32 [0x12,0x34]

{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

import Control.Comonad
import Data.Bits
import Data.Foldable as Foldable
import Data.Monoid
import Data.Profunctor
import Data.Proxy
import Data.Reflection
import Data.Array.Unboxed
import Data.Word

newtype GF a s = GF { runGF :: a } deriving (Eq,Show,Read,Bits)

deriving instance IArray UArray a => IArray UArray (GF a s)

-- | compute x * p(x)
xtimes :: (Integral a, Bits a, Reifies s a) => GF a s -> GF a s
xtimes c = unsafeShiftR c 1 + if testBit c 0 then GF (reflect c) else 0
{-# INLINE xtimes #-}

instance (Integral a, Bits a, Reifies s a) => Num (GF a s) where
  (+) = xor
  (-) = xor
  _ * 0 = 0
  a * b = xtimes a * unsafeShiftL b 1 + if testBit b (bitSize b - 1) then a else 0
  negate = id
  abs = id
  signum = fromIntegral . signum . runGF
  fromInteger i
    | odd i     = GF (bit (bitSize (undefined :: a) - 1)) -- x^0
    | otherwise = GF 0                     -- 0

-- | @x^1@
x :: forall a s. Bits a => GF a s
x = GF (bit (bitSize (undefined :: a) - 2))
{-# INLINE x #-}

data CRC a = CRC !a !a deriving (Eq,Read,Show)

instance Num a => Monoid (CRC a) where
  CRC p m `mappend` CRC q n = CRC (p*n+q) (m*n)
  mempty = CRC 0 1

crc :: forall a. (Integral a, Bits a, IArray UArray a) => a -> a -> a -> M Word8 a
crc _INIT _FINAL poly = reify poly $ \(_ :: Proxy s) ->
  let crcs :: UArray Word8 (GF a s)
      crcs = listArray (0,255) $ map (xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.xtimes.GF) [0..255]
      k (CRC p m) = runGF (GF _INIT * m + p + GF _FINAL)
      h a = CRC (crcs ! a) (x^8)
  in M k h mappend mempty
{-# INLINE crc #-}

-- | @x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1@
crc32 :: M Word8 Word32
crc32 = crc 0xffffffff 0xffffffff 0xedb88320

crc64_ecma182 :: M Word8 Word64
crc64_ecma182 = crc (-1) (-1) 0xC96C5795D7870F42

crc8 :: M Word8 Word8
crc8 = crc 0xff 0xff 0xab

crc8_sae :: M Word8 Word8
crc8_sae = crc 0xff 0xff 0xb8

data M a b where
  M :: (r -> b) -> (a -> r) -> (r -> r -> r) -> r -> M a b

instance Functor (M a) where
  fmap f (M k h m z) = M (f.k) h m z

instance Profunctor M where
  dimap f g (M k h m z) = M (g.k) (h.f) m z

instance Comonad (M a) where
  extract (M k _ _ z) = k z
  duplicate (M k h m z) = M (\n -> M (k . m n) h m z) h m z

runM :: Foldable f => M a b -> f a -> b
runM (M k h m z) xs = k (Foldable.foldr (m.h) z xs)

main = print $ runM crc32 [0x12,0x34]

class NFData a where
  rnf :: a -> ()

import Control.DeepSeq
import Control.Lens
import Data.Copointed
import Data.Foldable

data Once a = Once () a

runOnce :: Once a -> a
runOnce (Once _ a) = a

once :: NFData a => a -> Once a
once a = Once (rnf a) a

instance NFData (Once a) where
  rnf (Once () _) = ()

instance Foldable Once where
  foldMap f (Once _ a) = f a

instance Copointed Once where
  copoint (Once _ a) = a

_Once :: NFData a => Iso' (Once a) a
_Once = iso runOnce once

main = putStrLn "It compiled."

_Once :: NFData a => Iso' (Once a) a
_Once = iso runOnce once

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}

import Codec.Compression.Zlib
import Control.Lens
import Control.DeepSeq
import Control.Parallel.Strategies
import Data.Bits
import Data.Binary
import Data.Binary.Put
import Data.Complex
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Vector.Unboxed as Unboxed
import Data.Foldable as F
import Data.Monoid
import Yesod

-- * Mandelbrot

mandelbrot :: Int -> Int -> Int -> Lazy.ByteString
mandelbrot n w h = png w h $ \r i ->
 maybe 0 scale $ steps $ (r/.w*3-2) :+ (i/.h*2-1)
 where
   x /. y = fromIntegral x / fromIntegral y :: Double
   scale k = floor (k /. n * 255)
   diverges (r :+ i) = r^2 + i^2 > 4
   steps c = iterate (\z -> z^2 + c) 0 ^?
     taking n ifolded.filtered diverges.asIndex

-- * Folds

data L b a = forall x. L (x -> b -> x) x (x -> a)

more :: Lazy.ByteString -> L Word8 a -> a
more bs (L xbx x xa) = xa (Lazy.foldl' xbx x bs)

-- * CRC32

crc32 :: L Word8 Word32
crc32 = L step 0xffffffff complement where
  step r b = unsafeShiftR r 8 `xor` crcs Unboxed.! fromIntegral (xor r (fromIntegral b) .&. 0xff)

crcs :: Unboxed.Vector Word32
crcs = Unboxed.generate 256 (go.go.go.go.go.go.go.go.fromIntegral) where
  go c = unsafeShiftR c 1 `xor` if c .&. 1 /= 0 then 0xedb88320 else 0

-- * PNG

putChunk :: Lazy.ByteString -> Lazy.ByteString -> Put
putChunk h b = do
  putWord32be $ fromIntegral (Lazy.length b)
  putLazyByteString h
  putLazyByteString b
  putWord32be $ more (h <> b) crc32

putChunks :: Lazy.ByteString -> Lazy.ByteString -> Put
putChunks h b = forM_ (Lazy.toChunks b) (putChunk h . Lazy.fromChunks . return)

png :: Int -> Int -> (Int -> Int -> Word8) -> Lazy.ByteString
png w h p = runPut $ do
  putLazyByteString "\x89PNG\r\n\x1a\n"
  putChunk "IHDR" $ runPut $ do
    putWord32be (fromIntegral w)
    putWord32be (fromIntegral h)
    putWord8 8 -- 8 bit color depth
    putWord8 0 -- greyscale
    putWord8 0
    putWord8 0
    putWord8 1 -- Adam7 interlaced
  putChunks "IDAT" $
    compressWith defaultCompressParams { compressLevel = bestSpeed } $ runPut $ do
      pass [0,8 ..h-1] [0,8..w-1]
      pass [0,8 ..h-1] [4,12..w-1]
      pass [4,12..h-1] [0,4..w-1]
      pass [0,4 ..h-1] [2,6..w-1]
      pass [2,6 ..h-1] [0,2..w-1]
      pass [0,2 ..h-1] [1,3..w-1]
      pass [1,3 ..h-1] [0..w-1]
  putChunk "IEND" mempty
  where
    pass ys xs = forM_ ys $ \y -> do
      putWord8 0
      F.mapM_ put (fmap (p ?? y) xs `using` parListChunk 16 rdeepseq)

-- * Yesod

data App = App
instance Yesod App
mkYesod "App" [parseRoutes| / ImageR GET |]

getImageR :: MonadHandler m => m TypedContent
getImageR = sendResponse
          $ toTypedContent (typePng, toContent img)
  where
    img = mandelbrot 32 600 300

main :: IO ()
main = warpEnv App

forM_ [0..w-1] $ \x -> put (p x y)

F.mapM_ put
  (fmap (p ?? y) [0..w-1] `using` parListChunk 16 rdeepseq)

putChunk "IDAT"

putChunks "IDAT"

putChunks :: Lazy.ByteString -> Lazy.ByteString -> Put
putChunks h b = forM_ (Lazy.toChunks b) $
  putChunk h . Lazy.fromChunks . return

    pass ys xs = forM_ ys $ \y -> do
      putWord8 0
      F.mapM_ put (fmap (p ?? y) xs `using` parListChunk 16 rdeepseq)

  putChunks "IDAT" $ compress $ runPut $ do
      pass [0..h-1] [0..w-1]

  putChunks "IDAT" $ compress $ runPut $ do
      pass [0,8 ..h-1] [0,8..w-1]
      pass [0,8 ..h-1] [4,12..w-1]
      pass [4,12..h-1] [0,4..w-1]
      pass [0,4 ..h-1] [2,6..w-1]
      pass [2,6 ..h-1] [0,2..w-1]
      pass [0,2 ..h-1] [1,3..w-1]
      pass [1,3 ..h-1] [0..w-1]

1 6 4 6 2 6 4 6
7 7 7 7 7 7 7 7
5 6 5 6 5 6 5 6
7 7 7 7 7 7 7 7
3 6 4 6 3 6 4 6
7 7 7 7 7 7 7 7
5 6 5 6 5 6 5 6
7 7 7 7 7 7 7 7

data Fold a b = forall x . Fold (x -> a -> x) x (x -> b)

instance Functor (Fold a) where
  fmap f (Fold rar r rb) = Fold rar r (f.rb)

data Pair a b = Pair !a !b

instance Applicative (Fold a) where
  pure b = Fold (\() _ -> ()) () (\() -> b)
  {-# INLINABLE pure #-}
  Fold sas s0 s2f <*> Fold rar r0 r2x = Fold
    (\(Pair s r) a -> Pair (sas s a) (rar r a))
    (Pair s0 r0)
    (\(Pair s r) -> s2f s (r2x r))
  {-# INLINABLE (<*>) #-}

instance Num b => Num (Fold a b) where
  (+) = liftA2 (+)
  (-) = liftA2 (-)
  (*) = liftA2 (*)
  abs = fmap abs
  signum = fmap signum
  fromInteger = pure . fromInteger

instance Fractional b => Fractional (Fold a b) where
  recip = fmap recip
  (/) = liftA2 (/)
  fromRational = pure . fromRational

instance Profunctor Fold where
  dimap f g (Fold rar r0 rb) = Fold (\r -> rar r . f) r0 (g . rb)

instance Comonad (Fold a) where
  extract (Fold _ r rb) = rb r
  duplicate (Fold rar r0 rb) = Fold rar r0 $ \r -> Fold rar r rb

instance ComonadApply (Fold a) where
  (<@>) = (<*>)

data FoldX x a b = Fold (x -> a -> x) x (x -> b)

{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-}

import Control.Comonad

import Control.Exception
import Control.Monad

data Env e a = Env e a deriving (Eq,Ord,Show,Read,Functor)

instance Comonad (Env e) where
  -- extract :: Env e a -> a
  extract (Env e a) = error "unimplemented exercise"

  -- duplicate :: Env e a -> Env e (Env e a)
  duplicate (Env e a) = error "unimplemented exercise"

main = do
  test "extract" $ extract (Env 1 2) == 2
  test "duplicate" $ duplicate (Env 1 2) == Env 1 (Env 1 2)

test :: String -> Bool -> IO ()
test s b = try (return $! b) >>= \ ec -> case ec of
  Left (e :: SomeException) -> putStrLn $ s ++ " failed: " ++ show e
  Right True -> putStrLn $ s ++ " is correct!"
  Right False -> putStrLn $ s ++ " is not correct!"

data StoreAndEnv s e a = StoreAndEnv e (s -> a) s

data StoreAndStep s b a = StoreAndStep (s -> b -> s) (s -> a) s

data Fold a b = forall s. Fold (s -> b -> s) (s -> a) s

data Moore b a = Moore a (b -> Moore b a)

{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-}

import Control.Comonad

import Control.Exception
import Control.Monad

data Moore b a = Moore a (b -> Moore b a) deriving Functor

instance Comonad (Moore b) where
  -- extract :: Moore b a -> a
  extract (Moore a as) = error "unimplemented exercise"

  -- duplicate :: Moore b a -> Moore b (Moore b a)
  duplicate w@(Moore _ as) = Moore w (duplicate <$> as)

  -- extend :: (Moore b a -> c) -> Moore b a -> Moore b c
  extend f w@(Moore _ as)  = Moore (f w) (extend f <$> as)

main = do
  test "extract" $ 1 == extract (Moore 1 $ error "you don't need to look in the tail")

test :: String -> Bool -> IO ()
test s b = try (return $! b) >>= \ ec -> case ec of
  Left (e :: SomeException) -> putStrLn $ s ++ " failed: " ++ show e
  Right True -> putStrLn $ s ++ " is correct!"
  Right False -> putStrLn $ s ++ " is not correct!"

data YonedaMoore a b = forall r. YonedaMoore (r -> a) (Moore a r)

moorel :: (a -> b -> a) -> a -> Moore b a
moorel f = go where
  go a = Moore a (go . f a)

moorel' :: (a -> b -> a) -> a -> Moore b a
moorel' f = go where
  go !a = Moore a (go . f a)

total :: Num a => Moore a a
total = moorel' (+) 0

count :: Num a => Moore b a
count = moorel' (\a _ -> a + 1) 0

data Moore b a = Moore { this :: a, less :: b -> Moore b a }

more :: Foldable t => t b -> Moore b a -> a
more xs m = extract (F.foldl' less m xs)

more :: Foldable t => t b -> Fold b a -> a
more xs m = extract (fold m xs)

(=<=) :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c
f =<= g = f . extend g

extract = more []
more as =<= more bs = more (as ++ bs)

data Adler32 = Adler32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32

adler32 :: Moore Word8 Word32
adler32 = done <$> moorel' step (Adler32 1 0) where
  step (Adler32 s1 s2) x = Adler32 s1' s2' where
    s1' = mod (s1 + fromIntegral x) 65521
    s2' = mod (s1' + s2) 65521
  done (Adler32 s1 s2) = unsafeShiftL s2 16 + s1

crc32 :: Moore Word8 Word32
crc32 = complement <$> moorel' step 0xffffffff where
  step r b = unsafeShiftR r 8 `xor` (crcs Unboxed.! fromIntegral (xor r (fromIntegral b) .&. 0xff))

crcs :: Unboxed.Vector Word32
crcs = Unboxed.generate 256 (go.go.go.go.go.go.go.go.fromIntegral) where
  go c = unsafeShiftR c 1 `xor` if c .&. 1 /= 0 then 0xedb88320 else 0

moreOf :: Getting (Endo (Endo (Moore b a))) s b -> s -> Moore b a -> a
moreOf l xs m = extract (foldlOf' l less m xs)

moreOf :: Fold s b -> s -> Moore b a -> a

putChunk :: Lazy.ByteString -> Put -> Put
putChunk h (runPut -> b) = do
  putWord32be $ fromIntegral (Lazy.length b)
  putLazyByteString h
  putLazyByteString b
  putWord32be $ moreOf bytes h =<= moreOf bytes b $ crc32

deflated :: Bool -> Lazy.ByteString -> Put
deflated final b | l <- fromIntegral (Lazy.length b) = do
  putWord8 $ if final then 1 else 0
  putWord16le l -- yep, now it's little endian!
  putWord16le (complement l)
  putLazyByteString b

zlibbed :: Lazy.ByteString -> Put
zlibbed bs = do
  putWord8 0x78
  putWord8 0x01
  go bs
  putWord32be $ moreOf bytes bs adler32
  where
    go (Lazy.splitAt 0xffff -> (xs, ys)) | done <- Lazy.null ys = do
      deflated done xs
      M.unless done (go ys)

png :: Int -> [Int -> (Word8, Word8, Word8)] -> Lazy.ByteString
png w fs = runPut $ do
  putLazyByteString "\x89PNG\r\n\x1a\n"
  putChunk "IHDR" $ do
    putWord32be $ fromIntegral w
    putWord32be $ fromIntegral (List.length fs)
    putWord8 8 -- 8 bit color depth
    putWord8 2 -- RGB
    putWord8 0
    putWord8 0
    putWord8 0
  putChunk "IDAT" $ zlibbed (runPut rows)
  putChunk "IEND" $ return ()
  where
    rows = forM_ fs $ \f -> do
      putWord8 0
      forM_ [0..w-1] (put . f)

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
import Control.Applicative
import Control.Comonad
import Control.Lens
import qualified Control.Monad as M
import Data.Bits
import Data.Binary
import Data.Binary.Put
import qualified Data.ByteString.Lazy as Lazy
import Data.ByteString.Lens
import Data.Monoid
import qualified Data.Vector.Unboxed as Unboxed
import Data.Foldable as F
import Data.List as List
import Yesod

-- * Moore machines

data Moore b a = Moore { this :: a, less :: b -> Moore b a }

instance Num a => Num (Moore b a) where
  (+) = liftA2 (+)
  (-) = liftA2 (-)
  (*) = liftA2 (*)
  abs = fmap abs
  signum = fmap signum
  fromInteger = pure . fromInteger

instance Fractional a => Fractional (Moore b a) where
  recip = fmap recip
  (/) = liftA2 (/)
  fromRational = pure . fromRational

instance Functor (Moore b) where
  fmap f = go where go (Moore a k) = Moore (f a) (go . k)

instance Comonad (Moore b) where
  extract = this
  duplicate w@(Moore _ as) = Moore w (duplicate . as)

instance ComonadApply (Moore b) where
  (<@>) = (<*>)

instance Applicative (Moore b) where
  pure a = as where as = Moore a (const as)
  Moore f fs <*> Moore a as = Moore (f a) $ \b -> fs b <*> as b

instance Profunctor Moore where
  dimap f g (Moore a as) = Moore (g a) (dimap f g . as . f)

moorel :: (a -> b -> a) -> a -> Moore b a
moorel f = go where go a = Moore a (go . f a)

moorel' :: (a -> b -> a) -> a -> Moore b a
moorel' f = go where go !a = Moore a (go . f a)

moreOf :: Getting (Endo (Endo (Moore b a))) s b -> s -> Moore b a -> a
moreOf l xs m = extract (foldlOf' l less m xs)

-- * Adler 32

data Adler32 = Adler32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32

adler32 :: Moore Word8 Word32
adler32 = done <$> moorel' step (Adler32 1 0) where
  step (Adler32 s1 s2) x = Adler32 s1' s2' where
    s1' = mod (s1 + fromIntegral x) 65521
    s2' = mod (s1' + s2) 65521
  done (Adler32 s1 s2) = unsafeShiftL s2 16 + s1

-- * CRC32

crc32 :: Moore Word8 Word32
crc32 = complement <$> moorel' step 0xffffffff where
  step r b = unsafeShiftR r 8 `xor` crcs Unboxed.! fromIntegral (xor r (fromIntegral b) .&. 0xff)

crcs :: Unboxed.Vector Word32
crcs = Unboxed.generate 256 (go.go.go.go.go.go.go.go.fromIntegral) where
  go c = unsafeShiftR c 1 `xor` if c .&. 1 /= 0 then 0xedb88320 else 0

-- * PNG

putChunk :: Lazy.ByteString -> Put -> Put
putChunk h (runPut -> b) = do
  putWord32be $ fromIntegral (Lazy.length b)
  putLazyByteString h
  putLazyByteString b
  putWord32be $ moreOf bytes h =<= moreOf bytes b $ crc32

deflated :: Bool -> Lazy.ByteString -> Put
deflated final b | l <- fromIntegral (Lazy.length b) = do
  putWord8 $ if final then 1 else 0
  putWord16le l -- yep, now it's little endian!
  putWord16le (complement l)
  putLazyByteString b

zlibbed :: Lazy.ByteString -> Put
zlibbed bs = do
  putWord8 0x78
  putWord8 0x01
  go bs
  putWord32be $ moreOf bytes bs adler32
  where
    go (Lazy.splitAt 0xffff -> (xs, ys)) | done <- Lazy.null ys = do
      deflated done xs
      M.unless done (go ys)

png :: Int -> [Int -> (Word8, Word8, Word8)] -> Lazy.ByteString
png w fs = runPut $ do
  putLazyByteString "\x89PNG\r\n\x1a\n"
  putChunk "IHDR" $ do
    putWord32be $ fromIntegral w
    putWord32be $ fromIntegral (List.length fs)
    putWord8 8 -- 8 bit color depth
    putWord8 2 -- RGB
    putWord8 0
    putWord8 0
    putWord8 0
  putChunk "IDAT" $ zlibbed (runPut rows)
  putChunk "IEND" $ return ()
  where
    rows = forM_ fs $ \f -> do
      putWord8 0
      forM_ [0..w-1] (put . f)

-- * Yesod

data App = App

instance Yesod App

mkYesod "App" [parseRoutes| / ImageR GET |]

main :: IO ()
main = warpEnv App

getImageR :: MonadHandler m => m TypedContent
getImageR = sendResponse $ toTypedContent (typePng, toContent img) where
  img = png 500 $ take 300 $ pixel <$> [0..]
  pixel y x = (fromIntegral x,fromInteger y,0)

loop f = iterate (tab . extend f) . tab

loop f = iterate (extend f . tab)

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Applicative
import Control.Comonad
import Codec.Compression.Zlib
import Control.Lens.Internal.Context
import Control.Lens as L
import Data.Bits
import Data.Bits.Lens as L
import Data.Monoid
import Data.Binary
import Data.Binary.Put
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Vector.Unboxed as Unboxed
import Data.Foldable as F
import Data.MemoTrie
import Yesod

rule :: Num s => Word8 -> Context s s Bool -> Bool
rule w (Context f s) = testBit w $ 0 L.& partsOf L.bits .~ [f (s+1), f s, f (s-1)]

loop :: HasTrie s => (Context s s a -> a) -> Context s s a -> [Context s s a]
loop f = iterate (tab . extend f) . tab where
  tab (Context k s) = Context (memo k) s

data L b a = forall x. L (x -> b -> x) x (x -> a)

more :: Lazy.ByteString -> L Word8 a -> a
more bs (L xbx x xa) = xa (Lazy.foldl' xbx x bs)

crc32 :: L Word8 Word32
crc32 = L step 0xffffffff complement where
  step r b = unsafeShiftR r 8 `xor` crcs Unboxed.! fromIntegral (xor r (fromIntegral b) .&. 0xff)

crcs :: Unboxed.Vector Word32
crcs = Unboxed.generate 256 (go.go.go.go.go.go.go.go.fromIntegral) where
  go c = unsafeShiftR c 1 `xor` if c .&. 1 /= 0 then 0xedb88320 else 0

putChunk :: Lazy.ByteString -> Lazy.ByteString -> Put
putChunk h b = do
  putWord32be $ fromIntegral (Lazy.length b)
  putLazyByteString h
  putLazyByteString b
  putWord32be $ more (h <> b) crc32

png :: Int -> Int -> [Int -> (Word8, Word8, Word8)] -> Lazy.ByteString
png w h fs = runPut $ do
  putLazyByteString "\x89PNG\r\n\x1a\n"
  putChunk "IHDR" $ runPut $ do
    putWord32be (fromIntegral w)
    putWord32be (fromIntegral h)
    putWord8 8 -- 8 bit color depth
    putWord8 2 -- RGB
    putWord8 0
    putWord8 0
    putWord8 0
  putChunk "IDAT" $
    compressWith defaultCompressParams { compressLevel = bestSpeed } $
    runPut $ forM_ (take h fs) $ \f -> do
      putWord8 0
      forM_ [0..w-1] (put . f)
  putChunk "IEND" mempty

data App = App
instance Yesod App
mkYesod "App" [parseRoutes| / ImageR GET |]
main = warpEnv App

getImageR :: MonadHandler m => m TypedContent
getImageR = sendResponse $ toTypedContent (typePng, toContent img) where
  img = png 150 150 $ draw <$> loop (rule 110) (Context (==149) 149)
  draw (Context p _) x = if p x then (0,0,0) else (255,255,255)

import Data.Word

data Key = Key {-# UNPACK #-} !Word {-# UNPACK #-} !Word

  deriving (Show, Read, Eq)

main = putStrLn "It typechecks."

import Data.Bits
import Data.Word

compares :: Word -> Word -> Ordering
compares a b = case compare a b of
  LT | a < xor a b -> LT
  GT | b < xor a b -> GT
  _ -> EQ

main = print $ compares 4 7

import Data.Bits
import Data.Word

lts, les, eqs, nes, ges, gts :: Word -> Word -> Bool
lts a b = a < b && a < xor a b
les a b = a <= b || xor a b <= b

eqs a b = a >= min b c && b >= max a c where c = xor a b
nes a b = a <  min b c || b <  min a c where c = xor a b
-- show ...
gts a b = a > b && xor a b > b
ges a b = a >= b || a >= xor a b

main = print $ les 4 7

import Data.Bits
import Data.Word

data Key = Key {-# UNPACK #-} !Word {-# UNPACK #-} !Word
  deriving (Show, Read, Eq)

lts :: Word -> Word -> Bool
lts a b = a < b && a < xor a b

instance Ord Key where
  Key a b `compare` Key c d
    | xor a c `lts` xor b d = compare b d
    | otherwise             = compare a c

main = putStrLn "It typechecks."

type Prefix = Int
type Mask   = Int

data IntMap a
  = Nil
  | Tip {-# UNPACK #-} !Int a
  | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)

data IntMap a
  = Nil
  | Tip {-# UNPACK #-} !Int a
  | Bin {-# UNPACK #-} !Int {-# UNPACK #-} !Int !(IntMap a) !(IntMap a)

data Class
  = FarLeft   -- differs on a higher msb, outside left branch
  | NearLeft  -- differs on the same msb, but outside current left branch
  | InLeft    -- within the left branch
  | InRight   -- within the right branch
  | NearRight -- differs on the same msb, but outside current right branch
  | FarRight  -- differs on a higher msb, outside right branch

significant :: Int -> Int -> Int -> Int -> Bool
significant a b c d = ab < cd && ab < xor ab cd where
  cd = xor c d
  ab = xor a b

import Data.Bits

data Class
  = FarLeft   -- differs on a higher msb, outside left branch
  | NearLeft  -- differs on the same msb, but outside current left branch
  | InLeft    -- within the left branch
  | InRight   -- within the right branch
  | NearRight -- differs on the same msb, but outside current right branch
  | FarRight  -- differs on a higher msb, outside right branch
  deriving (Eq,Ord,Show,Read)

significant :: Int -> Int -> Int -> Int -> Bool
significant a b c d = ab < cd && ab < xor ab cd where
  cd = xor c d
  ab = xor a b

classify :: Int -> Int -> Int -> Class
classify k x y
  | k < x = if significant x y k y then FarLeft else NearLeft
  | k > y = if significant x y x k then FarRight else NearRight
  | significant k y x y = InRight
  | otherwise = InLeft

main = print $ classify 1 2 4

outside :: Int -> Int -> Int -> Bool
outside k x y = k < x || k > y

insideR :: Int -> Int -> Int -> Bool
insideR k x y = significant k y x y

null :: IntMap a -> Bool
null Nil = True
null _   = False

empty :: IntMap a
empty = Nil

instance Traversable IntMap where
  traverse f m0 = go m0 where
    go (Bin x y l r) = Bin x y <$> go l <*> go r
    go (Tip x a) = Tip x <$> f a
    go Nil = pure Nil
  {-# INLINE traverse #-}

instance Foldable IntMap where
  foldMap f m0 = go m0 where
    go Nil = mempty
    go (Tip _ a) = f a
    go (Bin _ _ l r) = mappend (go l) (go r)
  {-# INLINE foldMap #-}

instance Functor IntMap where
  fmap f m0 = go m0 where
    go Nil = Nil
    go (Tip x a) = Tip x (f a)
    go (Bin x y l r) = Bin x y (go l) (go r)
  {-# INLINE fmap #-}

range :: IntMap a -> Maybe (Int,Int)
range Nil           = Nothing
range (Tip i a)     = Just (i,i)
range (Bin i j _ _) = Just (i,j)

lookup :: Int -> IntMap a -> Maybe a
lookup k m0 = go m0 where
  go (Tip i a)
    | k == i    = Just a
    | otherwise = Nothing
  go (Bin x y  l r)
    | outside k x y = Nothing
    | insideR r x y = go r
    | otherwise     = go l
  go Nil = Nothing
{-# INLINE lookup #-}

insert :: Int -> a -> IntMap a -> IntMap a
insert k a m0 = go m0 where
  go Nil = Tip k a
  go (Tip j b) = case compare k j of
    LT -> Bin k j (Tip k a) (Tip j b)
    EQ -> Tip k a
    GT -> Bin j k (Tip j b) (Tip k a)
  go n@(Bin x y l r)
    | k < x = if significant x y k y then Bin k y (Tip k a) n
                                     else Bin k y (go l) r
    | k > y = if significant x y x k then Bin x k n (Tip k a)
                                     else Bin x k l (go r)
    | significant k y x y = Bin x y l (go r)
    | otherwise           = Bin x y (go l) r

newx :: Int -> IntMap a -> IntMap a -> IntMap a
newx _ Nil r = r
newx y l@(Tip x _) r = Bin x y l r
newx y l@(Bin x _ _ _) r = Bin x y l r
{-# INLINE newx #-}

newy :: Int -> IntMap a -> IntMap a -> IntMap a
newy _ l Nil = l
newy x l r@(Tip y _)     = Bin x y l r
newy x l r@(Bin _ y _ _) = Bin x y l r
{-# INLINE newy #-}

delete :: Int -> IntMap a -> IntMap a
delete k m0 = go m0 where
  go n@(Bin x y l r)
    | outside k x y = n
    | insideR k x y = newy x l (go r)
    | otherwise     = newx y (go l) r
  go n@(Tip x a)
    | k == x    = Nil
    | otherwise = n
  go Nil = Nil
{-# INLINE delete #-}

at :: Functor f => Int -> (Maybe a -> f (Maybe a)) -> IntMap a -> f (IntMap a)
at k f m0 = go m0 where
  go Nil       = maybe Nil (Tip k) <$> f Nothing
  go n@(Tip x a) = case compare k x of
    LT -> maybe n (\b -> Bin k x (Tip k b) n) <$> f Nothing
    EQ -> maybe Nil (Tip k) <$> f (Just a)
    GT -> maybe n (\b -> Bin x k n (Tip k b)) <$> f Nothing
  go n@(Bin x y l r)
    | k < x = if significant x y k y then maybe n (\b -> Bin k y (Tip k b) n) <$> f Nothing
                                     else maybe n (\b -> Bin (min k x) y (insert k b l) r) <$> f Nothing
    | k > y = if significant x y x k then maybe n (\b -> Bin x k n (Tip k b)) <$> f Nothing
                                     else maybe n (\b -> Bin x (max k y) l (insert k b r)) <$> f Nothing
    | insideR k x y = newy x l <$> go r
    | otherwise     = (\l' -> newx y l' r) <$> go l
{-# INLINE at #-}

at :: Int -> Lens' (IntMap a) (Maybe a)

import Control.Applicative hiding (empty)
import Control.Lens hiding (at,outside)
import Data.Bits
import Data.Foldable
import Data.Traversable
import Data.Monoid
import Prelude hiding (lookup, null)

data IntMap a
  = Nil
  | Tip {-# UNPACK #-} !Int a
  | Bin {-# UNPACK #-} !Int {-# UNPACK #-} !Int !(IntMap a) !(IntMap a)
  deriving (Eq,Ord,Show,Read)

null :: IntMap a -> Bool
null Nil = True
null _   = False
{-# INLINE null #-}

empty :: IntMap a
empty = Nil
{-# INLINE empty #-}

range :: IntMap a -> Maybe (Int,Int)
range Nil           = Nothing
range (Tip i a)     = Just (i,i)
range (Bin i j _ _) = Just (i,j)
{-# INLINE range #-}

instance Traversable IntMap where
  traverse f m0 = go m0 where
    go (Bin x y l r) = Bin x y <$> go l <*> go r
    go (Tip x a) = Tip x <$> f a
    go Nil = pure Nil
  {-# INLINE traverse #-}

instance Foldable IntMap where
  foldMap f m0 = go m0 where
    go Nil = mempty
    go (Tip _ a) = f a
    go (Bin _ _ l r) = mappend (go l) (go r)
  {-# INLINE foldMap #-}

instance Functor IntMap where
  fmap f m0 = go m0 where
    go Nil = Nil
    go (Tip x a) = Tip x (f a)
    go (Bin x y l r) = Bin x y (go l) (go r)
  {-# INLINE fmap #-}

-- @significant a b c d@ implies that the position of the most significant difference between
-- @c@ and @d@ dominates the position of the difference between @a and b@.
significant :: Int -> Int -> Int -> Int -> Bool
significant a b c d = ab < cd && ab < xor ab cd where
  cd = xor c d
  ab = xor a b
{-# INLINE significant #-}

-- | for expository purposes only
data Class
  = FarLeft   -- differs on a higher msb, outside left branch
  | NearLeft  -- differs on the same msb, but outside current left branch
  | InLeft    -- within the left branch
  | InRight   -- within the right branch
  | NearRight -- differs on the same msb, but outside current right branch
  | FarRight  -- differs on a higher msb, outside right branch
  deriving (Eq,Ord,Show,Read)

-- | classify a key @k@ with regards to a binary tree split on the 2-fattest number within @(x..y]@
classify :: Int -> Int -> Int -> Class
classify k x y
  | k < x = if significant x y k y then FarLeft else NearLeft
  | k > y = if significant x y x k then FarRight else NearRight
  | significant k y x y = InRight
  | otherwise = InLeft
{-# INLINE classify #-}

outside :: Int -> Int -> Int -> Bool
outside k x y = k < x || k > y
{-# INLINE outside #-}

insideR :: Int -> Int -> Int -> Bool
insideR k x y = significant k y x y
{-# INLINE insideR #-}

lookup :: Int -> IntMap a -> Maybe a
lookup k m0 = go m0 where
  go (Tip i a)
    | k == i    = Just a
    | otherwise = Nothing
  go (Bin x y  l r)
    | outside k x y = Nothing -- short-circuit
    | insideR k x y = go r
    | otherwise     = go l
  go Nil = Nothing
{-# INLINE lookup #-}

insert :: Int -> a -> IntMap a -> IntMap a
insert k a m0 = go m0 where
  go Nil = Tip k a
  go (Tip j b) = case compare k j of
    LT -> Bin k j (Tip k a) (Tip j b)
    EQ -> Tip k a
    GT -> Bin j k (Tip j b) (Tip k a)
  go n@(Bin x y l r)
    | k < x = if significant x y k y then Bin k y (Tip k a) n
                                     else Bin k y (go l) r
    | k > y = if significant x y x k then Bin x k n (Tip k a)
                                     else Bin x k l (go r)
    | significant k y x y = Bin x y l (go r)
    | otherwise           = Bin x y (go l) r
{-# INLINE insert #-}

newx :: Int -> IntMap a -> IntMap a -> IntMap a
newx _ Nil r = r
newx y l@(Tip x _) r = Bin x y l r
newx y l@(Bin x _ _ _) r = Bin x y l r
{-# INLINE newx #-}

newy :: Int -> IntMap a -> IntMap a -> IntMap a
newy _ l Nil = l
newy x l r@(Tip y _)     = Bin x y l r
newy x l r@(Bin _ y _ _) = Bin x y l r
{-# INLINE newy #-}

delete :: Int -> IntMap a -> IntMap a
delete k m0 = go m0 where
  go n@(Bin x y l r)
    | outside k x y = n
    | insideR k x y = newy x l (go r)
    | otherwise     = newx y (go l) r
  go n@(Tip x a)
    | k == x    = Nil
    | otherwise = n
  go Nil = Nil
{-# INLINE delete #-}

at :: Functor f => Int -> (Maybe a -> f (Maybe a)) -> IntMap a -> f (IntMap a)
at k f m0 = go m0 where
  go Nil       = maybe Nil (Tip k) <$> f Nothing
  go n@(Tip x a) = case compare k x of
    LT -> maybe n (\b -> Bin k x (Tip k b) n) <$> f Nothing
    EQ -> maybe Nil (Tip k) <$> f (Just a)
    GT -> maybe n (\b -> Bin x k n (Tip k b)) <$> f Nothing
  go n@(Bin x y l r)
    | k > y = if significant x y x k then maybe n (\b -> Bin x k n (Tip k b)) <$> f Nothing               -- far right
                                     else maybe n (\b -> Bin x (max k y) l (insert k b r)) <$> f Nothing  -- near right
    | k < x = if significant x y k y then maybe n (\b -> Bin k y (Tip k b) n) <$> f Nothing               -- far left
                                     else maybe n (\b -> Bin (min k x) y (insert k b l) r) <$> f Nothing  -- near left
    | significant k y x y = newy x l <$> go r -- in right
    | otherwise           = (\l' -> newx y l' r) <$> go l -- in left
{-# INLINE at #-}

bin :: IntMap a -> IntMap a -> IntMap a
bin l Nil = l
bin Nil r = r
bin l@(Tip x _)     r@(Tip y _)     = Bin x y l r
bin l@(Tip x _)     r@(Bin _ y _ _) = Bin x y l r
bin l@(Bin x _ _ _) r@(Bin _ y _ _) = Bin x y l r
bin l@(Bin x _ _ _) r@(Tip y _)     = Bin x y l r
{-# INLINE bin #-}

-- show Run it!
main = print $ (empty & at 1 ?~ "hello" & at 2 ?~ "world") ^. at 2

import Data.Vector as Boxed
import Data.Vector.Generic as Generic
import Data.Vector.Unboxed as Unboxed
import Data.Vector.Primitive as Primitive
import Data.Vector.Storable as Storable

-- show These will also occur in code samples
import qualified Data.Vector.Generic.Mutable as GM
import qualified Data.Vector.Generic as G
import Data.Vector.Fusion.Stream as Stream

main = putStrLn "Those modules still exist!"

{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Monad
import Data.Monoid
import qualified Data.Vector.Generic.Mutable as GM
import qualified Data.Vector.Generic as G
import Data.Vector.Fusion.Stream as Stream
import Data.Data
import Prelude hiding ( length, null, replicate, reverse, map, read, take, drop, init, tail )
import Text.Read

data MVector :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> * where
  MV :: !(u s a) -> !(v s b) -> MVector u v s (a, b)

instance (GM.MVector u a, GM.MVector v b) => GM.MVector (MVector u v) (a, b) where
  basicLength (MV ks _) = GM.basicLength ks
  basicUnsafeSlice s e (MV ks vs) = MV (GM.basicUnsafeSlice s e ks) (GM.basicUnsafeSlice s e vs)
  basicOverlaps (MV ks vs) (MV ks' vs') = GM.basicOverlaps ks ks' || GM.basicOverlaps vs vs'
  basicUnsafeNew n = liftM2 MV (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)
  basicUnsafeReplicate n (k,v) = liftM2 MV (GM.basicUnsafeReplicate n k) (GM.basicUnsafeReplicate n v)
  basicUnsafeRead (MV ks vs) n = liftM2 (,) (GM.basicUnsafeRead ks n) (GM.basicUnsafeRead vs n)
  basicUnsafeWrite (MV ks vs) n (k,v) = GM.basicUnsafeWrite ks n k >> GM.basicUnsafeWrite vs n v
  basicClear (MV ks vs) = GM.basicClear ks >> GM.basicClear vs
  basicSet (MV ks vs) (k,v) = GM.basicSet ks k >> GM.basicSet vs v
  basicUnsafeCopy (MV ks vs) (MV ks' vs') = GM.basicUnsafeCopy ks ks' >> GM.basicUnsafeCopy vs vs'
  basicUnsafeMove (MV ks vs) (MV ks' vs') = GM.basicUnsafeMove ks ks' >> GM.basicUnsafeMove vs vs'
  basicUnsafeGrow (MV ks vs) n = liftM2 MV (GM.basicUnsafeGrow ks n) (GM.basicUnsafeGrow vs n)

main = putStrLn "It typechecks, so it must be correct."

{-# START_FILE Hybrid.hs #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hybrid where

import Control.Monad
import Data.Monoid
import qualified Data.Vector.Generic.Mutable as GM
import qualified Data.Vector.Generic as G
import Data.Vector.Fusion.Stream as Stream
import Data.Data
import Prelude hiding ( length, null, replicate, reverse, map, read, take, drop, init, tail )
import Text.Read

data MVector :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> * where
  MV :: !(u s a) -> !(v s b) -> MVector u v s (a, b)

instance (GM.MVector u a, GM.MVector v b) => GM.MVector (MVector u v) (a, b) where
  basicLength (MV ks _) = GM.basicLength ks
  basicUnsafeSlice s e (MV ks vs) = MV (GM.basicUnsafeSlice s e ks) (GM.basicUnsafeSlice s e vs)
  basicOverlaps (MV ks vs) (MV ks' vs') = GM.basicOverlaps ks ks' || GM.basicOverlaps vs vs'
  basicUnsafeNew n = liftM2 MV (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)
  basicUnsafeReplicate n (k,v) = liftM2 MV (GM.basicUnsafeReplicate n k) (GM.basicUnsafeReplicate n v)
  basicUnsafeRead (MV ks vs) n = liftM2 (,) (GM.basicUnsafeRead ks n) (GM.basicUnsafeRead vs n)
  basicUnsafeWrite (MV ks vs) n (k,v) = do
    GM.basicUnsafeWrite ks n k
    GM.basicUnsafeWrite vs n v
  basicClear (MV ks vs) = do
    GM.basicClear ks
    GM.basicClear vs
  basicSet (MV ks vs) (k,v) = do
    GM.basicSet ks k
    GM.basicSet vs v
  basicUnsafeCopy (MV ks vs) (MV ks' vs') = do
    GM.basicUnsafeCopy ks ks'
    GM.basicUnsafeCopy vs vs'
  basicUnsafeMove (MV ks vs) (MV ks' vs') = do
    GM.basicUnsafeMove ks ks'
    GM.basicUnsafeMove vs vs'
  basicUnsafeGrow (MV ks vs) n = liftM2 MV (GM.basicUnsafeGrow ks n) (GM.basicUnsafeGrow vs n)

  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeMove #-}
  {-# INLINE basicUnsafeGrow #-}

data Vector :: (* -> *) -> (* -> *) -> * -> * where
  V :: !(u a) -> !(v b) -> Vector u v (a, b)

type instance G.Mutable (Vector u v) = MVector (G.Mutable u) (G.Mutable v)

instance (G.Vector u a, G.Vector v b) => G.Vector (Vector u v) (a, b) where
  basicUnsafeFreeze (MV ks vs) = liftM2 V (G.basicUnsafeFreeze ks) (G.basicUnsafeFreeze vs)
  basicUnsafeThaw (V ks vs) = liftM2 MV (G.basicUnsafeThaw ks) (G.basicUnsafeThaw vs)
  basicLength (V ks _) = G.basicLength ks
  basicUnsafeSlice i j (V ks vs) = V (G.basicUnsafeSlice i j ks) (G.basicUnsafeSlice i j vs)
  basicUnsafeIndexM (V ks vs) n = liftM2 (,) (G.basicUnsafeIndexM ks n) (G.basicUnsafeIndexM vs n)
  basicUnsafeCopy (MV ks vs) (V ks' vs') = do
    G.basicUnsafeCopy ks ks'
    G.basicUnsafeCopy vs vs'
  elemseq (V ks vs) (k,v) b = G.elemseq ks k (G.elemseq vs v b)

  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE elemseq #-}

instance (G.Vector u a, G.Vector v b, c ~ (a, b)) => Monoid (Vector u v c) where
  mappend = (G.++)
  {-# INLINE mappend #-}
  mempty = G.empty
  {-# INLINE mempty #-}
  mconcat = G.concat
  {-# INLINE mconcat #-}

instance (G.Vector u a, G.Vector v b, Show a, Show b, c ~ (a, b)) => Show (Vector u v c) where
  showsPrec = G.showsPrec

instance (G.Vector u a, G.Vector v b, Read a, Read b, c ~ (a, b)) => Read (Vector u v c) where
  readPrec = G.readPrec
  readListPrec = readListPrecDefault

instance (G.Vector u a, G.Vector v b, Eq a, Eq b, c ~ (a, b)) => Eq (Vector u v c) where
  xs == ys = Stream.eq (G.stream xs) (G.stream ys)
  xs /= ys = not (Stream.eq (G.stream xs) (G.stream ys))
  {-# INLINE (==) #-}
  {-# INLINE (/=) #-}

instance (G.Vector u a, G.Vector v b, Ord a, Ord b, c ~ (a, b)) => Ord (Vector u v c) where
  compare xs ys = Stream.cmp (G.stream xs) (G.stream ys)
  {-# INLINE compare #-}

{-# START_FILE Main.hs #-}

module Main where
import Hybrid
import Data.Vector.Unboxed as Unboxed
import Data.Vector
import Data.Vector as Boxed
import Data.Vector.Generic as Generic
import Data.Vector.Unboxed as Unboxed
import Data.Vector.Primitive as Primitive
import Data.Vector.Storable as Storable
import qualified Data.Vector.Generic.Mutable as GM
import qualified Data.Vector.Generic as G
import Data.Vector.Fusion.Stream as Stream

type V = Hybrid.Vector Unboxed.Vector Boxed.Vector (Int,Integer)
main = do
  print (G.fromList [(1,2),(3,4)] :: V)
  print $ G.slice 2 3 (G.fromList (Prelude.zip [1..10] [11..20]) :: V)

instance (G.Vector u a, G.Vector v b) => Monoid (Vector u v (a,b))

instance (G.Vector u a, G.Vector v b, c ~ (a, b)) => Monoid (Vector u v c) where
  mappend = (G.++)
  mempty = G.empty
  mconcat = G.concat

instance (G.Vector u a, G.Vector v b, Show a, Show b, c ~ (a, b)) => Show (Vector u v c) where
  showsPrec = G.showsPrec

instance (G.Vector u a, G.Vector v b, Read a, Read b, c ~ (a, b)) => Read (Vector u v c) where
  readPrec = G.readPrec
  readListPrec = readListPrecDefault

instance (G.Vector u a, G.Vector v b, Eq a, Eq b, c ~ (a, b)) => Eq (Vector u v c) where
  xs == ys = Stream.eq (G.stream xs) (G.stream ys)
  xs /= ys = not (Stream.eq (G.stream xs) (G.stream ys))

instance (G.Vector u a, G.Vector v b, Ord a, Ord b, c ~ (a, b)) => Ord (Vector u v c) where
  compare xs ys = Stream.cmp (G.stream xs) (G.stream ys)

mergeStreamsWith
  :: (Monad m, Ord i)
  => (a -> a -> Maybe a)
  -> Stream m (i, a)
  -> Stream m (i, a)
  -> Stream m (i, a)

data Stream m a = forall s . Stream (s -> m (Step s a)) s Size

mergeStreamsWith f (Stream stepa sa0 na) (Stream stepb sb0 nb)
  = Stream step (MergeStart sa0 sb0) (toMax na + toMax nb)

data Step s a = Yield a s | Skip s | Done

data MergeState sa sb i a
  = MergeL sa sb i a
  | MergeR sa sb i a
  | MergeLeftEnded sb
  | MergeRightEnded sa
  | MergeStart sa sb

  step (MergeStart sa sb) = do
    r <- stepa sa
    return $ case r of
      Yield (i, a) sa' -> Skip (MergeL sa' sb i a)
      Skip sa'         -> Skip (MergeStart sa' sb)
      Done             -> Skip (MergeLeftEnded sb)

  step (MergeL sa sb i a) = do
    r <- stepb sb
    return $ case r of
      Yield (j, b) sb' -> case compare i j of
        LT -> Yield (i, a)     (MergeR sa sb' j b)
        EQ -> case f a b of
           Just c  -> Yield (i, c) (MergeStart sa sb')
           Nothing -> Skip (MergeStart sa sb')
        GT -> Yield (j, b)     (MergeL sa sb' i a)
      Skip sb' -> Skip (MergeL sa sb' i a)
      Done     -> Yield (i, a) (MergeRightEnded sa)

  step (MergeR sa sb j b) = do
    r <- stepa sa
    return $ case r of
      Yield (i, a) sa' -> case compare i j of
        LT -> Yield (i, a)     (MergeR sa' sb j b)
        EQ -> case f a b of
          Just c  -> Yield (i, c) (MergeStart sa' sb)
          Nothing -> Skip (MergeStart sa' sb)
        GT -> Yield (j, b)     (MergeL sa' sb i a)
      Skip sa' -> Skip (MergeR sa' sb j b)
      Done     -> Yield (j, b) (MergeLeftEnded sb)

  step (MergeLeftEnded sb) = do
    r <- stepb sb
    return $ case r of
      Yield (j, b) sb' -> Yield (j, b) (MergeLeftEnded sb')
      Skip sb'         -> Skip (MergeLeftEnded sb')
      Done             -> Done
  step (MergeRightEnded sa) = do
    r <- stepa sa
    return $ case r of
      Yield (i, a) sa' -> Yield (i, a) (MergeRightEnded sa')
      Skip sa'         -> Skip (MergeRightEnded sa')
      Done             -> Done

import Data.Vector.Fusion.Stream.Monadic (Step(..), Stream(..))
import Data.Vector.Fusion.Stream.Size

data MergeState sa sb i a
  = MergeL sa sb i a
  | MergeR sa sb i a
  | MergeLeftEnded sb
  | MergeRightEnded sa
  | MergeStart sa sb

mergeStreamsWith
  :: (Monad m, Ord i)
  => (a -> a -> Maybe a)
  -> Stream m (i, a)
  -> Stream m (i, a)
  -> Stream m (i, a)
mergeStreamsWith f (Stream stepa sa0 na) (Stream stepb sb0 nb)
  = Stream step (MergeStart sa0 sb0) (toMax na + toMax nb) where
  step (MergeStart sa sb) = do
    r <- stepa sa
    return $ case r of
      Yield (i, a) sa' -> Skip (MergeL sa' sb i a)
      Skip sa'         -> Skip (MergeStart sa' sb)
      Done             -> Skip (MergeLeftEnded sb)
  step (MergeL sa sb i a) = do
    r <- stepb sb
    return $ case r of
      Yield (j, b) sb' -> case compare i j of
        LT -> Yield (i, a)     (MergeR sa sb' j b)
        EQ -> case f a b of
           Just c  -> Yield (i, c) (MergeStart sa sb')
           Nothing -> Skip (MergeStart sa sb')
        GT -> Yield (j, b)     (MergeL sa sb' i a)
      Skip sb' -> Skip (MergeL sa sb' i a)
      Done     -> Yield (i, a) (MergeRightEnded sa)
  step (MergeR sa sb j b) = do
    r <- stepa sa
    return $ case r of
      Yield (i, a) sa' -> case compare i j of
        LT -> Yield (i, a)     (MergeR sa' sb j b)
        EQ -> case f a b of
          Just c  -> Yield (i, c) (MergeStart sa' sb)
          Nothing -> Skip (MergeStart sa' sb)
        GT -> Yield (j, b)     (MergeL sa' sb i a)
      Skip sa' -> Skip (MergeR sa' sb j b)
      Done     -> Yield (j, b) (MergeLeftEnded sb)
  step (MergeLeftEnded sb) = do
    r <- stepb sb
    return $ case r of
      Yield (j, b) sb' -> Yield (j, b) (MergeLeftEnded sb')
      Skip sb'         -> Skip (MergeLeftEnded sb')
      Done             -> Done
  step (MergeRightEnded sa) = do
    r <- stepa sa
    return $ case r of
      Yield (i, a) sa' -> Yield (i, a) (MergeRightEnded sa')
      Skip sa'         -> Skip (MergeRightEnded sa')
      Done             -> Done
  {-# INLINE [0] step #-}
{-# INLINE [1] mergeStreamsWith #-}

main = putStrLn "That compiles, too."

newtype Mat v a = Mat { runMat :: Hybrid.Vector Unboxed.Vector v (Key, a) }

fromList :: Generic.Vector v a => [(Key, a)] -> Mat v a
fromList xs
  = Mat
  $ Generic.modify (Intro.sortBy (compare `on` fst))
  $ Generic.fromList xs

import Data.Bits
import Data.Word
import Control.Lens
import Numeric.Lens

-- | @smear x@ returns the smallest @2^n-1 >= x@
smear :: Word64 -> Word64
smear k0 = k6 where
  k1 = k0 .|. unsafeShiftR k0 1
  k2 = k1 .|. unsafeShiftR k1 2
  k3 = k2 .|. unsafeShiftR k2 4
  k4 = k3 .|. unsafeShiftR k3 8
  k5 = k4 .|. unsafeShiftR k4 16
  k6 = k5 .|. unsafeShiftR k5 32

-- | @msb x@ returns the largest @2^n <= x@
msb :: Word64 -> Word64
msb x = y `xor` unsafeShiftR y 1
  where y = smear x

-- | @fat x y@ for @x < y@ returns the unique selection of @z = i*2^n@
-- in @x < z <= y@ that maximizes n.
fat :: Word64 -> Word64 -> Word64
fat x y = complement (unsafeShiftR (smear (xor x y)) 1) .&. y

main = print $ base 16 # smear 0xf001030900

import Data.Bits
import Data.Word
import Control.Lens
import Numeric.Lens
-- | @smear x@ returns the smallest @2^n-1 >= x@
smear :: Word64 -> Word64
smear k0 = k6 where
  k1 = k0 .|. unsafeShiftR k0 1
  k2 = k1 .|. unsafeShiftR k1 2
  k3 = k2 .|. unsafeShiftR k2 4
  k4 = k3 .|. unsafeShiftR k3 8
  k5 = k4 .|. unsafeShiftR k4 16
  k6 = k5 .|. unsafeShiftR k5 32
-- | @msb x@ returns the largest @2^n <= x@

msb :: Word64 -> Word64
msb x = y `xor` unsafeShiftR y 1
  where y = smear x

-- | @fat x y@ for @x < y@ returns the unique selection of @z = i*2^n@
-- in @x < z <= y@ that maximizes n.
fat :: Word64 -> Word64 -> Word64
fat x y = complement (unsafeShiftR (smear (xor x y)) 1) .&. y

main = do
  print $ base 16 # msb 0xf001030900
  print $ base 16 # msb (xor 0xff0 0xc00)

import Data.Bits
import Data.Word
import Control.Lens
import Numeric.Lens
-- | @smear x@ returns the smallest @2^n-1 >= x@
smear :: Word64 -> Word64
smear k0 = k6 where
  k1 = k0 .|. unsafeShiftR k0 1
  k2 = k1 .|. unsafeShiftR k1 2
  k3 = k2 .|. unsafeShiftR k2 4
  k4 = k3 .|. unsafeShiftR k3 8
  k5 = k4 .|. unsafeShiftR k4 16
  k6 = k5 .|. unsafeShiftR k5 32

-- | @msb x@ returns the largest @2^n <= x@
msb :: Word64 -> Word64
msb x = y `xor` unsafeShiftR y 1
  where y = smear x

-- | @fat x y@ for @x < y@ returns the unique selection of @z = b*2^i@
-- in @x < z <= y@ that maximizes @i@.
fat :: Word64 -> Word64 -> Word64
fat x y = complement (unsafeShiftR (smear (xor x y)) 1) .&. y

main = print $ base 16 # fat 0x1 0xf

data Key = Key {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 deriving (Eq,Show,Read)

instance (a ~ Word32, b ~ Word32) => Field2 Key Key a b where
  _2 f (Key i j) = Key i <$> indexed f (1 :: Int) j

instance Ord Key where
  compare (Key a b) (Key c d)
    | ac < bd && ac < xor ac bd = compare b d
    | otherwise                 = compare a c
    where
      ac = xor a c
      bd = xor b d

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Control.Applicative
import Control.Lens
import Data.Bits
import Data.Word

data Key = Key {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 deriving (Eq,Show,Read)

instance Ord Key where
  compare (Key a b) (Key c d)
    | ac < bd && ac < xor ac bd = compare b d
    | otherwise                 = compare a c
    where
      ac = xor a c
      bd = xor b d

instance (a ~ Word32, b ~ Word32) => Field1 Key Key a b where
  _1 f (Key a b) = (`Key` b) <$> indexed f (0 :: Int) a

instance (a ~ Word32, b ~ Word32) => Field2 Key Key a b where
  _2 f (Key a b) = Key a <$> indexed f (1 :: Int) b

main = putStrLn "it compiles!"

newtype DilatedEven = DilatedEven Word64
newtype DilatedOdd  = DilatedOdd Word64

unsigned shuffle1(unsigned x) {
// ------------------------------ cut ----------------------------------
   x = (x & 0x0000FF00) << 8 | (x >> 8) & 0x0000FF00 | x & 0xFF0000FF;
   x = (x & 0x00F000F0) << 4 | (x >> 4) & 0x00F000F0 | x & 0xF00FF00F;
   x = (x & 0x0C0C0C0C) << 2 | (x >> 2) & 0x0C0C0C0C | x & 0xC3C3C3C3;
   x = (x & 0x22222222) << 1 | (x >> 1) & 0x22222222 | x & 0x99999999;
// ---------------------------- end cut --------------------------------
   return x;
}

abcd efgh ijkl mnop ABCD EFGH IJKL MNOP

abcd efgh ABCD EFGH ijkl mnop IJKL MNOP
abcd ABCD efgh EFGH ijkl IJKL mnop MNOP
abAB cdCD efEF ghGH ijIJ klKL mnMN opOP
aAbB cCdD eEfF gGhH iIjJ kKlL mMnN oOpP

import Data.Bits
import Data.Word
import Control.Lens
import Numeric.Lens

shuffle :: Word64 -> Word64
shuffle k0 = k5 where
  k1 = unsafeShiftL (k0 .&. 0x00000000FFFF0000) 16 .|. unsafeShiftR k0 16 .&. 0x00000000FFFF0000 .|. k0 .&. 0xFFFF00000000FFFF
  k2 = unsafeShiftL (k1 .&. 0x0000FF000000FF00) 8  .|. unsafeShiftR k1 8  .&. 0x0000FF000000FF00 .|. k1 .&. 0xFF0000FFFF0000FF
  k3 = unsafeShiftL (k2 .&. 0x00F000F000F000F0) 4  .|. unsafeShiftR k2 4  .&. 0x00F000F000F000F0 .|. k2 .&. 0xF00FF00FF00FF00F
  k4 = unsafeShiftL (k3 .&. 0x0C0C0C0C0C0C0C0C) 2  .|. unsafeShiftR k3 2  .&. 0x0C0C0C0C0C0C0C0C .|. k3 .&. 0xC3C3C3C3C3C3C3C3
  k5 = unsafeShiftL (k4 .&. 0x2222222222222222) 1  .|. unsafeShiftR k4 1  .&. 0x2222222222222222 .|. k4 .&. 0x9999999999999999

-- show main
main = print $ base 2 # shuffle 0x00000000FFFFFFFF

newtype Key = Key Word64

key :: Word32 -> Word32 -> Key
key i j = Key $ shuffle $ unsafeShiftL (fromIntegral i) 32 .|. fromIntegral j

import Data.Bits
import Data.Word
import Control.Lens
import Numeric.Lens

unshuffle :: Word64 -> Word64
unshuffle k0 = k5 where
  t0 = xor k0 (unsafeShiftR k0 1 ) .&. 0x2222222222222222
  k1 = k0 `xor` t0 `xor` unsafeShiftL t0 1
  t1 = xor k1 (unsafeShiftR k1 2 ) .&. 0x0C0C0C0C0C0C0C0C
  k2 = k1 `xor` t1 `xor` unsafeShiftL t1 2
  t2 = xor k2 (unsafeShiftR k2 4 ) .&. 0x00F000F000F000F0
  k3 = k2 `xor` t2 `xor` unsafeShiftL t2 4
  t3 = xor k3 (unsafeShiftR k3 8 ) .&. 0x0000FF000000FF00
  k4 = k3 `xor` t3 `xor` unsafeShiftL t3 8
  t4 = xor k4 (unsafeShiftR k4 16) .&. 0x00000000FFFF0000
  k5 = k4 `xor` t4 `xor` unsafeShiftL t4 16

{-# INLINE unshuffle #-}

-- show main
main = print $ base 2 # unshuffle 0xAAAAAAAAAAAAAAAA

unshuffle k0 = k5 where
  k5 = unsafeShiftL (k4 .&. 0x00000000FFFF0000) 16 .|. unsafeShiftR k4 16 .&. 0x00000000FFFF0000 .|. k4 .&. 0xFFFF00000000FFFF
  k4 = unsafeShiftL (k3 .&. 0x0000FF000000FF00) 8  .|. unsafeShiftR k3 8  .&. 0x0000FF000000FF00 .|. k3 .&. 0xFF0000FFFF0000FF
  k3 = unsafeShiftL (k2 .&. 0x00F000F000F000F0) 4  .|. unsafeShiftR k2 4  .&. 0x00F000F000F000F0 .|. k2 .&. 0xF00FF00FF00FF00F
  k2 = unsafeShiftL (k1 .&. 0x0C0C0C0C0C0C0C0C) 2  .|. unsafeShiftR k1 2  .&. 0x0C0C0C0C0C0C0C0C .|. k1 .&. 0xC3C3C3C3C3C3C3C3
  k1 = unsafeShiftL (k0 .&. 0x2222222222222222) 1  .|. unsafeShiftR k0 1  .&. 0x2222222222222222 .|. k0 .&. 0x9999999999999999

unkey :: Key -> (Word32, Word32)

keyed :: Iso' (Word32,Word32) Key
keyed = iso (uncurry key) unkey

instance Field1 Key Key Word32 Word32 where
  _1 = from keyed._1

instance Field2 Key Key Word32 Word32 where
  _2 = from keyed._2

key 100 200 ^. _2 = 200
key 100 200 & _2 .~ 300 = key 100 300

instance Show Key where
  showsPrec d w = case unkey w of
    (i,j) -> showParen (d > 10) $
      showString "key " . Prelude.showsPrec 11 i .
           showChar ' ' . Prelude.showsPrec 11 j

instance Read Key where
  readsPrec d = readParen (d > 10) $ \r ->
    [ (key i j, u)
    | ("key",s) <- lex r
    , (i,t) <- readsPrec 11 s
    , (j,u) <- readsPrec 11 t
    ]

-- | Masks for the interleaved components of a key
m1, m2 :: Word64
m1 = 0xAAAAAAAAAAAAAAAA -- the mask for the first component of our key.
m2 = 0x5555555555555555 -- the mask for the second component of our key.
{-# INLINE m1 #-}
{-# INLINE m2 #-}

instance (a ~ Word32, b ~ Word32) => Field2 Key Key a b where
  _2 f (Key ij) = indexed f (1 :: Int) (fromIntegral k5) <&> \j -> let
         j0 = fromIntegral j
         j1 = unsafeShiftL (j0 .&. 0x00000000FFFF0000) 16 .|. j0 .&. 0xFFFF00000000FFFF
         j2 = unsafeShiftL (j1 .&. 0x0000FF000000FF00) 8  .|. j1 .&. 0xFF0000FFFF0000FF
         j3 = unsafeShiftL (j2 .&. 0x00F000F000F000F0) 4  .|. j2 .&. 0xF00FF00FF00FF00F
         j4 = unsafeShiftL (j3 .&. 0x0C0C0C0C0C0C0C0C) 2  .|. j3 .&. 0xC3C3C3C3C3C3C3C3
         j5 = unsafeShiftL (j4 .&. 0x2222222222222222) 1  .|. j4 .&. 0x9999999999999999
      in Key (ij .&. m1 .|. j5)
    where
      k0 = ij .&. m2
      k1 = (unsafeShiftR k0 1  .|. k0) .&. 0x3333333333333333
      k2 = (unsafeShiftR k1 2  .|. k1) .&. 0x0F0F0F0F0F0F0F0F
      k3 = (unsafeShiftR k2 4  .|. k2) .&. 0x00FF00FF00FF00FF
      k4 = (unsafeShiftR k3 8  .|. k3) .&. 0x0000FFFF0000FFFF
      k5 = (unsafeShiftR k4 16 .|. k4) .&. 0x00000000FFFFFFFF

instance (a ~ Word32, b ~ Word32) => Field2 Key Key a b where
  _1 f (Key ij) = indexed f (0 :: Int) (fromIntegral k5) <&> \i -> let
         i0 = fromIntegral i
         i1 = unsafeShiftL (i0 .&. 0x00000000FFFF0000) 16 .|. i0 .&. 0xFFFF00000000FFFF
         i2 = unsafeShiftL (i1 .&. 0x0000FF000000FF00) 8  .|. i1 .&. 0xFF0000FFFF0000FF
         i3 = unsafeShiftL (i2 .&. 0x00F000F000F000F0) 4  .|. i2 .&. 0xF00FF00FF00FF00F
         i4 = unsafeShiftL (i3 .&. 0x0C0C0C0C0C0C0C0C) 2  .|. i3 .&. 0xC3C3C3C3C3C3C3C3
         i5 = unsafeShiftL (i4 .&. 0x2222222222222222) 1  .|. i4 .&. 0x9999999999999999
      in Key (unsafeShiftL i5 1 .|. ij .&. m2)
    where
      k0 = unsafeShiftR (ij .&. m1) 1
      k1 = (unsafeShiftR k0 1  .|. k0) .&. 0x3333333333333333
      k2 = (unsafeShiftR k1 2  .|. k1) .&. 0x0F0F0F0F0F0F0F0F
      k3 = (unsafeShiftR k2 4  .|. k2) .&. 0x00FF00FF00FF00FF
      k4 = (unsafeShiftR k3 8  .|. k3) .&. 0x0000FFFF0000FFFF
      k5 = (unsafeShiftR k4 16 .|. k4) .&. 0x00000000FFFFFFFF

instance (a ~ Word32, b ~ Word32) => Field2 Key Key a b where
  _1 f (Key ij) = indexed f (0 :: Int) (fromIntegral k5) <&> \i -> let
         i0 = fromIntegral i
         i1 = unsafeShiftL (i0 .&. 0x00000000FFFF0000) 17 .|. i0 .&. 0xFFFE00000001FFFE
         i2 = unsafeShiftL (i1 .&. 0x0000FF000000FF00) 9  .|. i1 .&. 0xFE0001FFFE0001FE
         i3 = unsafeShiftL (i2 .&. 0x00F000F000F000F0) 5  .|. i2 .&. 0xE01FE01FE01FE01E
         i4 = unsafeShiftL (i3 .&. 0x0C0C0C0C0C0C0C0C) 3  .|. i3 .&. 0x0F0F0F0F0F0F0F0E
         i5 = unsafeShiftL (i4 .&. 0x2222222222222222) 2  .|. i4 .&. 0x3333333333333332
      in Key (unsafeShiftL 1 i5 .|. ij .&. m2)
    where
      k0 = ij .&. m1
      k1 = (unsafeShiftR k0 2  .|. k0) .&. 0x6666666666666666
      k2 = (unsafeShiftR k1 3  .|. k1) .&. 0x1E1E1E1E1E1E1E1E
      k3 = (unsafeShiftR k2 5  .|. k2) .&. 0x01FE01FE01FE01FE
      k4 = (unsafeShiftR k3 9  .|. k3) .&. 0x0001FFFE0001FFFE
      k5 = (unsafeShiftR k4 15 .|. k4) .&. 0x00000001FFFFFFFE

-- show Sparse/Matrix/Key.hs
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Keys in Morton order
--
-- This module provides combinators for shuffling together the bits of two
-- key components to get a key that is based on their interleaved bits.
--
-- See <http://en.wikipedia.org/wiki/Z-order_curve> for more information
-- about Morton order.
--
----------------------------------------------------------------------------

import Control.Lens
import Data.Bits
import Data.Word

-- * Morton Order

-- | @key i j@ interleaves the bits of the keys @i@ and @j@.
--
-- Keys are then just values sorted in \"Morton Order\".
newtype Key = Key { runKey :: Word64 }
  deriving (Eq, Ord)

-- | Construct a key from a pair of indices.
--
-- @
-- key i j ^. _1 = i
-- key i j ^. _2 = j
-- @
key :: Word32 -> Word32 -> Key
key i j = Key k5 where
  k0 = unsafeShiftL (fromIntegral i) 32 .|. fromIntegral j
  k1 = unsafeShiftL (k0 .&. 0x00000000FFFF0000) 16 .|. unsafeShiftR k0 16 .&. 0x00000000FFFF0000 .|. k0 .&. 0xFFFF00000000FFFF
  k2 = unsafeShiftL (k1 .&. 0x0000FF000000FF00) 8  .|. unsafeShiftR k1 8  .&. 0x0000FF000000FF00 .|. k1 .&. 0xFF0000FFFF0000FF
  k3 = unsafeShiftL (k2 .&. 0x00F000F000F000F0) 4  .|. unsafeShiftR k2 4  .&. 0x00F000F000F000F0 .|. k2 .&. 0xF00FF00FF00FF00F
  k4 = unsafeShiftL (k3 .&. 0x0C0C0C0C0C0C0C0C) 2  .|. unsafeShiftR k3 2  .&. 0x0C0C0C0C0C0C0C0C .|. k3 .&. 0xC3C3C3C3C3C3C3C3
  k5 = unsafeShiftL (k4 .&. 0x2222222222222222) 1  .|. unsafeShiftR k4 1  .&. 0x2222222222222222 .|. k4 .&. 0x9999999999999999
{-# INLINE key #-}

-- | This isomorphism lets you build a key from a pair of indices.
--
-- @
-- key i j ≡ (i,j)^.shuffled
-- @
--
-- @
-- 'shuffled' . 'unshuffled' = 'id'
-- 'unshuffled' . 'shuffled' = 'id'
-- @
shuffled :: Iso' (Word32, Word32) Key
shuffled = iso (uncurry key) unshuffle
{-# INLINE shuffled #-}

-- | This isomorphism lets you build a pair of indices from a key.
unshuffled :: Iso' Key (Word32, Word32)
unshuffled = iso unshuffle (uncurry key)
{-# INLINE unshuffled #-}

unshuffle :: Key -> (Word32, Word32)
unshuffle (Key k0) = (fromIntegral (unsafeShiftR k5 32), fromIntegral k5) where
  t0 = xor k0 (unsafeShiftR k0 1 ) .&. 0x2222222222222222
  k1 = k0 `xor` t0 `xor` unsafeShiftL t0 1
  t1 = xor k1 (unsafeShiftR k1 2 ) .&. 0x0C0C0C0C0C0C0C0C
  k2 = k1 `xor` t1 `xor` unsafeShiftL t1 2
  t2 = xor k2 (unsafeShiftR k2 4 ) .&. 0x00F000F000F000F0
  k3 = k2 `xor` t2 `xor` unsafeShiftL t2 4
  t3 = xor k3 (unsafeShiftR k3 8 ) .&. 0x0000FF000000FF00
  k4 = k3 `xor` t3 `xor` unsafeShiftL t3 8
  t4 = xor k4 (unsafeShiftR k4 16) .&. 0x00000000FFFF0000
  k5 = k4 `xor` t4 `xor` unsafeShiftL t4 16
{-# INLINE unshuffle #-}

instance (a ~ Word32, b ~ Word32) => Field1 Key Key a b where
  _1 f (Key ij) = indexed f (0 :: Int) (fromIntegral k5) <&> \i -> let
         i0 = fromIntegral i
         i1 = unsafeShiftL (i0 .&. 0x00000000FFFF0000) 16 .|. i0 .&. 0xFFFF00000000FFFF
         i2 = unsafeShiftL (i1 .&. 0x0000FF000000FF00) 8  .|. i1 .&. 0xFF0000FFFF0000FF
         i3 = unsafeShiftL (i2 .&. 0x00F000F000F000F0) 4  .|. i2 .&. 0xF00FF00FF00FF00F
         i4 = unsafeShiftL (i3 .&. 0x0C0C0C0C0C0C0C0C) 2  .|. i3 .&. 0xC3C3C3C3C3C3C3C3
         i5 = unsafeShiftL (i4 .&. 0x2222222222222222) 1  .|. i4 .&. 0x9999999999999999
      in Key (unsafeShiftL i5 1 .|. ij .&. m2)
    where
      k0 = unsafeShiftR (ij .&. m1) 1
      k1 = (unsafeShiftR k0 1  .|. k0) .&. 0x3333333333333333
      k2 = (unsafeShiftR k1 2  .|. k1) .&. 0x0F0F0F0F0F0F0F0F
      k3 = (unsafeShiftR k2 4  .|. k2) .&. 0x00FF00FF00FF00FF
      k4 = (unsafeShiftR k3 8  .|. k3) .&. 0x0000FFFF0000FFFF
      k5 = (unsafeShiftR k4 16 .|. k4) .&. 0x00000000FFFFFFFF
  -- _1 = unshuffled._1 -- reference implementation
  {-# INLINE _1 #-}

instance (a ~ Word32, b ~ Word32) => Field2 Key Key a b where
  _2 f (Key ij) = indexed f (1 :: Int) (fromIntegral k5) <&> \j -> let
         j0 = fromIntegral j
         j1 = unsafeShiftL (j0 .&. 0x00000000FFFF0000) 16 .|. j0 .&. 0xFFFF00000000FFFF
         j2 = unsafeShiftL (j1 .&. 0x0000FF000000FF00) 8  .|. j1 .&. 0xFF0000FFFF0000FF
         j3 = unsafeShiftL (j2 .&. 0x00F000F000F000F0) 4  .|. j2 .&. 0xF00FF00FF00FF00F
         j4 = unsafeShiftL (j3 .&. 0x0C0C0C0C0C0C0C0C) 2  .|. j3 .&. 0xC3C3C3C3C3C3C3C3
         j5 = unsafeShiftL (j4 .&. 0x2222222222222222) 1  .|. j4 .&. 0x9999999999999999
      in Key (ij .&. m1 .|. j5)
    where
      k0 = ij .&. m2
      k1 = (unsafeShiftR k0 1  .|. k0) .&. 0x3333333333333333
      k2 = (unsafeShiftR k1 2  .|. k1) .&. 0x0F0F0F0F0F0F0F0F
      k3 = (unsafeShiftR k2 4  .|. k2) .&. 0x00FF00FF00FF00FF
      k4 = (unsafeShiftR k3 8  .|. k3) .&. 0x0000FFFF0000FFFF
      k5 = (unsafeShiftR k4 16 .|. k4) .&. 0x00000000FFFFFFFF
  -- _2 = unshuffled._2 -- reference implementation
  {-# INLINE _2 #-}

instance Show Key where
  showsPrec d w = case unshuffle w of
    (i,j) -> showParen (d > 10) $
      showString "key " . Prelude.showsPrec 11 i .
           showChar ' ' . Prelude.showsPrec 11 j

instance Read Key where
  readsPrec d = readParen (d > 10) $ \r ->
    [ (key i j, u)
    | ("key",s) <- lex r
    , (i,t) <- readsPrec 11 s
    , (j,u) <- readsPrec 11 t
    ]

-- * Utilities

-- | Masks for the interleaved components of a key
m1, m2 :: Word64
m1 = 0xAAAAAAAAAAAAAAAA
m2 = 0x5555555555555555
{-# INLINE m1 #-}
{-# INLINE m2 #-}

-- show playground
main :: IO ()
main = do
 print $ key 100 200 ^. _2
 print $ key 100 200 & _1 .~ 300

{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad

data Store s a = Store (s -> a) s deriving Functor

instance Comonad (Store s) where
  extract (Store f s) = f s
  duplicate (Store f s) = Store (Store f) s

experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s

main = putStrLn "It typechecks, so it must be correct!"

experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
import Control.Comonad

newtype Pretext s a = Pretext {
    runPretext :: forall f. Functor f => (s -> f s) -> f a
  } deriving Functor

experiment :: Functor f => (s -> f s) -> Pretext s a -> f a
experiment f (Pretext k) = k f

main = putStrLn "It typechecks, so it must be correct!"

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
import Control.Comonad
import Control.Applicative

newtype Bazaar s a = Bazaar {
    runBazaar :: forall f. Applicative f => (s -> f s) -> f a
  } deriving Functor

main = putStrLn "It typechecks, so it must be correct!"

{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad
import Control.Applicative

data FunList s a
    = Done a
    | More s (FunList s (s -> a))
    deriving Functor

main = putStrLn "It typechecks, so it must be correct!"

rule :: Num s => Word8 -> Store s Bool -> Bool
rule w (Store f s) = testBit w $
  0 & partsOf (taking 3 bits) .~ [f (s+1), f s, f (s-1)]

0 & partsOf (taking 3 bits) .~ [f (s+1), f s, f (s-1)]

extend (rule 110) :: Num s => Store s Bool -> Store s Bool

slowLoop :: (Store s a -> a) -> Store s a -> [Store s a]
slowLoop f = iterate (extend f)

tab :: Memo s -> Store s a -> Store s a
tab opt (Store f s) = Store (opt f) s

type Memo a = forall r. (a -> r) -> a -> r

loop :: Integral s => (Store s a -> a) -> Store s a -> [Store s a]
loop f = iterate (extend f . tab integral)

-- TODO: copy the whole program below here
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}

import Control.Comonad
import Control.Lens as L
import Data.Bits
import Data.Bits.Lens as L
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.MemoCombinators
import Data.Word
import Diagrams.Backend.SVG
import Diagrams.Prelude as D
import Text.Blaze.Svg.Renderer.Utf8
import Yesod

data Store s a = Store (s -> a) s deriving Functor

instance Comonad (Store s) where
  extract (Store f s) = f s
  duplicate (Store f s) = Store (Store f) s

experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s

rule :: Num s => Word8 -> Store s Bool -> Bool
rule w (Store f s) = testBit w $
  0 L.& partsOf (taking 3 L.bits) .~ [f (s+1), f s, f (s-1)]

tab :: Memo s -> Store s a -> Store s a
tab opt (Store f s) = Store (opt f) s

loop :: Integral s => (Store s a -> a) -> Store s a -> [Store s a]
loop f = iterate (extend f . tab integral)

window :: (Enum s, Num s) => s -> s -> Store s a -> [a]
window l h = experiment $ \ s -> [s-l..s+h]

xo :: Bool -> Char
xo True  = 'X'
xo False = ' '

main = mapM_ (putStrLn . map xo . window 50 0) $
       take 50 $ loop (rule 110) $ Store (==0) 0

grid :: [[Bool]] -> Diagram SVG R2
grid = vcat . map (hcat . cell) where
  cell b = unitSquare D.# fc (if b then black else white)

svg :: Diagram SVG R2 -> Strict.ByteString
svg = Strict.concat . Lazy.toChunks .
      renderSvg . renderDia SVG (SVGOptions (Width 400) Nothing)

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}

import Control.Comonad
import Control.Lens as L
import Data.Bits
import Data.Bits.Lens as L
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.MemoCombinators
import Data.Word
import Diagrams.Backend.SVG
import Diagrams.Prelude as D
import Text.Blaze.Svg.Renderer.Utf8
import Yesod

data Store s a = Store (s -> a) s deriving Functor

instance Comonad (Store s) where
  extract (Store f s) = f s
  duplicate (Store f s) = Store (Store f) s

experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s

rule :: Num s => Word8 -> Store s Bool -> Bool
rule w (Store f s) = testBit w $ 0 L.& partsOf (taking 3 L.bits) .~ [f (s+1), f s, f (s-1)]

tab :: Memo s -> Store s a -> Store s a
tab opt (Store f s) = Store (opt f) s

loop :: Integral s => (Store s a -> a) -> Store s a -> [Store s a]
loop f = iterate (extend f . tab integral)

window :: (Enum s, Num s) => s -> s -> Store s a -> [a]
window l h = experiment $ \ s -> [s-l..s+h]

grid :: [[Bool]] -> Diagram SVG R2
grid = cat unitY . reverse . map (hcat . map cell) where
  cell b = unitSquare D.# fc (if b then black else white)

svg :: Diagram SVG R2 -> Strict.ByteString
svg = Strict.concat . Lazy.toChunks . renderSvg . renderDia SVG (SVGOptions (Width 400) Nothing)

data App = App

instance Yesod App

mkYesod "App" [parseRoutes| / ImageR GET |]

getImageR :: MonadHandler m => m TypedContent
getImageR = sendResponse $ toTypedContent (typeSvg, toContent img)

img = svg . grid . map (window 49 0) . take 50 . loop (rule 110) $ Store (==0) (0 :: Int)

main = warpEnv App

distributeReader :: Functor f => f (r -> a) -> (r -> f a)
distributeReader fra = \r -> fmap ($r) fra

log(a + c) = log a + log (1 + c/a)

newtype Fix f = Fix (f (Fix f))

newtype FixF f a = FixF (f (FixF f) a)
deriving instance (Show (f (FixF f) a)) => Show (FixF f a)

instance Functor (f (FixF f)) => Functor (FixF f) where
    fmap f (FixF x) = FixF $ fmap f x

instance Applicative (f (FixF f)) => Applicative (FixF f) where
    pure x = FixF $ pure x
    (FixF f) < *> (FixF x) = FixF (f < *> x)

-- FixF . Compose . Just . FixF . Compose $ Nothing
-- > FixF (Compose (Just (FixF (Compose Nothing))))
-- :t FixF (Compose (Just (FixF (Compose Nothing))))
-- > FixF (Compose Maybe) a

newtype Embed (f :: * -> *) a = Embed a deriving (Show)

instance Functor (Embed f) where
    fmap f (Embed x) = Embed $ f x

instance Applicative (Embed f) where
    pure x = Embed x
    (Embed f) < *> (Embed x) = Embed (f x)

-- FixF $ Embed "hi"
-- > FixF (Embed "hi")

-- fmap (++ " world") $ FixF (Embed "hi")
-- > FixF (Embed "hi world")

-- FixF . Product (Embed "hi") .
--        FixF . Product (Embed "there") . FixF $ undefined
-- > FixF (Product (Embed "hi")
--   (FixF (Product (Embed "there")
--   (FixF *** Exception: Prelude.undefined

-- :t FixF . Product (Embed "hi") . FixF . Product (Embed "there") . FixF $ undefined
-- > FixF (Product (Embed f)) [Char]

data ProductF f g (b :: * -> *) a =
      ProductF (f b a) (g b a) deriving Show

instance (Functor (f b), Functor (g b)) =>
         Functor (ProductF f g b) where
                fmap f (ProductF x y) = ProductF (fmap f x) (fmap f y)

instance (Applicative (f b), Applicative (g b)) =>
         Applicative (ProductF f g b) where
               pure x = ProductF (pure x) (pure x)
              (ProductF f g) < *> (ProductF x y) = ProductF (f < *> x) (g < *> y)

yy = FixF . ProductF (Embed "foo") $ InL $ Const ()
xx = FixF . ProductF (Embed "bar") . InR .
  FixF . ProductF (Embed "baz") . InL $ Const ()

-- :t yy
-- > FixF (ProductF Embed (Sum (Const ()))) [Char]

-- (++) < $> yy < *> xx
-- > FixF (ProductF (Embed "foobar") (InL (Const ())))

-- liftA2 (++) (InL (Identity "hi")) $
--      InR (Product (Identity " there") (Const ([12::Int])))
-- > InL (Identity "hi there")
-- liftA2 (++) (InR (Identity "hi")) $ InL (Product (Identity " there") (Const ([12::Int])))
-- > InL (Product (Identity "hi there") (Const [12]))

{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,
StandaloneDeriving, FlexibleContexts, UndecidableInstances,
GADTs, KindSignatures, RankNTypes #-}

module Main where
import Control.Applicative hiding (Const)
import Data.Monoid hiding (Sum, Product)
import Control.Monad.Identity
instance Show a => Show (Identity a) where
    show (Identity x) = "(Identity " ++ show x ++ ")"

data Const mo a = Const mo deriving Show

instance Functor (Const mo) where
    fmap _ (Const mo) = Const mo

instance Monoid mo => Applicative (Const mo) where
    pure _ = Const mempty
    (Const f) < *> (Const x) = Const (f <> x)

newtype Compose f g a = Compose (f (g a)) deriving Show

instance (Functor f, Functor g) => Functor (Compose f g) where
    fmap f (Compose x) = Compose $ (fmap . fmap) f x

instance (Applicative f, Applicative g) => Applicative (Compose f g) where
    pure = Compose . pure . pure
    (Compose f) < *> (Compose x) = Compose $ (< *>) < $> f < *> x

data Product f g a = Product (f a) (g a) deriving Show

instance (Functor f, Functor g) => Functor (Product f g) where
    fmap f (Product  x y) = Product (fmap f x) (fmap f y)

instance (Applicative f, Applicative g) => Applicative (Product f g) where
    pure x = Product (pure x) (pure x)
    (Product f g) < *> (Product  x y) = Product (f < *> x) (g < *> y)

type Writer mo = Product (Const mo) Identity

tell :: mo -> Writer mo ()
tell x = Product (Const x) (pure ())

-- tell [1] *> tell [2]
-- > Product (Const [1,2]) (Identity ())

type FailingWriter mo = Compose (Writer mo) Maybe

tellFW :: Monoid mo => mo -> FailingWriter mo ()
tellFW x = Compose (tell x *> pure (Just ()))

failFW :: Monoid mo => FailingWriter mo a
failFW = Compose (pure Nothing)

-- tellFW [1] *> tellFW [2]
-- > Compose (Product (Const [1,2]) (Identity Just ()))

-- tellFW [1] *> failFW *> tellFW [2]
-- > Compose (Product (Const [1,2]) (Identity Nothing))

type HasEnv k m = Product (Const [k]) m
takeEnv :: (k -> m a) -> k -> HasEnv k m a
takeEnv f x = Product (Const [x]) (f x)

data Reader r a = Reader (r -> a)
instance Functor (Reader r) where
    fmap f (Reader x) = Reader (f . x)
instance Applicative (Reader r) where
    pure x = Reader $ pure x
    (Reader f) < *> (Reader x) = Reader (f < *> x)

runReader :: (Reader r a) -> r -> a
runReader (Reader f) = f

takeEnvNew :: (env -> k -> a) -> k -> HasEnv k (Reader env) a
takeEnvNew f x = Product (Const [x]) (Reader $ flip f x)

type FormletOne mo a = Product (Const mo) Identity a

type FormletTwo mo env a =
    Product (Const mo) (Compose (Reader env) Maybe) a

type FormletThree mo err env a =
    Product (Const mo)
            (Compose (Reader env) (Product (Const err) Maybe)) a

data Sum f g a = InL (f a) | InR (g a) deriving Show

instance (Functor f, Functor g) => Functor (Sum f g) where
    fmap f (InL x) = InL (fmap f x)
    fmap f (InR y) = InR (fmap f y)

class Natural f g where
    eta :: f a -> g a

instance (Applicative f, Applicative g, Natural g f) =>
  Applicative (Sum f g) where
    pure x = InR $ pure x
    (InL f) < *> (InL x) = InL (f < *> x)
    (InR g) < *> (InR y) = InR (g < *> y)
    (InL f) < *> (InR x) = InL (f < *> eta x)
    (InR g) < *> (InL x) = InL (eta g < *> x)

instance Monoid mo => Natural f (Const mo) where
    eta = const (Const mempty)

instance Applicative f =>
  Natural g (Compose f g) where
     eta = Compose . pure

instance (Applicative g, Functor f) => Natural f (Compose f g) where
     eta = Compose . fmap pure

instance (Natural f g) => Natural f (Product f g) where
    eta x = Product x (eta x)

instance (Natural g f) => Natural g (Product f g) where
    eta x = Product (eta x) x

instance Natural (Product f g) f where
    eta (Product x _ ) = x

instance Natural (Product f g) g where
    eta (Product _ x) = x

instance Natural g f => Natural (Sum f g) f where
    eta (InL x) = x
    eta (InR y) = eta y

instance Natural Identity (Reader r) where
    eta (Identity x) = pure x

-- instance Applicative g => Natural Identity g where
--     eta (Identity x) = pure x

type Validation mo = Sum (Const mo) Identity

validationError :: Monoid mo => mo -> Validation mo a
validationError x = InL (Const x)

type Formlet mo err env a =
    Product (Const mo)
            (Compose (Reader env)
                     (Sum (Const err) Identity))
    a

type FormletClean mo err env a = (mo, env -> Either err a)

  class Eq a => Ord a where ...
  instance (Eq a, Eq b) => Eq (a, b) where ...

 U a ~= forall r. (a -> M r) -> U r
M a ~= forall r. (a -> M r) -> M r

t f e = f (v e) (st e)
  where
  rd :: e -> a
  st :: e -> e

t (const id) e = st e
 where
 st :: e -> e

remote-repo:
  hdiff.luite.com:http://hdiff.luite.com/packages/archive

   {-# LANGUAGE Rank2Types #-}  -- we'll relax this later
   import Data.Complex -- for complex examples

type Lens a b =
  forall f. Functor f =>
  (b -> f b) -> a -> f a

realLens :: RealFloat a => Lens (Complex a) a
realLens f (r :+ i) = fmap (:+ i) (f r)

imagLens :: RealFloat a => Lens (Complex a) a
imagLens f (r :+ i) = fmap (r :+) (f i)

type LensFamily a b c d =
  forall f. Functor f =>
  (c -> f d) -> a -> f b

data Store c d b = Store (d -> b) c

instance Functor (Store c d) where
  fmap f (Store g c) = Store (f . g) c

newtype DataLensFamily a b c d = DataLensFamily (a -> Store c d b)

dlens :: LensFamily a b c d -> DataLensFamily a b c d
dlens l = DataLensFamily (l (Store id))

plens :: DataLensFamily a b c d -> LensFamily a b c d
plens (DataLensFamily l) f a = case l a of
  Store g c -> fmap g (f c)

infixl 8 ^.
newtype Getting b a = Getting { got :: b }
instance Functor (Getting b) where
    fmap _ (Getting b) = Getting b
(^.) :: a -> ((c -> Getting c d) -> a -> Getting c b) -> c
x ^. l = got (l Getting x)

newtype Setting a = Setting { unsetting :: a }
instance Functor Setting where
    fmap f (Setting a) = Setting (f a)
infixr 4 %=
(%=) :: ((c -> Setting d) -> a -> Setting b) -> (c -> d) -> a -> b
l %= f = unsetting . l (Setting . f)

infixr 4 ^=
(^=) :: ((c -> Setting d) -> a -> Setting b) -> d -> a -> b
l ^= v = l %= const v

lens :: (a -> c) -> (a -> d -> b) -> LensFamily a b c d
lens f g h a = fmap (g a) (h (f a))

iso :: (a -> c) -> (d -> b) -> LensFamily a b c d
iso f g h a = fmap g (h (f a))

fstLens :: LensFamily (a,c) (b,c) a b
fstLens f (a,b) = fmap (\x -> (x,b)) (f a)

sndLens :: LensFamily (a,b) (a,c) b c
sndLens f (a,b) = fmap ((,) a) (f b)

swap :: (a,b) -> (b,a)
swap (a,b) = (b,a)

swapped :: LensFamily (a,b) (c,d) (b,a) (d,c)
swapped = iso swap swap

negated :: Num a => Lens a a
negated = iso negate negate

ghci> (1:+2,3) ^.fstLens.realLens
1.0
ghci> fstLens . realLens ^= 4 $ (1:+2,3)
(4.0 :+ 2.0,3)

ghci> (fstLens . sndLens ^= "hello") ((1,()),3)
((1,"hello"),3)

traverseLens :: ((c -> c) -> a -> b) -> a -> b
traverseLens f = f id

ghci> :t traverseLens (fstLens . sndLens)
traverseLens (fstLens . sndLens)
  :: Functor f => ((a, f b), c) -> f ((a, b), c)

-- pseudo-Haskell
-- type LensFamily outer inner =
--    forall a b. LensFamily (outer a) (outer b) (inner a) (inner b)

type Getter a c = forall r d b. (c -> Getting r d) -> a -> Getting r b

-- | build a getting out of a function
getting :: (a -> b) -> Getter a b
getting g f = Getting . got . f . g

getFst :: Getter (a,b) a
getFst = getting fst

getSnd :: Getter (a,b) b
getSnd = getting snd

getPhase :: RealFloat a => Getter (Complex a) a
getPhase = getting phase

getAbs, getSignum  :: Num a => Getter a a
getAbs = getting abs
getSignum = getting signum

ghci> (0,(1:+2,3)) ^. getting snd . fstLens . getting magnitude
2.23606797749979

ghci> getting magnitude ^= 12
<interactive>:2:1:
    Couldn't match expected type `Setting d0'
                with actual type `Getting r0 d1'
    Expected type: (c0 -> Setting d0) -> a1 -> Setting b1
      Actual type: (c0 -> Getting r0 d1) -> a0 -> Getting r0 b0
    In the return type of a call of `getting'
    In the first argument of `(^=)', namely `getting magnitude'
</interactive>

type Setter a d b = (() -> Setting d) -> a -> Setting b

setting :: (a -> d -> b) -> Setter a d b
setting f g a = Setting (f a (unsetting (g ())))

plus, times :: Num a => Setter a a a
plus = setting (+)
times = setting (*)

ghci> setting (+) ^= 12 $ 32
44
ghci> fstLens . setting (*) ^= 12 $ (2,3)
(24,3)

ghci> (setting (+) . realLens ^= 12) 1
<interactive>:15:16:
    Couldn't match expected type `()' with actual type `Complex d0'
    Expected type: (d0 -> Setting d0) -> () -> Setting b0
      Actual type: (d0 -> Setting d0)
                   -> Complex d0 -> Setting (Complex d0)
    In the second argument of `(.)', namely `realLens'
    In the first argument of `(^=)', namely `setting (+) . realLens'
</interactive>

type Modifier a b c d = (c -> Setting d) -> a -> Setting b

modifying :: ((c -> d) -> a -> b) -> Modifier a b c d
modifying f g a = Setting (f (unsetting . g) a)

ghci> modifying map %= (+1) $ [1,2,3]
[2,3,4]

ghci> modifying map . sndLens %= (+1) $ [("hello",1),("goodbye",2)]
[("hello",2),("goodbye",3)]

modifying fmap . modifying fmap
  :: (Functor g, Functor f) =>
     (c -> Setting d) -> f (g c) -> Setting (f (g d))

ghci> [1,2,3] ^. modifying fmap
<interactive>:18:12:
    Couldn't match expected type `Getting c0 d0'
                with actual type `Setting d1'
    Expected type: (c0 -> Getting c0 d0) -> [t0] -> Getting c0 b1
      Actual type: Modifier a0 b0 c0 d1
    In the return type of a call of `modifying'
    In the second argument of `(^.)', namely `modifying map'
</interactive>

reals :: (RealFloat a, RealFloat b) => Modifier (Complex a) (Complex b) a b
reals = modifying (\f (r :+ i) -> f r :+ f i)

ghci> reals %= (+1) $  1 :+ 2
2 :+ 3
ghci> fstLens . reals %= (+1) $ (1 :+ 2, 4)
(2.0 :+ 3.0,4)

ghci> :m + Data.Lens
ghci> modifying (`adjust` "goodbye") %= (+1) $
      fromList [("hello",1),("goodbye",2)]
fromList [("goodbye",3),("hello",1)]

ghci> :t \l y -> l ^= y ^. l + 1 $ y
<interactive>:1:19:
    Couldn't match expected type `Getting d0 d1'
                with actual type `Setting d0'
    Expected type: (d0 -> Getting d0 d1) -> a1 -> Getting d0 b1
      Actual type: (d0 -> Setting d0) -> a0 -> Setting b0
    In the second argument of `(^.)', namely `l'
    In the first argument of `(+)', namely `y ^. l'
</interactive>

clone ::
  ((c -> Store c d d) -> (a -> Store c d b)) ->
  LensFamily a b c d
clone l f a = case l (Store id) a of
  Store g c -> fmap g (f c)

ghci> :t \l y -> clone l ^= y ^. clone l + 1 $ y
\l y -> clone l ^= y ^. clone l + 1 $ y
  :: Num d => ((c -> Store c d1 d1) -> a -> Store d d b) -> a -> b

{-# LANGUAGE RankNTypes #-}

import Data.Maybe (fromMaybe)
import Control.Applicative
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Control.Monad
import Control.Monad.Trans.Class
import Data.Functor.Identity

ε: (X -> Prop) -> X

data LazyNat = Zero | Succ LazyNat
infinity :: LazyNat
infinity = Succ infinity

palmer :: (LazyNat -> Bool) -> LazyNat
palmer p
  | p Zero = Zero
  | otherwise = Succ $ palmer $ p . Succ

type Cantor = Integer -> Bool

infixr 0 #
(#) :: Bool -> Cantor -> Cantor
(x # a) 0 = x
(x # a) i = a (i - 1)

berger :: (Cantor -> Bool) -> Cantor
berger p =
  if ex $ \a -> p $ False # a
  then False # berger $ \a -> p $ False # a
  else True  # berger $ \a -> p $ True # a
  where ex q = q (berger q)

escardo :: (Cantor -> Bool) -> Cantor
escardo p = go x l r where
  go x l r n =  case divMod n 2 of
    (0, 0) -> x
    (q, 1) -> l q
    (q, 0) -> r $ q-1
  x = ex $ \l -> ex $ \r -> p $ go True l r
  l = escardo $ \l -> ex $ \r -> p $ go x l r
  r = escardo $ \r -> p $ go x l r
  ex q = q (escardo q)

newtype S s a = S { runS :: s -> (a, s) }

instance Functor (S s) where
  fmap f (S m) = S $ \s -> case m s of
    (a, s') -> (f a, s')

instance Applicative (S s) where
  pure = return
  (< *>) = ap

instance Monad (S m) where
  return a = S $ \s -> (a, s)
  S m >>= k = S $ \s -> case m s of
    (a, s') -> runS (k a) s'

let mu f a =
  let r = ref 0 in
  let b n = (r := max n ! r; a n) in
    ignore (f b);
    !r

-- bad
modulus :: (Num b, Ord s) =>
  ((s -> S s a) -> S b c) -> (s -> a) -> b

-- still bad
modulus :: Real a =>
  ((a -> S n b) -> S n c) -> (a -> b) -> a

-- getting better
modulus :: Real a =>
  (forall f. Monad f => (a -> f b) -> f c) ->
  (a -> b) ->
  a

-- good
modulus :: Real a =>
  (forall f. (Monad f, Applicative f) => (a -> f b) -> f c) ->
  (a -> b) ->
  a

modulus (\a -> a 10 >>= a) (\n -> n * n)
100

newtype K r s a = K { runK :: (a -> s -> r) -> s -> r }

instance Functor (K r s) where
  fmap = liftM

instance Applicative (K r s) where
  pure = return
  (< *>) = ap

instance Monad (K r s) where
  return a = K $ \k -> k a
  K m >>= f = K $ \k -> m $ \a -> runK (f a) k

neighborhood ::
  (forall f. (Applicative f, Monad f) => (Int -> f Bool) -> f Bool) ->
  IntMap Bool
neighborhood phi = snd $ runK (phi beta) (,) IntMap.empty where
  beta n = K $ \k s -> case IntMap.lookup n s of
    Just b -> k b s
    Nothing -> case k True (IntMap.insert n True s) of
      (False, _) -> k False (IntMap.insert n False s)
      r -> r

bauer ::
  (forall f. (Applicative f, Monad f) => (Int -> f Bool) -> f Bool) ->
  Cantor
bauer p = \n -> fromMaybe True $ IntMap.lookup n m where
  m = neighborhood p

exists ::
  (forall f. (Applicative f, Monad f) => (Int -> f Bool) -> f Bool) ->
  Bool
forAll ::
  (forall f. (Applicative f, Monad f) => (Int -> f Bool) -> f Bool) ->
  Bool

#if 0
class Eq a => Ord a
instance Eq a => Eq [a]
#endif

ordEq :: Ord a :- Eq a
ordEq = Sub Dict

eqList :: Eq a :- Eq [a]
eqList = Sub Dict

class Class b h | h -> b where
  cls :: h :- b

infixr 9 :=>
class b :=> h | h -> b where
  ins :: b :- h

instance Class () (Class b a) where cls = Sub Dict
instance Class () (b :=> a) where cls = Sub Dict

-- class Eq a => Ord a where ...
instance Class (Eq a) (Ord a) where cls = Sub Dict
-- instance Eq a => Eq [a] where ...
instance Eq a :=> Eq [a] where ins = Sub Dict

#ifdef UNDECIDABLE
instance Class b a => () :=> Class b a where ins = Sub Dict
instance (b :=> a) => () :=> b :=> a where ins = Sub Dict
#endif

instance Class () () where cls = Sub Dict
instance () :=> () where ins = Sub Dict

instance Class () (Eq a) where cls = Sub Dict
instance () :=> Eq () where ins = Sub Dict
instance () :=> Eq Int where ins = Sub Dict
instance () :=> Eq Bool where ins = Sub Dict
instance () :=> Eq Integer where ins = Sub Dict
instance () :=> Eq Float where ins = Sub Dict
instance () :=> Eq Double where ins = Sub Dict
instance Eq a :=> Eq [a] where ins = Sub Dict
instance Eq a :=> Eq (Maybe a) where ins = Sub Dict
instance Eq a :=> Eq (Complex a) where ins = Sub Dict
instance Eq a :=> Eq (Ratio a) where ins = Sub Dict
instance (Eq a, Eq b) :=> Eq (a, b) where ins = Sub Dict
instance (Eq a, Eq b) :=> Eq (Either a b) where ins = Sub Dict
instance () :=> Eq (Dict a) where ins = Sub Dict
instance () :=> Eq (a :- b) where ins = Sub Dict

instance Class (Eq a) (Ord a) where cls = Sub Dict
instance () :=> Ord () where ins = Sub Dict
instance () :=> Ord Bool where ins = Sub Dict
instance () :=> Ord Int where ins = Sub Dict
instance ():=> Ord Integer where ins = Sub Dict
instance () :=> Ord Float where ins = Sub Dict
instance ():=> Ord Double where ins = Sub Dict
instance () :=> Ord Char where ins = Sub Dict
instance Ord a :=> Ord (Maybe a) where ins = Sub Dict
instance Ord a :=> Ord [a] where ins = Sub Dict
instance (Ord a, Ord b) :=> Ord (a, b) where ins = Sub Dict
instance (Ord a, Ord b) :=> Ord (Either a b) where ins = Sub Dict
instance Integral a :=> Ord (Ratio a) where ins = Sub Dict
instance () :=> Ord (Dict a) where ins = Sub Dict
instance () :=> Ord (a :- b) where ins = Sub Dict

instance Class () (Show a) where cls = Sub Dict
instance () :=> Show () where ins = Sub Dict
instance () :=> Show Bool where ins = Sub Dict
instance () :=> Show Ordering where ins = Sub Dict
instance () :=> Show Char where ins = Sub Dict
instance Show a :=> Show (Complex a) where ins = Sub Dict
instance Show a :=> Show [a] where ins = Sub Dict
instance Show a :=> Show (Maybe a) where ins = Sub Dict
instance (Show a, Show b) :=> Show (a, b) where ins = Sub Dict
instance (Show a, Show b) :=> Show (Either a b) where ins = Sub Dict
instance (Integral a, Show a) :=> Show (Ratio a) where ins = Sub Dict
instance () :=> Show (Dict a) where ins = Sub Dict
instance () :=> Show (a :- b) where ins = Sub Dict

instance Class () (Read a) where cls = Sub Dict
instance () :=> Read () where ins = Sub Dict
instance () :=> Read Bool where ins = Sub Dict
instance () :=> Read Ordering where ins = Sub Dict
instance () :=> Read Char where ins = Sub Dict
instance Read a :=> Read (Complex a) where ins = Sub Dict
instance Read a :=> Read [a] where ins = Sub Dict
instance Read a :=> Read (Maybe a) where ins = Sub Dict
instance (Read a, Read b) :=> Read (a, b) where ins = Sub Dict
instance (Read a, Read b) :=> Read (Either a b) where ins = Sub Dict
instance (Integral a, Read a) :=> Read (Ratio a) where ins = Sub Dict

instance Class () (Enum a) where cls = Sub Dict
instance () :=> Enum () where ins = Sub Dict
instance () :=> Enum Bool where ins = Sub Dict
instance () :=> Enum Ordering where ins = Sub Dict
instance () :=> Enum Char where ins = Sub Dict
instance () :=> Enum Int where ins = Sub Dict
instance () :=> Enum Integer where ins = Sub Dict
instance () :=> Enum Float where ins = Sub Dict
instance () :=> Enum Double where ins = Sub Dict
instance Integral a :=> Enum (Ratio a) where ins = Sub Dict

instance Class () (Bounded a) where cls = Sub Dict
instance () :=> Bounded () where ins = Sub Dict
instance () :=> Bounded Ordering where ins = Sub Dict
instance () :=> Bounded Bool where ins = Sub Dict
instance () :=> Bounded Int where ins = Sub Dict
instance () :=> Bounded Char where ins = Sub Dict
instance (Bounded a, Bounded b) :=> Bounded (a,b) where ins = Sub Dict

instance Class () (Num a) where cls = Sub Dict
instance () :=> Num Int where ins = Sub Dict
instance () :=> Num Integer where ins = Sub Dict
instance () :=> Num Float where ins = Sub Dict
instance () :=> Num Double where ins = Sub Dict
instance RealFloat a :=> Num (Complex a) where ins = Sub Dict
instance Integral a :=> Num (Ratio a) where ins = Sub Dict

instance Class (Num a, Ord a) (Real a) where cls = Sub Dict
instance () :=> Real Int where ins = Sub Dict
instance () :=> Real Integer where ins = Sub Dict
instance () :=> Real Float where ins = Sub Dict
instance () :=> Real Double where ins = Sub Dict
instance Integral a :=> Real (Ratio a) where ins = Sub Dict

instance Class (Real a, Enum a) (Integral a) where cls = Sub Dict
instance () :=> Integral Int where ins = Sub Dict
instance () :=> Integral Integer where ins = Sub Dict

instance Class (Num a) (Fractional a) where cls = Sub Dict
instance () :=> Fractional Float where ins = Sub Dict
instance () :=> Fractional Double where ins = Sub Dict
instance RealFloat a :=> Fractional (Complex a) where ins = Sub Dict
instance Integral a :=> Fractional (Ratio a) where ins = Sub Dict

instance Class (Fractional a) (Floating a) where cls = Sub Dict
instance () :=> Floating Float where ins = Sub Dict
instance () :=> Floating Double where ins = Sub Dict
instance RealFloat a :=> Floating (Complex a) where ins = Sub Dict

instance Class (Real a, Fractional a) (RealFrac a) where cls = Sub Dict
instance () :=> RealFrac Float where ins = Sub Dict
instance () :=> RealFrac Double where ins = Sub Dict
instance Integral a :=> RealFrac (Ratio a) where ins = Sub Dict

instance Class (RealFrac a, Floating a) (RealFloat a) where cls = Sub Dict
instance () :=> RealFloat Float where ins = Sub Dict
instance () :=> RealFloat Double where ins = Sub Dict

instance Class () (Monoid a) where cls = Sub Dict
instance () :=> Monoid () where ins = Sub Dict
instance () :=> Monoid Ordering where ins = Sub Dict
instance () :=> Monoid [a] where ins = Sub Dict
instance Monoid a :=> Monoid (Maybe a) where ins = Sub Dict
instance (Monoid a, Monoid b) :=> Monoid (a, b) where ins = Sub Dict

instance Class () (Functor f) where cls = Sub Dict
instance () :=> Functor [] where ins = Sub Dict
instance () :=> Functor Maybe where ins = Sub Dict
instance () :=> Functor (Either a) where ins = Sub Dict
instance () :=> Functor ((->) a) where ins = Sub Dict
instance () :=> Functor ((,) a) where ins = Sub Dict
instance () :=> Functor IO where ins = Sub Dict

instance Class (Functor f) (Applicative f) where cls = Sub Dict
instance () :=> Applicative [] where ins = Sub Dict
instance () :=> Applicative Maybe where ins = Sub Dict
instance () :=> Applicative (Either a) where ins = Sub Dict
instance () :=> Applicative ((->)a) where ins = Sub Dict
instance () :=> Applicative IO where ins = Sub Dict
instance Monoid a :=> Applicative ((,)a) where ins = Sub Dict

instance Class (Applicative f) (Alternative f) where cls = Sub Dict
instance () :=> Alternative [] where ins = Sub Dict
instance () :=> Alternative Maybe where ins = Sub Dict

instance Class () (Monad f) where cls = Sub Dict
instance () :=> Monad [] where ins = Sub Dict
instance () :=> Monad ((->) a) where ins = Sub Dict
instance () :=> Monad (Either a) where ins = Sub Dict
instance () :=> Monad IO where ins = Sub Dict

instance Class (Monad f) (MonadPlus f) where cls = Sub Dict
instance () :=> MonadPlus [] where ins = Sub Dict
instance () :=> MonadPlus Maybe where ins = Sub Dict

#if 0
class Class h where
  type Sup h :: Constraint
  type Sup h = ()
  cls :: h :- Sup h
  default cls :: h :- ()
  cls = Sub Dict

class Instance h where
  type Ctx h :: Constraint
  type Ctx h = ()
  ins :: Ctx h :- h
  default ins :: h => Ctx h :- h
  ins = Sub Dict

instance Class (Class a)
instance Class (Instance a)

#ifdef UNDECIDABLE
instance Class a => Instance (Class a)
instance Instance a => Instance (Instance a)
#endif

instance Class ()
instance Instance ()
#endif

#if 0
instance Class (Eq a)
instance Instance (Eq ())
instance Instance (Eq Int)
instance Instance (Eq Bool)
instance Instance (Eq Integer)
instance Instance (Eq Float)
instance Instance (Eq Double)
#endif

#if 0
instance Instance (Eq [a]) where
  type Ctx (Eq [a]) = Eq a
  ins = Sub Dict
instance Instance (Eq (Maybe a)) where
  type Ctx (Eq (Maybe a)) = Eq a
  ins = Sub Dict
instance Instance (Eq (Complex a)) where
  type Ctx (Eq (Complex a)) = Eq a
  ins = Sub Dict
instance Instance (Eq (Ratio a)) where
  type Ctx (Eq (Ratio a)) = Eq a
  ins = Sub Dict
instance Instance (Eq (a, b)) where
  type Ctx (Eq (a,b)) = (Eq a, Eq b)
  ins = Sub Dict
instance Instance (Eq (Either a b)) where
  type Ctx (Eq (Either a b)) = (Eq a, Eq b)
  ins = Sub Dict
#endif

evil :: a :- b
evil = unsafeCoerce refl

instance Monad m :=> Applicative (WrappedMonad m) where ins = Sub Dict

applicative :: forall m a. Monad m => (Applicative m => m a) -> m a
applicative m =
  m \\ trans (evil :: Applicative (WrappedMonad m) :- Applicative m) ins

(< &>) :: Monad m => m a -> m b -> m (a, b)
m < &> n = applicative $ (,) < $> m < *> n

(< &>) :: Monad m => m a -> m b -> m (a, b)
m < &> n = unwrapMonad $ (,) < $> WrapMonad m < *> WrapMonad n

instance MonadPlus m :=> Alternative (WrappedMonad m) where ins = Sub Dict

alternative :: forall m a. MonadPlus m => (Alternative m => m a) -> m a
alternative m =
  m \\ trans (evil :: Alternative (WrappedMonad m) :- Alternative m) ins

{-# LANGUAGE
  CPP,
  ScopedTypeVariables,
  FlexibleInstances,
  FlexibleContexts,
  ConstraintKinds,
  KindSignatures,
  TypeOperators,
  FunctionalDependencies,
  Rank2Types,
  StandaloneDeriving,
  GADTs
  #-}

{-# LANGUAGE UndecidableInstances #-}
#define UNDECIDABLE

import Control.Monad
import Control.Monad.Instances
import Control.Applicative
import Data.Monoid
import Data.Complex
import Data.Ratio
import Unsafe.Coerce

data Dict a where
  Dict :: a => Dict a

deriving instance Eq (Dict a)
deriving instance Ord (Dict a)
deriving instance Show (Dict a)

#ifdef UNDECIDABLE
deriving instance a => Read (Dict a)
instance a => Monoid (Dict a) where
  mappend Dict Dict = Dict
  mempty = Dict
#endif

infixr 9 :-
newtype a :- b = Sub (a => Dict b)

instance Eq (a :- b) where
  _ == _ = True

instance Ord (a :- b) where
  compare _ _ = EQ

instance Show (a :- b) where
  showsPrec d _ = showParen (d > 10) $
    showString "Sub Dict"

refl :: a :- a
refl = Sub Dict

weaken1 :: (a, b) :- a
weaken1 = Sub Dict

weaken2 :: (a, b) :- b
weaken2 = Sub Dict

contract :: a :- (a, a)
contract = Sub Dict

infixl 1 \\ -- required comment
(\\) :: a => (b => r) -> (a :- b) -> r
r \\ Sub Dict = r

trans :: (b :- c) -> (a :- b) -> a :- c
trans f g = Sub $ Dict \\ f \\ g

(&&&) :: (a :- b) -> (a :- c) -> a :- (b, c)
f &&& g = Sub $ Dict \\ f \\ g

(***) :: (a :- b) -> (c :- d) -> (a, c) :- (b, d)
f *** g = Sub $ Dict \\ f \\ g

#if 0
class BifunctorS (p :: Constraint -> Constraint -> Constraint) where
  bimapS :: (a :- b) -> (c :- d) -> p a c :- p b d
#endif

#ifdef POLYMORPHIC_KINDS
class Category (k :: x -> x -> *) where
  id :: k a a
  (.) :: k b c -> k a b -> k a c
instance Category (:-) where
  id = refl
  (.) = trans
#endif

#if 0
class Bifunctor (p :: x -> y -> z) where
  type Left p :: x -> x -> *
  type Left p = (->)
  type Right p :: y -> y -> *
  type Right p = (->)
  type Cod p :: z -> z -> *
  type Cod p = (->)
  bimap :: Left p a b -> Right p c d -> Cod p (p a c) (p b d)
#endif

-- (,) :: Constraint -> Constraint -> Constraint and
-- (,) :: * -> * -> *

--    ?
--   / \
-- (#)  ??
--     /  \
--    #    *  Constraint
--          \ /
--          ???

-- Box
--  |
--  @

-- (,) :: forall (k :: @). k -> k -> k
-- () :: forall (k :: @). k

{-# LANGUAGE RecordWildCards, ViewPatterns, FlexibleInstances, MultiParamTypeClasses #-}

import Text.Parsec
import qualified Text.Parsec.Token as T
import Text.Parsec.Token
    (GenLanguageDef(..), GenTokenParser(TokenParser))
import Text.Parsec.Pos (initialPos, updatePosChar)
import Data.Functor.Identity (Identity(..))
import Control.Applicative hiding ((< |>))
import Control.Monad.Fix (fix)

(< />) :: Monad m => ParsecT s u m a -> ParsecT s u m a ->
    ParsecT s u m a
p < /> q = try p < |> q
infixl 3 < />

type Result d a = Consumed (Reply d () a)

rat :: Monad m => (d -> Result d a) -> ParsecT d u m a
rat f   = mkPT $ \s0 -> return $
    return . patch s0 < $> f (stateInput s0) where
  patch (State _ _ u) (Ok a (State s p _) err) = Ok a (State s p u) err
  patch _             (Error e)                = Error e

womp :: d -> SourcePos -> ParsecT d () Identity a -> Result d a
womp d pos p = fmap runIdentity . runIdentity $
    runParsecT p (State d pos ())

myLanguageDef :: Monad m => T.GenLanguageDef D u m
myLanguageDef = T.LanguageDef
  { commentStart    = "{-"
  , commentEnd      = "-}"
  , commentLine     = "--"
  , nestedComments  = True
  , identStart      = letter < |> char '_'
  , identLetter     = alphaNum < |> oneOf "_'"
  , opStart         = opLetter myLanguageDef
  , opLetter        = oneOf ":!#$%&*+./< =>?@\\^|-~"
  , reservedOpNames = []
  , reservedNames   = []
  , caseSensitive   = True
  }

TokenParser {..} = T.makeTokenParser myLanguageDef

data D = D
  { _add        :: Result D Integer
  , _mult       :: Result D Integer
  , _primary    :: Result D Integer
  , _dec        :: Result D Integer
  , _uncons     :: Maybe (Char, D)
  }

instance Monad m => Stream D m Char where
  uncons = return . _uncons

add, mult, primary, dec :: Parsec D u Integer
add     = rat _add
mult    = rat _mult
primary = rat _primary
dec     = rat _dec

parse :: SourceName -> String -> D
parse n = go (initialPos n) where
  go p s = fix $ \d -> let
    (womp d p -> _add) =
            (+) < $> mult < * reservedOp "+" <*> add
        < /> mult < ?> "summand"
    (womp d p -> _mult) =
            (*) < $> primary < * reservedOp "*" <*> mult
        < /> primary < ?> "factor"
    (womp d p -> _primary) =
            parens add
        < /> dec < ?> "number"
    (womp d p -> _dec) = natural
    _uncons = case s of
      (x:xs) -> Just (x, go (updatePosChar p x) xs)
      []     -> Nothing
    in D { .. }

runD :: Parsec D u a -> u -> SourceName -> String -> Either ParseError a
runD p u fn s = runParser p u fn (prep fn s)

eval :: String -> Integer
eval s = either (error . show) id $
    runD (whiteSpace *> add < * eof) () "-" s

{-# LANGUAGE RecordWildCards, ViewPatterns, DeriveFunctor #-}
import Control.Applicative
import Control.Monad (MonadPlus(..), guard)
import Control.Monad.Fix (fix)
import Data.Char (isDigit, digitToInt, isSpace)

newtype Rat d a = Rat { runRat :: d -> Result d a }
  deriving Functor

data Result d a
  = Pure a             -- didn't consume anything, can backtrack
  | Commit d a      -- consumed input
  | Fail String Bool -- failed, flagged if consumed
  deriving Functor

instance Applicative (Rat d) where
  pure a = Rat $ \ _ -> Pure a
  Rat mf < *> Rat ma = Rat $ \ d -> case mf d of
    Pure f      -> fmap f (ma d)
    Fail s c    -> Fail s c
    Commit d' f -> case ma d' of
      Pure a       -> Commit d' (f a)
      Fail s _     -> Fail s True
      Commit d'' a -> Commit d'' (f a)

instance Alternative (Rat d) where
  Rat ma < |> Rat mb = Rat $ \ d -> case ma d of
    Fail _ False -> mb d
    x            -> x
  empty = Rat $ \ _ -> Fail "empty" False

instance Monad (Rat d) where
  return a = Rat $ \_ -> Pure a
  Rat m >>= k = Rat $ \d -> case m d of
    Pure a -> runRat (k a) d
    Commit d' a -> case runRat (k a) d' of
      Pure b -> Commit d' b
      Fail s _ -> Fail s True
      commit -> commit
    Fail s c -> Fail s c
  fail s = Rat $ \ _ -> Fail s False

instance MonadPlus (Rat d) where
  mplus = (< |>)
  mzero = empty

try :: Rat d a -> Rat d a
try (Rat m) = Rat $ \d -> case m d of
  Fail s _ -> Fail s False
  x        -> x

(< />) :: Rat d a -> Rat d a -> Rat d a
p < /> q = try p < |> q
infixl 3 < />

class Stream d where
  anyChar :: Rat d Char

whiteSpace :: Stream d => Rat d ()
whiteSpace = () < $ many (satisfy isSpace)
phrase :: Stream d => Rat d a -> Rat d a
phrase m = whiteSpace *> m < * eof

notFollowedBy :: Rat d a -> Rat d ()
notFollowedBy (Rat m) = Rat $ \d -> case m d of
  Fail{} -> Pure ()
  _      -> Fail "unexpected" False

eof :: Stream d => Rat d ()
eof = notFollowedBy anyChar

satisfy :: Stream d => (Char -> Bool) -> Rat d Char
satisfy p = try $ do
  x < - anyChar
  x <$ guard (p x)

char :: Stream d => Char -> Rat d Char
char c = satisfy (c ==)

lexeme :: Stream d => Rat d a -> Rat d a
lexeme m = m < * whiteSpace

symbol :: Stream d => Char -> Rat d Char
symbol c = lexeme (char c)

digit :: Stream d => Rat d Int
digit = digitToInt < $> satisfy isDigit

instance Stream [Char] where
  anyChar = Rat $ \s -> case s of
    (x:xs) -> Commit xs x
    [] -> Fail "EOF" False

data D = D
  { _add        :: Result D Int
  , _mult       :: Result D Int
  , _primary    :: Result D Int
  , _decimal    :: Result D Int
  , anyCharD    :: Result D Char
  }

add, mult, primary, decimal :: Rat D Int
add     = Rat _add
mult    = Rat _mult
primary = Rat _primary
decimal = Rat _decimal

instance Stream D where
  anyChar = Rat anyCharD

parse :: String -> D
parse s = fix $ \d -> let
  Rat (dv d -> _add) =
        (+) < $> mult < * symbol '+' <*> add
     < /> mult
  Rat (dv d -> _mult) =
        (*) < $> primary < * symbol '*' <*> mult
    < /> primary
  Rat (dv d -> _primary) =
        symbol '(' *> add < * symbol ')'
    </> decimal
  Rat (dv d -> _decimal) =
     foldl' (\b a -> b * 10 + a) 0 < $> lexeme (some digit)
  anyCharD = case s of
    (x:xs) -> Commit (parse xs) x
    []     -> Fail "EOF" False
  in D { .. }

dv :: d -> (d -> b) -> b
dv d f = f d

eval :: String -> Int
eval s = case runRat (whiteSpace *> add < * eof) (parse s) of
  Pure a -> a
  Commit _ a -> a
  Fail s _ -> error s

s .* (u + v) = s .* u + s .* v
(s + t) .* v = s .* v + t .* v

   (s * t) .* v = s .* (t .* v)

   1 .* v = v

  (*.) :: V -> F -> V
  v *. f = f .* v

-- (a + b) + c = a + (b + c)
class Additive m where
  (+) :: m -> m -> m
  replicate1p :: Whole n => n -> m -> m -- (ignore this for now)
  -- ...

-- a + b = b + a
class Additive m => Abelian m

-- (a * b) * c = a * (b * c)
class Multiplicative m where
  (*) :: m -> m -> m
  pow1p :: Whole n => m -> n -> m
  -- ...

-- a*(b + c) = a*b + a*c
-- (a + b)*c = a*c + b*c
class (Additive m, Abelian m, Multiplicative m) => Semiring

-- r .* (x + y) = r .* x + r .* y
-- (r + s) .* x = r .* x + s .* x
-- (r * s) .* x = r .* (s .* x)
class (Semiring r, Additive m) => LeftModule r m
   (.*) :: r -> m -> m

class (Semiring r, Additive m) => RightModule r m
   (*.) :: m -> r -> m

-- | zero + a = a = a + zero
class
    (LeftModule Natural m,
    RightModule Natural m
    ) => AdditiveMonoid m where
   zero :: m
   replicate :: Whole n => n -> m -> m

-- | a + negate a = zero = negate a + a
class
    (LeftModule Integer m
    , RightModule Integer m
    ) => AdditiveGroup m where
  negate :: m -> m
  times :: Integral n => n -> m -> m
  -- ...

instance Additive m => Additive (e -> m) where
   f + g = \x -> f x + g x

instance Abelian m => Abelian (e -> m)

instance AdditiveMonoid m => AdditiveMonoid (e -> m) where
   zero = const zero

instance AdditiveGroup m => AdditveGroup (e -> m) where
   f - g = \x -> f x - g x

instance Semiring r => LeftModule r (e -> m) where
   r .* f = \x -> r * f x

instance LeftModule r m => LeftModule r (e -> m) where
   (.*) m f e = m .* f e

instance RightModule r m => RightModule r (e -> m) where
   (*.) f m e = f e *. m

f (a .* x + y) = a * f x + f y

bad f = f 0 * f 0

newtype LinearM r e =
  LinearM {
    runLinearM :: forall r. LeftModule r m => (e -> m) -> m
  }

infixr 0 $*
newtype Linear r a = Linear { ($*) :: (a -> r) -> r }

instance AdditiveMonoid r => Alternative (Linear r a) where
  Linear f < |> Linear g = Linear (f + g)
  empty = Linear zero

b -> ((a -> r) ~> r)

(a -> r) ~> (b -> r)

infixr 0 $#
newtype Map r b a = Map { ($#) :: (a -> r) -> (b -> r) }

instance Category (Map r) where
  Map f . Map g = Map (g . f)
  id = Map id

class Contravariant f where
  contramap :: (a -> b) -> f a -> f b

-- | Dual function arrows.
newtype Op a b = Op { getOp :: b -> a }

instance Contravariant (Op a) where
  contramap f g = Op (getOp g . f)

instance Functor (Linear r) where
  fmap f m = Linear $ \k -> m $* k . f

newtype Vect r a = Vect { runVect :: [(r,a)] }

instance MultiplicativeMonoid r => Monad (Vect r) where
   return a = Vect [(1,a)]
   Vect as >>= f = Vect
       [ (p*q, b) | (p,a) < - as, (q,b) <- runVect (f b) ]

instance Monad (Linear r) where
  return a = Linear $ \k -> k a
  m >>= f = Linear $ \k -> m $* \a -> f a $* k

F E = (E -> F, F,\f g x -> f x + g x ,\r f x -> r * f x)

delta :: (Rig r, Eq a) => e -> e -> r
delta i j | i == j = one
       | otherwise = zero

vectMap :: Rig r => Vect r a -> Linear r a
vectMap (Vect as) = Map $ \k -> sum [ r * k a | (r, a) < - as ]

memo :: HasTrie a => (a -> r) -> a -> r

memoMap :: HasTrie a => Map r a a
memoMap = Map memo

memoLinear :: HasTrie a => a -> Linear r a
memoLinear = Linear . flip memo

newtype Co w m a = Co (forall r. w (a -> r) -> r)

Co w ~ Co (f . g) ~ g . f

{-# LANGUAGE GADTs, FlexibleInstances #-}

import Control.Comonad
import Control.Comonad.Trans.Class

data L w a where
  L :: w (r -> a) -> r -> L w a

instance Functor w => Functor (L w) where
  fmap f (L w r) = L (fmap (f .) w) r

instance ComonadTrans L where
  lower (L w r) = fmap ($r) w

instance Extend w => Extend (L w) where
  duplicate (L w s) = L (extend L w) s

instance Comonad w => Comonad (L w) where
  extract (L w r) = extract w r

L w a ~ exists r. (w (r -> a), r)
      ~ exists r. (f (g (r -> a)), r)
      ~ exists r. (f (), g (r -> a), r)
      ~ exists r. (f (), f () -> r -> a, r)
      ~ exists r. (f () -> r -> a, f r)
      ~ exists r. (f r -> a, f r)
      ~ Density f a
      ~ Lan f f a
      ~ (f . Lan f Id) a
      ~ (f . g) a
      ~ w a

data L w a where
  L :: w (r -> a) -> r -> L w a

data D f w a where
  D :: w (f r -> a) -> f r -> D f w a

instance Functor w => Functor (D f w) where
  fmap f (D w r) = D (fmap (f .) w) r

instance Extend w => Extend (D f w) where
  duplicate (D w s) = D (extend D w) s

instance Comonad w => Comonad (D f w) where
  extract (D w r) = extract w r

instance ComonadTrans (D f) where
  lower (D w r) = fmap ($r) w

fstD :: (Extend f, Comonad w) => D f w a -> f a
fstD (D w r) = extend (extract w) r

sndD :: Comonad w => D f w a -> w a
sndD = lower

newtype Product m n a = Pair { runFst :: m a, runSnd :: n a }

instance (Monad m, Monad n) => Monad (Product m n) where
   return a = Pair (return a) (return a)
   Pair ma na >>= f = Pair (ma >>= runFst . f) (na >>= runSnd . f)

newtype Coproduct f g a = Coproduct { getCoproduct :: Either (f a) (g a) }

left :: f a -> Coproduct f g a
left = Coproduct . Left

right :: g a -> Coproduct f g a
right = Coproduct . Right

coproduct :: (f a -> b) -> (g a -> b) -> Coproduct f g a -> b
coproduct f g = either f g . getCoproduct

instance (Extend f, Extend g) => Extend (Coproduct f g) where
  extend f = Coproduct . coproduct
    (Left . extend (f . Coproduct . Left))
    (Right . extend (f . Coproduct . Right))

instance (Comonad f, Comonad g) => Comonad (Coproduct f g) where
  extract = coproduct extract extract

braid :: (Extend f, Comonad w) => D f w a -> D w f a
braid (D w r) = D (extend (flip extract) r) w

sndD (braid (D w r)) = -- by braid def
sndD (D (extend (flip extract) r) w) = -- by sndD (and lower) def
fmap ($w) (extend (flip extract) r) = -- extend fmap fusion
extend (($w) . flip extract) r = -- @unpl
extend (\t -> flip extract t w) r = -- flip . flip = id
extend (extract w) r = -- by fstD def
fstD (D w r)

newtype CoT w m a = CoT { runCoT :: w (a -> m r) -> m r

type Co w = CoT w Identity

Co w ~ Co (f . g) ~ g . f

CoT w m a ~ forall r. w (a -> m r) -> m r
    ~ forall r. f (g (a -> m r)) -> m r
    ~ forall r. f (f() -> a -> m r) -> m r
    ~ forall r. f (a -> f () -> m r) -> m r
    ~ forall r. (a -> f () -> m r, f ()) -> m r
    ~ forall r. (a -> f () -> m r) -> f () -> m r
    ~ forall r. (a -> g (m r)) -> g (m r)
    ~ Codensity (g . m) a

instance
    (Adjunction f g, Adjunction f' g') =>
    Adjunction (Compose f' f) (Compose g g') where
  unit   = Compose . leftAdjunct (leftAdjunct Compose)
  counit = rightAdjunct (rightAdjunct getCompose) . getCompose

newtype CoT w m a = CoT { runCoT :: forall r. w (a -> m r) -> m r }

type Co w = CoT w Identity

co :: Functor w => (forall r. w (a -> r) -> r) -> Co w a
co f = CoT (Identity . f . fmap (fmap runIdentity))

runCo :: Functor w => Co w a -> w (a -> r) -> r
runCo m = runIdentity . runCoT m . fmap (fmap Identity)

instance Functor w => Functor (CoT w m) where
  fmap f (CoT w) = CoT (w . fmap (. f))

instance Extend w => Apply (CoT w m) where
  mf < .> ma = mf >>- \f -> fmap f ma

instance Extend w => Bind (CoT w m) where
  CoT k >>- f = CoT (k . extend (\wa a -> runCoT (f a) wa))

instance Comonad w => Applicative (CoT w m) where
  pure a = CoT (`extract` a)
  mf < *> ma = mf >>= \f -> fmap f ma

instance Comonad w => Monad (CoT w m) where
  return a = CoT (`extract` a)
  CoT k >>= f = CoT (k . extend (\wa a -> runCoT (f a) wa))

instance Comonad w => MonadTrans (CoT w) where
  lift m = CoT (extract . fmap (m >>=))

instance (Comonad w, MonadIO m) => MonadIO (CoT w m) where
  liftIO = lift . liftIO

liftCoT0 :: Comonad w => (forall a. w a -> s) -> CoT w m s
liftCoT0 f = CoT (extract < *> f)

lowerCoT0 :: (Functor w, Monad m) => CoT w m s -> w a -> m s
lowerCoT0 m = runCoT m . (return < $)

lowerCo0 :: Functor w => Co w s -> w a -> s
lowerCo0 m = runIdentity . runCoT m . (return < $)

liftCoT1 :: (forall a. w a -> a) -> CoT w m ()
liftCoT1 f = CoT (`f` ())

lowerCoT1 :: (Functor w, Monad m) => CoT w m () -> w a -> m a
lowerCoT1 m = runCoT m . fmap (const . return)

lowerCo1 :: Functor w => Co w () -> w a -> a
lowerCo1 m = runIdentity . runCoT m . fmap (const . return)

posW :: (ComonadStore s w, Monad m) => CoT w m s
posW = liftCoT0 pos

peekW :: (ComonadStore s w, Monad m) => s -> CoT w m ()
peekW s = liftCoT1 (peek s)

peeksW :: (ComonadStore s w, Monad m) => (s -> s) -> CoT w m ()
peeksW f = liftCoT1 (peeks f)

askW :: (ComonadEnv e w, Monad m) => CoT w m e
askW = liftCoT0 (Env.ask)

asksW :: (ComonadEnv e w, Monad m) => (e -> a) -> CoT w m a
asksW f = liftCoT0 (Env.asks f)

traceW :: (ComonadTraced e w, Monad m) => e -> CoT w m ()
traceW e = liftCoT1 (Traced.trace e)

instance (Comonad w, MonadReader e m) => MonadReader e (CoT w m) where
  ask = lift Reader.ask
  local f m = CoT (local f . runCoT m)

instance (Comonad w, MonadState s m) => MonadState s (CoT w m) where
  get = lift get
  put = lift . put

instance (Comonad w, MonadWriter e m) => MonadWriter e (CoT w m) where
  tell = lift . tell
  pass m = CoT (pass . runCoT m . fmap aug) where
    aug f (a,e) = liftM (\r -> (r,e)) (f a)
  listen = error "Control.Monad.Co.listen: TODO"

instance (Comonad w, MonadError e m) => MonadError e (CoT w m) where
  throwError = lift . throwError
  catchError = error "Control.Monad.Co.catchError: TODO"

instance (Comonad w, MonadCont m) => MonadCont (CoT w m) where
  callCC = error "Control.Monad.Co.callCC: TODO"

class (Functor f, Representable u) =>
         Adjunction f u | f -> u, u -> f where
    leftAdjunct :: (f a -> b) -> a -> u b
    rightAdjunct :: (a -> u b) -> f a -> b

newtype Op a b = Op { getOp :: b -> a }

instance Contravariant (Op a) where
  contramap f g = Op (getOp g . f)

class (Contravariant f, Corepresentable g) =>
       Adjunction f g | f -> g, g -> f where
    leftAdjunct :: (b -> f a) -> a -> g b
    rightAdjunct :: (a -> g b) -> b -> f a

{-# LANGUAGE Rank2Types, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}

import Data.Monoid
import Control.Comonad
import Control.Applicative
import Control.Comonad.Store.Class
import Control.Comonad.Env.Class as Env
import Control.Comonad.Traced.Class as Traced
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
import Data.Functor.Bind

newtype Co w a = Co { runCo :: forall r. w (a -> r) -> r }

instance Functor w => Functor (Co w) where
   fmap f (Co w) = Co (w . fmap (. f))

instance Comonad w => Monad (Co w) where
   return a = Co (`extract` a)
   Co k >>= f = Co (k .extend (\wa a -> runCo (f a) wa))

instance Comonad w => Applicative (Co w) where
   mf < *> ma = mf >>= \f -> fmap f ma
   pure a = Co (`extract` a)

instance Extend w => Bind (Co w) where
   Co k >>- f = Co (k .extend (\wa a -> runCo (f a) wa))

instance Extend w => Apply (Co w) where
   mf < .> ma = mf >>- \f -> fmap f ma

Co (Store s) a ~ forall r. ((s -> a -> r, s) -> r)
         ~ forall r. (s -> a -> r) -> s -> r
         ~ forall r. (a -> s -> r) -> s -> r
         ~ Codensity ((->)s) a
         ~ State s a

instance ComonadStore s m => MonadState s (Co m) where
   get = Co (\w -> extract w (pos w))
   put s = Co (\w -> peek s w ())

instance ComonadEnv e m => MonadReader e (Co m) where
   ask = Co (\w -> extract w (Env.ask w))
   local = error "local"

class Monad m => MonadReader e m | m -> e where
   ask :: m a -> e

class MonadReader e m => MonadLocal e m | m -> e where
   local :: (e -> e) -> m a -> m a

instance (Monoid e, ComonadTraced e m) => MonadWriter e (Co m) where
   tell m = Co (\w -> Traced.trace m w ())
   listen = error "listen"
   pass = error "pass"

instance Monad m => MonadWriter e m | m -> e where
    tell :: e -> m ()

instance MonadWriter e m => MonadListen e m | m -> e
    listen :: m a -> m (a, w)
    pass :: m (a, w -> w) -> m a

lift0 :: Comonad w => (forall a. w a -> s) -> Co w s
lift0 f = Co (extract < *> f)

lift1 :: (forall a. w a -> a) -> Co w ()
lift1 f = Co (`f` ())

lower0 :: Functor w => Co w s -> w a -> s
lower0 (Co f) w = f (id < $ w)

lower1 :: Functor w => Co w () -> w a -> a
lower1 (Co f) w = f (fmap const w)

get = lift0 pos
put s = lift1 (peek s)
ask = lift0 Env.ask
tell s = lift1 (tell s)

Co w a ~ forall r. (f (g (a -> r)) -> r).

tabulateAdjunction :: Adjunction f u => (f () -> b) -> u b
tabulateAdjunction f = leftAdjunct f ()

indexAdjunction :: Adjunction f u => u b -> f a -> b
indexAdjunction = rightAdjunct . const

Co w a ~ f (g (a -> r)) -> r ~ f (f () -> a -> r) -> r

split :: Adjunction f u => f a -> (a, f ())
split = rightAdjunct (flip leftAdjunct () . (,))

unsplit :: Adjunction f g => a -> f () -> f a
unsplit a = fmap (const a)

Co w a ~ forall r. f (f () -> a -> r) -> r ~
   forall r. (f () -> a -> r, f ()) -> r

Co w a ~ forall r. (f () -> a -> r) -> f () -> r

Co w a ~ forall r. (a -> f () -> r) -> f () -> r

Co w a ~ forall r. (a -> g r) -> g r

Co w a ~ Codensity g a

Codensity g a ~ Ran g g a

Ran g g a ~ g (f a)

class (Contravariant f, Contravariant g) => DualContravariantAdjunction f g where
    leftAdjunct :: (f a -> b) -> g b -> a
    rightAdjunct :: (g b -> a) -> f a -> b

newtype Absurd a = Absurd (Absurd a)

absurdity :: Absurd a -> b
absurdity (Absurd a) = absurdity a

instance Contravariant Absurd where
   contramap f (Absurd as) = Absurd (contramap f as)

instance DualContravariantAdjunction Absurd Absurd where
    leftAdjunct _ = absurdity
    rightAdjunct _ = absurdity

newtype Silly m a = Silly { runSilly :: Absurd (m (Absurd a)) }

instance Monad m => Extend (Silly m) where
    extend f (Silly m) = absurdity m

instance Monad m => Comonad (Silly m) where
    extract (Silly m) = absurdity m

data Store i o r = Store (i -> r) o
    deriving (Functor)

class Functor y => Yieldable y i o | y -> i o where
   yield :: o -> y i

instance Yieldable (Store i o) i o where
   yield = Store id

type Yield i o = Free (Store i o)

liftFree :: Functor f => f a -> Free f a
liftFree = Free . fmap Pure

instance Yieldable y i o => Yieldable (Free y) i o where
   yield = liftFree . yield

foo :: Num o => Yield () o ()
foo = do
   yield 1
   yield 2
   yield 3

walk :: Traversable f => f o -> Yield i o (f i)
walk = traverse yield

type Iterator i o = Codensity (Yield i o)

instance (Monad y, Yieldable y i o) => Yieldable (Codensity y) i o where
   yield = liftCodensity . yield

liftF :: Functor f => f a -> F f a
liftF f = F (\kp kf -> kf (fmap kp f))

instance Yieldable y i o => Yieldable (F y) i o where
   yield = liftF . yield

newtype Iterator i o a = Iterator
  { runIterator ::
    forall r. (a -> r) -> (o -> (i -> r) -> r) -> r)
  }

newtype RSIterator i o a = RSIterator
    { runRSIterator :: forall r.
          (a -> (o -> (i -> r) -> r) -> r)
             -> (o -> (i -> r) -> r) -> r
    }

newtype IO a =
   IO (State# RealWorld -> (# a, State# RealWorld #))

type FFI o i -- external, side-effecting computation taking o, returning i

newtype OI a = forall o i. OI (FFI o i) o (i -> a) deriving Functor

-- data FIO a where
--    Return :: a -> FIO a
--    FIO :: FFI o i -> o -> (i -> FIO a) -> FIO a

newtype IO a = IO
    (forall r. (a -> r) ->
                 (forall i o. FFI o i -> o -> (i -> r) -> r) ->
                 r)

FFI = (->)

unsafePerformIO :: IO a -> a
unsafePerformIO (IO m) = m id (\ oi o ir -> ir (oi o))

newtype Yoneda f a = Yoneda (forall r. (a -> r) -> f r)

liftYoneda :: Functor f => f a -> Yoneda f a
liftYoneda a = Yoneda (\f -> fmap f a)

lowerYoneda :: Yoneda f a -> f a
lowerYoneda (Yoneda f) = f id

instance MonadState s (Codensity ((->) s)) where
   get = Codensity (\k s -> k s s)
   put s = Codensity (\k _ -> k () s)

instance Functor (Yoneda f) where
  fmap f (Yoneda m) = Yoneda (\k -> m (k . f))

instance Monad m => Monad (Yoneda m) where
  return a = Yoneda (\f -> return (f a))
  Yoneda m >>= k = Yoneda (\f -> m id >>= \a -> runYoneda (k a) f)

newtype Endo a = Endo { appEndo :: a -> a }

newtype YMaybe a = YMaybe (forall r. (a -> r) -> r -> r)

newtype GEndo m r = GEndo (m r -> m r)

newtype Rec f r = (f r -> r) -> r

newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r }

instance Functor (F f) where
   fmap f (F g) = F (\kp -> g (kp . f))

instance Monad (F f) where
   return a = F (\kp _ -> kp a)
   F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf)

instance MonadTrans F where
   lift f = F (\kp kf -> kf (liftM kp f))

instance Functor f => MonadFree f (F f) where
   wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f))

fromF :: MonadFree f m => F f a -> m a
fromF (F m) = m return wrap

toF :: Functor f => Free f a -> F f a
toF xs = F (\kp kf -> go kp kf xs) where
  go kp _  (Pure a) = kp a
  go kp kf (Free fma) = kf (fmap (go kp kf) fma)

newtype CF f a = CF (forall r. (a -> (f r -> r) -> r) -> (f r -> r) -> r)

newtype ScottFree f a = ScottFree
    { runScottFree :: forall r.
       (a -> r) -> (f (ScottFree f a) -> r) -> r
    }

instance Functor f => Monad (ScottFree f) where
   return a = ScottFree (\kp _ -> kp a)
   ScottFree m >>= f = ScottFree
       (\kb kf -> m (\a -> runScottFree (f a) kb kf) (kf . fmap (>>= f)))

lowerF :: F f a -> Free f a
lowerF (F f) = f Pure Free

improve :: (forall a. MonadFree f m => m a) -> Free f a
improve m = lowerF m

data Free f a = Pure a | Free (f (Free f a))

instance Functor f => Functor (Free f) where
   fmap f (Pure a) = Pure (f a)
   fmap f (Free as) = Free (fmap (fmap f) as)

instance Functor f => Monad (Free f) where
   return = Pure
   Pure a >>= f = f a -- the first monad law!
   Free as >>= f = Free (fmap (>>= f) as)

instance MonadTrans Free where
    lift = Free . liftM Pure

retract :: Monad f => Free f a -> f a
retract (Pure a) = return a
retract (Free as) = as >>= retract

class (Monad m, Functor f) => MonadFree f m | m -> f where
    wrap :: f (m a) -> m a

instance Functor f => MonadFree f (Free f) where
    wrap = Free

instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where
    wrap fs = ReaderT $ \e -> wrap $ fmap (`runReaderT` e) fs

newtype Codensity f a = Codensity (forall r. (a -> f r) -> f r)

instance Functor (Codensity k) where
  fmap f (Codensity m) = Codensity (\k -> m (k . f))

instance Monad (Codensity f) where
  return x = Codensity (\k -> k x)
  m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))

instance MonadTrans Codensity where
   lift m = Codensity (m >>=)

instance Functor (ContT r m) where
    fmap f m = ContT $ \c -> runContT m (c . f)

instance Monad (ContT r m) where
    return a = ContT ($ a)
    m >>= k  = ContT $ \c -> runContT m (\a -> runContT (k a) c)

instance MonadTrans (ContT r) where
    lift m = ContT (m >>=)

lowerCodensity :: Monad m => Codensity m a -> m a
lowerCodensity (Codensity m) = m return

runContT :: ContT r m a -> m r
runContT (ContT m) = m return

    (f >>= g) >>= h

   f >>= \x -> g x >>= h

m >>= f = join (fmap f m)

-- join :: Functor f => Free f (Free f a) -> Free f a
-- join (Pure a) = a
-- join (Free as) = Free (fmap join as)

-- data Tree a = Tip a | Bin (Tree a) (Tree a)

data Bin a = Bin a a
    deriving (Functor, Foldable, Traversable)
    -- using LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable

type Tree = Free Bin

bin :: MonadFree Bin m => m a -> m a -> m a
bin l r = wrap (Bin l r)

instance MonadFree f m => MonadFree f (Codensity m) where
  wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t))

improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a
improve m = lowerCodensity m

spec :: Eq a => a -> (a -> b) -> a -> b

(define-curried (id x) x)
(id + 1 2 3) ;;=> 6

(define-curried (compose f g x) (f (g x)))
(define-curried (const a _) a)

;; curried lambda
(define-syntax curried
  (syntax-rules ()
    ((_ () body)
     (lambda args
         (if (null? args)
             body
             (apply body args))))
    ((_ (arg) body)
      (letrec
        ((partial-application
          (lambda args
            (if (null? args)
                partial-application
                (let ((arg (car args))
                      (rest (cdr args)))
                  (if (null? rest)
                      body
                      (apply body rest)))))))
        partial-application))
    ((_ (arg args ...) body)
     (letrec
       ((partial-application
         (lambda all-args
           (if (null? all-args)
               partial-application
               (let ((arg (car all-args))
                     (rest (cdr all-args)))
                 (let ((next (curried (args ...) body)))
                   (if (null? rest)
                       next
                       (apply next rest))))))))
       partial-application))))

;; curried defines
(define-syntax define-curried
  (syntax-rules ()
    ((define-curried (name args ...) body)
       (define name (curried (args ...) body)))
    ((define-curried (name) body)
       (define name (curried () body)))
    ((define-curried name body)
       (define name body))))

*Data.Reflection> reify (+)
    (reflect < *> pure 1 < *> (reflect < *> pure 2 < *> pure 3))
6

{-# LANGUAGE
     MultiParamTypeClasses,
     FlexibleInstances, Rank2Types,
     FlexibleContexts, UndecidableInstances #-}
import Control.Applicative
import Data.Reflection
import Data.Monoid
import Data.Tagged

newtype M s a = M a

instance Reifies s (a,a → a → a) ⇒ Monoid (M s a) where
    mempty = tagMonoid $ fst < $> reflect
    a `mappend` b = tagMonoid $
        snd < $> reflect < *> monoidTag a < *> monoidTag b

monoidTag :: M s a → Tagged s a
monoidTag (M a) = Tagged a

tagMonoid :: Tagged s a → M s a
tagMonoid (Tagged a) = M a

withMonoid :: a → (a → a → a) →
    (∀s. Reifies s (a, a → a → a) ⇒ M s w) → w
withMonoid e op m = reify (e,op) (monoidTag m)

*> withMonoid 0 (+) (M 5 `mappend` M 4 `mappend` mempty)
9

{-# LANGUAGE
   TypeOperators
 , MultiParamTypeClasses
 , FlexibleInstances
 , FlexibleContexts
 , UndecidableInstances
 , ScopedTypeVariables
 , GeneralizedNewtypeDeriving
 #-}

module Incremental where

import Text.Show
import Text.Read
import Data.Reflection
import Data.Monoid.Reducer hiding (Sum,getSum,cons,ReducedBy(Reduction,getReduction))

class Functor f => Algebra f m where
    phi :: f m -> m

class Functor f => Coalgebra f m where
    psi :: m -> f m

instance Functor f => Algebra f () where
    phi _ = ()

-- F-Algebra product
instance (Algebra f m, Algebra f n) => Algebra f (m,n) where
    phi a = (phi (fmap fst a), phi (fmap snd a))

instance (Algebra f m, Algebra f n, Algebra f o)
  => Algebra f (m,n,o) where
    phi a = (phi (fmap f a),phi (fmap g a),phi (fmap h a)) where
        f (x,_,_) = x
        g (_,y,_) = y
        h (_,_,z) = z

newtype Mu f = In (f (Mu f))

instance (Eq (f (Mu f))) => Eq (Mu f) where
    In f == In g = f == g

instance (Ord (f (Mu f))) => Ord (Mu f) where
    In f `compare` In g = f `compare` g

instance (Show (f (Mu f))) => Show (Mu f) where
    showsPrec d (In f) = showParen (d > 10) $
        showString "In " . showsPrec 11 f

instance (Read (f (Mu f))) => Read (Mu f) where
    readPrec = parens . prec 10 $ do
        Ident "In " < - lexP
        f <- step readPrec
        return (In f)

instance Functor f => Algebra f (Mu f) where
    phi = In

instance Functor f => Coalgebra f (Mu f) where
    psi (In x) = x

data (f :> m) = f (f :> m) :> m

value :: (f :> m) -> m
value (_ :> m) = m

instance (Eq m, Eq (f (f :> m))) => Eq (f :> m) where
    f :> m == g :> n = f == g && m == n
    f :> m /= g :> n = f /= g || m /= n

instance (Ord m, Ord (f (f :> m))) => Ord (f :> m) where
    (f :> m) `compare` (g :> n) | a == EQ = m `compare` n
                                | otherwise = a
        where a = f `compare` g

instance (Show m, Show (f (f :> m))) => Show (f :> m) where
    showsPrec d (f :> m) = showParen (d > 9) $
        showsPrec 10 f .
        showString " :> " .
        showsPrec 10 m

instance (Read m, Read (f (f :> m))) => Read (f :> m) where
    readPrec = parens $ prec 9 $ do
            f < - step readPrec
            Symbol ":>" < - lexP
            m <- step readPrec
            return (f :> m)

instance Functor f => Coalgebra f (f :> m) where
    psi (x :> _) = x

instance Algebra f m => Algebra f (f :> m) where
    phi x = x :> phi (fmap value x)

forget :: Functor f => (f :> m) -> f (f :> m)
forget = psi

remember :: Algebra f m => f (f :> m) -> f :> m
remember = phi

cata :: Algebra f a => (f :> m) -> a
cata = phi . fmap cata . forget

ana :: (Algebra f m, Coalgebra f a) => a -> (f :> m)
ana = remember . fmap ana . psi

tag :: Algebra f m => Mu f -> (f :> m)
tag = remember . fmap tag . psi

untag :: Functor f => (f :> m) -> Mu f
untag = phi . fmap untag . forget

data Tree a r = Bin r a r | Tip
    deriving (Eq,Ord,Show,Read)

instance Functor (Tree a) where
    fmap f (Bin x a y) = Bin (f x) a (f y)
    fmap _ Tip = Tip

bin :: Algebra (Tree a) m =>
    (Tree a :> m) -> a -> (Tree a :> m) -> (Tree a :> m)
bin a v b = remember (Bin a v b)

tip :: Algebra (Tree a) m => (Tree a :> m)
tip = remember Tip

testTree :: (Num a, Algebra (Tree a) m) => Tree a :> m
testTree = bin tip 2 (bin (bin tip 3 tip) 4 tip)

newtype Size = Size { getSize :: Int } deriving (Eq,Ord,Show,Read,Num)
instance Algebra (Tree a) Size where
    phi (Bin x _ y) = x + 1 + y
    phi Tip = 0

newtype Sum = Sum { getSum :: Int } deriving (Eq,Ord,Show,Read,Num)
instance Algebra (Tree Int) Sum where
    phi (Bin x y z) = x + Sum y + z
    phi Tip = 0

*Incremental> testTree :: Tree Int :> Sum
Bin
    (Tip :> Sum {getSum = 0})
    2
    (Bin
        (Bin
            (Tip :> Sum {getSum = 0})
            3
            (Tip :> Sum {getSum = 0})
            :> Sum {getSum = 3}
        )
        4
        (Tip :> Sum {getSum = 0})
        :> Sum {getSum = 7}
    ) :> Sum {getSum = 9}

*Incremental> testTree :: Tree Int :> Mu (Tree Int)
Bin (Tip :> In Tip) 2 (Bin (Bin (Tip :> In Tip) 3 (Tip :> In Tip)
:> In (Bin (In Tip) 3 (In Tip))) 4 (Tip :> In Tip) :> In (Bin (In
(Bin (In Tip) 3 (In Tip))) 4 (In Tip))) :> In (Bin (In Tip) 2 (In
(Bin (In (Bin (In Tip) 3 (In Tip))) 4 (In Tip))))

newtype Mon m = Mon { getMon :: m } deriving (Eq,Ord,Show,Read,Monoid)

instance (a `Reducer` m) => Algebra (Tree a) (Mon m) where
    phi (Bin x v y) = x `mappend` Mon (unit v) `mappend` y
    phi Tip = mempty
    -- where unit :: (a `Reducer`m) => a -> m

data List a r = Cons a r | Nil
    deriving (Eq,Ord,Show,Read)

instance Functor (List a) where
    fmap f (Cons a x) = Cons a (f x)
    fmap _ Nil = Nil

instance Algebra (List a) Size where
    phi (Cons _ xs) = 1 + xs
    phi Nil = 0

instance Algebra (List Int) Sum where
    phi (Cons x xs) = fromIntegral x + xs
    phi Nil = 0

instance (a `Reducer` m) => Algebra (List a) (Mon m) where
    phi (Cons x xs) = Mon (unit x) `mappend` xs
    phi Nil = mempty

cons :: Algebra (List a) m => a -> (List a :> m) -> (List a :> m)
cons a b = remember (Cons a b)

nil :: Algebra (List a) m => List a :> m
nil = remember Nil

testList :: (Num a, Algebra (List a) m) => List a :> m
testList = cons 2 . cons 5 . cons 8 $ cons 27 nil

filter_phi ::
    Algebra (List a) m =>
    (a -> Bool) ->
    List a (List a :> m) -> List a :> m
filter_phi p Nil = nil
filter_phi p (Cons a as)
    | p a = cons a as
    | otherwise = as

newtype (a `ReducedBy` s) = Reduction { getReduction :: a }

instance (Functor f, s `Reflects` (f a -> a)) =>
  Algebra f (a `ReducedBy` s) where
    phi = Reduction . reflect (undefined :: s) . fmap getReduction

test :: List Int :> (Mon [Int],Size)
test = reify
    (filter_phi (\x -> x `mod` 2 == 0))
    (\\(_ :: s) ->
      getReduction (
        value (
          testList :: List Int :>
            ((List Int :> (Mon [Int],Size)) `ReducedBy` s))))

*Incremental> test
Cons 2 (
    Cons 8 (
        Nil :> (Mon {getMon = []},Size {getSize = 0})
    ) :> (Mon {getMon = [8]},Size {getSize = 1})
) :> (Mon {getMon = [2,8]},Size {getSize = 2})

F*[A] = A * F'[A]

module PointedSet where

import Control.Comonad -- from my category-extras library
import Data.List (inits,tails) -- used much later below

data PointedSet a = PointedSet a [a] deriving (Eq, Ord, Show, Read)

instance Functor PointedSet where
    fmap f (PointedSet x xs) = PointedSet (f x) $ fmap f xs

instance Copointed PointedSet where
    extract (PointedSet x _) = x

boring_duplicate :: PointedSet a -> PointedSet (PointedSet a)
boring_duplicate xxs@(PointedSet x xs) =
    PointedSet xxs $ fmap (flip PointedSet []) xs

*PointedSet> boring_duplicate $ PointedSet 0 [1..3]
PointedSet (PointedSet 0 [1..3]) [
    PointedSet 1 [],
    PointedSet 2 [],
    PointedSet 3 []
]

instance Comonad PointedSet where
    duplicate xxs@(PointedSet x xs) = PointedSet xxs $ refocus [] x xs
      where
        refocus :: [a] -> a -> [a] -> [PointedSet a]
        refocus acc x (y:ys) =
            PointedSet y (acc ++ (x:ys)) : refocus (y:acc) x ys
        refocus acc x [] = []

*PointedSet> duplicate $ PointedSet 0 [1..3] =
PointedSet (PointedSet 0 [1,2,3]) [
    PointedSet 1 [0,2,3],
    PointedSet 2 [1,0,3],
    PointedSet 3 [2,1,0]
]

smooth :: Fractional a => a -> PointedSet a -> a
smooth w (PointedSet a as) =
    w * a +
    (1 - w) * sum as / fromIntegral (length as)

*PointedSet> extend (smooth 0.5) $ PointedSet 10 [1..5]
PointedSet 6.5 [2.9,3.3,3.7,4.1,4.5]

data PointedCycle a = PointedCycle a [a] deriving (Eq, Ord, Show,Read)

instance Functor PointedCycle where
    fmap f (PointedCycle x xs) = PointedCycle (f x) $ fmap f xs

instance Copointed PointedCycle where
    extract (PointedCycle x _) = x

instance Comonad PointedCycle where
   duplicate xxs@(PointedCycle x xs) =
        PointedCycle xxs . fmap listToCycle . tail $ rotations (x:xs)
     where
        rotations :: [a] -> [[a]]
        rotations xs = init $ zipWith (++) (tails xs) (inits xs)
        listToCycle (x:xs) = PointedCycle x xs

*PointedSet> duplicate $ PointedCycle 0 [1..3]
PointedCycle (PointedCycle 0 [1,2,3]) [
    PointedCycle 1 [2,3,0],
    PointedCycle 2 [3,0,1],
    PointedCycle 3 [0,1,2]
]

class Functor f => Representable f x where
    rep :: (x -> a) -> f a
    unrep :: f a -> (x -> a)

{-# RULES
"rep/unrep" rep . unrep = id
"unrep/rep" unrep . rep = id
 #-}

instance Representable ((->)x) x where
    rep = id
    unrep = id

data Void {- you'll need EmptyDataDecls -}

instance Representable Identity Void where
    rep f = Identity (f undefined)
    unrep = const . runIdentity

class (Functor f, Functor g) =>
    Adjunction f g | f -> g, g -> f where
        unit   :: a -> g (f a)
        counit :: f (g a) -> a
        leftAdjunct  :: (f a -> b) -> a -> g b
        rightAdjunct :: (a -> g b) -> f a -> b

        unit = leftAdjunct id
        counit = rightAdjunct id
        leftAdjunct f = fmap f . unit
        rightAdjunct f = counit . fmap f

repAdjunction :: Adjunction f g => (f Void -> a) -> g a
repAdjunction f = leftAdjunct f undefined

unrepAdjunction :: Adjunction f g => g a -> (f Void -> a)
unrepAdjunction = rightAdjunct . const

instance Adjunction f g => Representable g (f Void) where
  rep = repAdjunction;
  unrep = unrepAdjunction

class (Representable g (f Void), Functor f) =>
    Adjunction f g | f -> g, g -> f where
        ...

strength :: Functor f => a -> f b -> f (a,b)
strength = fmap . (,)

class Zap f g | f -> g, g -> f where
  zapWith :: (a -> b -> c) -> f a -> g b -> c
  zap :: f (a -> b) -> g a -> b
  zap = zapWith id

zapWithAdjunctionGF :: Adjunction g f =>
    (a -> b -> c) -> f a -> g b -> c
zapWithAdjunctionGF f a b =
    uncurry (flip f) . counit . fmap (uncurry (flip strength)) $
    strength a b

zapWithAdjunctionFG :: Adjunction f g => (a -> b -> c) -> f a -> g b -> c

class (Zap f g, Zap g f, Representable g (f Void), Functor f) =>
    Adjunction f g | f -> g, g -> f where
        ...

newtype O f g a = Compose { decompose :: f (g a) }

instance (Functor f, Functor g) => Functor (f `O` g) where
        fmap f = Compose . fmap (fmap f) . decompose

instance (Adjunction f1 g1, Adjunction f2 g2) =>
    Adjunction (f2 `O` f1) (g1 `O` g2) where
        counit =
               counit .
               fmap (counit . fmap decompose) .
               decompose
        unit =
               Compose .
               fmap (fmap Compose . unit) .
               unit

instance (Adjunction f1 g1, Adjunction f2 g2) =>
    Zap (f2 `O` f1) (g1 `O` g2) where
        zapWith = zapWithAdjunctionFG
instance (Adjunction f1 g1, Adjunction f2 g2) =>
    Zap (g1 `O` g2) (f2 `O` f1) where
        zapWith = zapWithAdjunctionGF

instance (Zap f g, Zap h k) => Zap (f `O` h) (g `O` k) where
    zapWith f a b =
        zapWith (zapWith f) (decompose a) (decompose b)

prezapAdjunctionGF :: Adjunction g f => f a -> g b -> (a,b)
prezapAdjunctionGF a b =
    swap . counit . fmap (uncurry strength . swap) $ strength a b
    where swap ~(a,b) = (b,a)

eval :: (a -> b, a) -> b
eval (f,a) = f a

precozapAdjunctionFG ::
    (Adjunction f g, Traversable f, Traversable g) =>
    Either a b -> Either (f a) (g b)
precozapAdjunctionFG =
    costrength . fmap (swap . costrength) . unit . swap

type Dinatural f g = forall a. f a a -> g a a

newtype Const x a b = Const { runConst :: x }

Dinatural (Const x) s ~ forall a. Const x a a -> s a a

type DinaturalFromObject x s = x -> forall a. s a a

type End s = forall a. s a a

type DinaturalFromObject x s = x -> End s

newtype HomFG f g a b =
  HomFG { runHomFG :: f a -> g b }

type Nat f g = End (HomFG f g) -- forall a. f a -> g a

newtype RanT k t c m m' = (c -> k m) -> t m'
type Ran k t c = End (RanT k t c)

newtype Ran f g c = Ran { runRan :: forall m. (c -> f m) -> g m }

type DinaturalToObject s c = forall a. (s a a -> c)

(forall a. s a a -> c) ~ (exists a. s a a) -> c

data Coend f = forall a. Coend (f a a)

data LanT k t c m m' = LanT (k m -> c) (t m')
type Lan k t c = Coend (LanT k t c)

data Lan k t c = forall m. Lan (k m -> c) (t m)

class (Functor f, Functor g) =>
  Adjunction f g | f -> g, g -> f where
    unit   :: a -> g (f a)
    counit :: f (g a) -> a
    leftAdjunct  :: (f a -> b) -> a -> g b
    rightAdjunct :: (a -> g b) -> f a -> b

    unit = leftAdjunct id
    counit = rightAdjunct id
    leftAdjunct f = fmap f . unit
    rightAdjunct f = counit . fmap f

curry :: ((a, b) -> c) -> a -> b -> c
curry f x y = f (x,y)

uncurry :: (a -> b -> c) -> (a, b) -> c
uncurry f ~(x,y) = f x y

instance Adjunction ((,)e) ((->)e) where
  leftAdjunct f a e  = f (e,a)
  rightAdjunct f ~(e,a) = f a e

a -> e -> b
(a , e) -> b
(e , a) -> b

newtype O f g a = Compose { decompose :: f (g a) }
instance (Functor f, Functor g) => Functor (f `O` g) where
  fmap f = Compose . fmap (fmap f) . decompose

instance Adjunction f g => Monad (g `O` f) where
  return = Compose . unit
  m >>= f =
    Compose . fmap (rightAdjunct (decompose . f)) $ decompose m

class Comonad w where
  extract :: w a -> a
  duplicate :: w a -> w (w a)
  extend :: (w a -> b) -> w a -> w b
  extend f = fmap f . duplicate
  duplicate = extend id

instance Adjunction f g => Comonad (f `O` g) where
  extract = counit . decompose
  extend f =
    Compose . fmap (leftAdjunct (f . Compose)) . decompose

instance (Adjunction f1 g1, Adjunction f2 g2) =>
  Adjunction (f2 `O` f1) (g1 `O` g2) where
    counit =
      counit . fmap (counit . fmap decompose) . decompose
    unit =
      Compose . fmap (fmap Compose . unit) . unit

instance MonadState e ((->)e `O` (,)e) where
  get = compose $ \s -> (s,s)
  put s = compose $ const (s,())

class Comonad w =>
  ComonadContext s w | w -> s where
    getC :: w a -> s
    modifyC :: (s -> s) -> w a -> a

instance ComonadContext e ((,)e `O` (->)e) where
  getC = fst . decompose
  modifyC f = uncurry (flip id . f) . decompose

newtype Ran g h a = Ran
  { runRan :: forall b. (a -> g b) -> h b }
data Lan g h a = forall b. Lan (g b -> a) (h b)

adjointToRan :: Adjunction f g => f a -> Ran g Identity a
adjointToRan f = Ran (\a -> Identity $ rightAdjunct a f)

ranToAdjoint :: Adjunction f g => Ran g Identity a -> f a
ranToAdjoint r = runIdentity (runRan r unit)

adjointToLan :: Adjunction f g => g a -> Lan f Identity a
adjointToLan = Lan counit . Identity

lanToAdjoint :: Adjunction f g => Lan f Identity a -> g a
lanToAdjoint (Lan f v) = leftAdjunct f (runIdentity v)

ranToComposedAdjoint
  :: Adjunction f g
  => Ran g h a -> (h `O` f) a
ranToComposedAdjoint r = Compose (runRan r unit)

composedAdjointToRan
  :: (Functor h, Adjunction f g)
  => (h `O` f) a -> Ran g h a
composedAdjointToRan f =
  Ran (\a -> fmap (rightAdjunct a) (decompose f))

lanToComposedAdjoint
  :: (Functor h, Adjunction f g)
  => Lan f h a -> (h `O` g) a
lanToComposedAdjoint (Lan f v) =
  Compose (fmap (leftAdjunct f) v)

composedAdjointToLan
  :: Adjunction f g
  => (h `O` g) a -> Lan f h a
composedAdjointToLan = Lan counit . decompose

composeRan :: Ran f (Ran g h) a -> Ran (f `O` g) h a
composeRan r =
  Ran (\f -> runRan (runRan r (decompose . f)) id)

decomposeRan
  :: Functor f
  => Ran (f `O` g) h a -> Ran f (Ran g h) a
decomposeRan r =
  Ran (\f -> Ran (\g -> runRan r (Compose . fmap g . f)))

composeLan
  :: Functor f
  => Lan f (Lan g h) a -> Lan (f `O` g) h a
composeLan (Lan f (Lan g h)) =
  Lan (f . fmap g . decompose) h

decomposeLan :: Lan (f `O` g) h a -> Lan f (Lan g h) a
decomposeLan (Lan f h) = Lan (f . compose) (Lan id h)

liftRan :: Monad m => m a -> Ran m m a
liftRan m = Ran (m >>=)

lowerRan :: Monad m => Ran m m a -> m a
lowerRan a = runRan a return

instance MonadReader r m =>
  MonadReader r (Ran m m) where
    ask = liftRan ask
    local f m = Ran (\c -> ask >>=
        \r -> local f (runRan m (local (const r) . c)))

instance MonadIO m =>
  MonadIO (Ran m m) where
    liftIO = liftRan . liftIO

instance MonadState s m =>
  MonadState s (Ran m m) where
    get = liftRan get
    put = liftRan . put

newtype Ran g h a = Ran
  { runRan :: forall b. (a -> g b) -> h b }

newtype ContT r m a = ContT
  { runContT :: (a -> m r) -> m r }

instance Functor (Ran g h) where
  fmap f m = Ran (\k -> runRan m (k . f))

instance Monad (Ran f f) where
  return x = Ran (\k -> k x)
  m >>= k = Ran (\c -> runRan m (\a -> runRan (k a) c))

newtype C m a = C (forall b. (a -> m b) -> m b)

check :: Functor f => f a -> (forall b . (a -> b) -> f b)
check a f = fmap f a

uncheck :: (forall b . (a -> b) -> f b) -> f a
uncheck t = t id

type Yoneda = Ran Identity

check' :: Functor f => f a -> Yoneda f a
check' a = Ran (\f -> fmap (runIdentity . f) a)

uncheck' :: Yoneda f a -> f a
uncheck' t = runRan t Identity

data Trivial a = Trivial
instance Functor Trivial where
  fmap f _ = Trivial
trivialize :: a -> Trivial b
trivialize _ = Trivial

type Lim = Ran Trivial

Lim f a ~ forall b. (a -> Trivial b) -> f b

data Lan g h a = forall b. Lan (g b -> a) (h b)

newtype ContextT s w a = ContextT
  { runContextT :: (w s -> a, w s) }

instance Functor (Lan f g) where
  fmap f (Lan g h) = Lan (f . g) h

instance Comonad (Lan f f) where
  extract (Lan f a) = f a
  duplicate (Lan f ws) = Lan (Lan f) ws

type Colim = Lan Trivial

Folds
Scheme	Code	Description
catamorphism†	Cata	tears down a structure level by level
paramorphism*†	Para	tears down a structure with primitive recursion
zygomorphism*†	Zygo	tears down a structure with the aid of a helper function
histomorphism†	Histo	tears down a structure with the aid of the previous answers it has given.
prepromorphism*†	Prepro	tears down a structure after repeatedly applying a natural transformation
Unfolds
Scheme	Code	Description
anamorphism†	Ana	builds up a structure level by level
apomorphism*†	Apo	builds up a structure opting to return a single level or an entire branch at each point
futumorphism†	Futu	builds up a structure multiple levels at a time
postpromorphism*†	Postpro	builds up a structure and repeatedly transforms it with a natural transformation
Refolds
Scheme	Code	Description
hylomorphism†	Hylo	builds up and tears down a virtual structure
chronomorphism†	Chrono	builds up a virtual structure with a futumorphism and tears it down with a histomorphism
synchromorphism	Synchro	a high level transformation between data structures using a third data structure to queue intermediate results
exomorphism	Exo	a high level transformation between data structures from a trialgebra to a bialgebraga
metamorphism	Erwig	a hylomorphism expressed in terms of bialgebras
metamorphism	Gibbons	A fold followed by an unfold; change of representation
dynamorphism†	Dyna	builds up a virtual structure with an anamorphism and tears it down with a histomorphism
Elgot algebra	Elgot	builds up a structure and tears it down but may shortcircuit the process during construction
Elgot coalgebra	Elgot	builds up a structure and tears it down but may shortcircuit the process during deconstruction

Rule	Haskell
cata-cancel	cata phi . InF = phi . fmap (cata phi)
cata-refl	cata InF = id
cata-fusion	f . phi = phi . fmap f => f . cata phi = cata phi
cata-compose	eps :: forall x. f x -> g x => cata phi . cata (In . eps) = cata (phi . eps)

The Comonad.Reader

Live Coding — Session 26

Internalized Guarded Recursion for Equational Reasoning

Across the Kmettverse

Materials

The current state of the Haskell Foundation

Programming with Tactics

A Taste of Linear Optics

Cadenza: Building Fast Functional Languages Fast

Materials

Guanxi: Logic Programming in Haskell — Part 4 of 4

Materials

Guanxi: Logic Programming in Haskell — Part 3 of 4

Materials

Guanxi: Logic Programming in Haskell — Part 2 of 4

Materials

Guanxi: Logic Programming in Haskell — Part 1 of 4

Materials

Live Coding — Session 25: Guanxi Review

Live Coding — Session 24: Dancing with Decision Diagrams

Live Coding — Session 23: Dancing Links, Part 2

Live Coding — Session 22: Dancing Links

Live Coding — Session 21: Relational Programming, Part 6

Materials

Live Coding — Session 20: Relational Programming, Part 5

Live Coding — Session 19: Relational Programming, Part 4 (Soul of a New Machine)

Live Coding — Session 17: Relational Programming, Part 3

Materials

Live Coding — Session 18: Nominal Sets

Materials

Live Coding — Session 16: Relational Programming, Part 2

Live Coding — Session 15: Back from ICFP

Materials

There and Back Again: Regular and Inverse Semigroups

Materials

Live Coding — Session 14.3: Succinct Serialization, Part 6

Live Coding — Session 14.2: Succinct Serialization, Part 6

Live Coding — Session 14.1: Succinct Serialization, Part 6

Live Coding — Session 13: Succinct Serialization, Part 5

Live Coding — Session 12: Succinct Serialization, Part 4

Live Coding — Session 11: Succinct Serialization, Part 3

Live Coding — Session 10: Succinct Serialization, Part 2

Live Coding — Session 9: Succinct Serialization, Part 1

Live Coding — Session 7: More Machines

Live Coding — Session 8: Succinct Data Structures and Dynamization

Live Coding — Session 6: CEK Machines

Materials

Live Coding — Session 5.2: Propagators

Live Coding — Session 5.1: Propagators

Live Coding — Session 4.2: Q&A

Live Coding — Session 4.1: Regular and Inverse Semigroups

Live Coding — Session 3: Authenticated Computation

Materials

Combinators Revisited

Materials

Combinators Revisited

Materials

Live Coding — Session 2.2: Q&A

Live Coding — Session 2.1: Q&A

Live Coding — Session 1: Commutativity

Materials

Computational Quadrinitarianism (Curious Correspondences go Cubical)

1. Categories

2. Spaces, Logics

3. Spaces, Categories

4. Spaces, Programming Languages

5. Spaces, Categories

The State Comonad

A Walk-through of Computational Reflection in Coq

Monoidal Parsing

Algebraic Databases

Introduction to Cryptocurrencies in Haskell

SMT for DSLs: a Tutorial

Cracking Multi-Language Transformations

Efficiently coding for modern CPUs

Materials

VR: Test Framework

Desugaring Haskell’s do-Notation into Applicative Operations

Monad Transformer Lenses

Monad Homomorphisms