Cojoingrids.hs

{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE PatternSynonyms #-}

module Cojoingrids where


-- https://stackoverflow.com/questions/12963733/writing-cojoin-or-cobind-for-n-dimensional-grid-type/13100857
-- 
data Bwd x
  = B0
  | Bwd x :< x
  deriving (Functor, Foldable, Traversable, Show)

data Fwd x
  = F0
  | x :> Fwd x
  deriving (Functor, Foldable, Traversable, Show)

infixl 5 :<

infixr 5 :>

data Cursor x =
  Cur (Bwd x) x (Fwd x)
  deriving (Functor, Foldable, Traversable, Show)

class Functor f =>
      Comonad f
  where
  counit :: f x -> x
  cojoin :: f x -> f (f x)

instance Comonad Cursor where
  counit (Cur _ x _) = x
  cojoin c = Cur (lefts c) c (rights c)
    where
      lefts (Cur B0 _ _) = B0
      lefts (Cur (xz :< x) y ys) = lefts c :< c
        where
          c = Cur xz x (y :> ys)
      rights (Cur _ _ F0) = F0
      rights (Cur xz x (y :> ys)) = c :> rights c
        where
          c = Cur (xz :< x) y ys

--type InContext f x = (x, ∂ f x)
newtype (:.:) f g x =
  C
    { unC :: f (g x)
    }
  deriving (Show)

-- transpose :: f (g x) -> g (f x)
instance Applicative Bwd where
  pure x = pure x :< x
  (fz :< f) <*> (sz :< s) = (fz <*> sz) :< f s
  _ <*> _ = B0

instance Applicative Fwd where
  pure x = x :> pure x
  (f :> fs) <*> (s :> ss) = f s :> (fs <*> ss)
  _ <*> _ = F0

instance Applicative Cursor where
  pure x = Cur (pure x) x (pure x)
  Cur fz f fs <*> Cur sz s ss = Cur (fz <*> sz) (f s) (fs <*> ss)

instance (Comonad f, Traversable f, Comonad g, Applicative g) =>
         Comonad (f :.: g) where
  counit = counit . counit . unC
  cojoin = C . fmap (fmap C . sequenceA) . cojoin . fmap cojoin . unC

instance (Functor f, Functor g) => Functor (f :.: g) where
  fmap h (C fgx) = C (fmap (fmap h) fgx)

instance (Applicative f, Applicative g) => Applicative (f :.: g) where
  pure = C . pure . pure
  C f <*> C s = C (pure (<*>) <*> f <*> s)

instance (Functor f, Foldable f, Foldable g) => Foldable (f :.: g)
  --fold = fold . fmap fold . unC
                                  where
  foldMap f (C t) = foldMap (foldMap f) t

instance (Traversable f, Traversable g) => Traversable (f :.: g) where
  traverse h (C fgx) = C <$> traverse (traverse h) fgx

data (:<|) s p x =
  s :<| (p -> x)

-- (s :<| p) :><: (s' :<| p')  =  (s, s') :<| (p, p')
class Applicative f =>
      Naperian f
  where
  type Log f
  project :: f x -> Log f -> x
  positions :: f (Log f) --- project positions = id

newtype Id x =
  Id
    { unId :: x
    }
  deriving (Show)

instance Functor Id where
  fmap f (Id x) = Id $ f x

instance Applicative Id where
  pure = Id
  (Id f) <*> (Id x) = Id (f x)

instance Naperian Id where
  type Log Id = ()
  project (Id x) () = x
  positions = Id ()

newtype (:*:) f g x =
  Pr (f x, g x)
  deriving (Show)

instance (Functor f, Functor g) => Functor (f :*: g) where
  fmap h (Pr (fa, ga)) = Pr (fmap h fa, fmap h ga)

instance (Applicative f, Applicative g) => Applicative (f :*: g) where
  pure a = Pr (pure a, pure a)
  Pr (fx, gx) <*> Pr (ax, bx) = Pr ((fx <*> ax), (gx <*> bx))

instance (Naperian f, Naperian g) => Naperian (f :*: g) where
  type Log (f :*: g) = Either (Log f) (Log g)
  project (Pr (fx, gx)) (Left p) = project fx p
  project (Pr (fx, gx)) (Right p) = project gx p
  positions = Pr (fmap Left positions, fmap Right positions)

instance (Naperian f, Naperian g) => Naperian (f :.: g) where
  type Log (f :.: g) = (Log f, Log g)
  project (C fgx) (p, q) = project (project fgx p) q
  positions = C $ fmap (\p -> fmap (p, ) positions) positions

data Focused f x =
  f x :@ Log f

instance Functor f => Functor (Focused f) where
  fmap h (fx :@ p) = fmap h fx :@ p

instance Naperian f => Comonad (Focused f) where
  counit (fx :@ p) = project fx p
  cojoin (fx :@ p) = fmap (fx :@) positions :@ p

regularMatrixCursor :: Cursor (Cursor Int)
regularMatrixCursor =
  Cur
    (B0 :< Cur (B0 :< 1) 2 (3 :> F0))
    (Cur (B0 :< 4) 5 (6 :> F0))
    (Cur (B0 :< 7) 8 (9 :> F0) :> F0)

raggedyMatrixCursor :: Cursor (Cursor Int)
raggedyMatrixCursor =
  Cur
    (B0 :< Cur ((B0 :< 1) :< 2) 3 F0)
    (Cur (B0 :< 4) 5 (6 :> F0))
    (Cur (B0 :< 7) 8 (9 :> F0) :> F0)

type Triple = Id :*: Id :*: Id

pattern Tr :: a -> a -> a -> (:*:) (Id :*: Id) Id a

pattern Tr a b c = Pr (Pr (Id a, Id b), Id c)

type Row = Triple :.: Triple

type Grid = Matrix Value

type Matrix = Row :.: Row

type Value = Char

type Choices = [Value]

zone :: Row Value
zone = C (Tr (Tr 'a' 'b' 'c') (Tr 'd' 'e' 'f') (Tr 'g' 'h' 'a'))

zone2 :: Row Choices
zone2 = C (Tr (Tr "12" "123" "9") (Tr "123" "5" "123") (Tr "7" "1234" "12"))