Aplopegmorphism.hs

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}

module Alopegmorphism where

import           Data.Void

type Triple = I :*: I :*: I

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

pattern Tr a b c = (I a :*: I b) :*: I c

type Row = Triple :.: Triple

type Grid = Matrix Value

type Matrix = Row :.: Row

type Value = Char

type Choices = [Value]


unfoldr :: (seed -> Maybe (value, seed)) -> seed -> [value]
unfoldr coalg s = case coalg s of
  Nothing      -> []
  Just (v, s') -> v : unfoldr coalg s'

growList :: ([value] -> Maybe value) -> [value]
growList g = unfoldr coalg []
 where
  coalg vz = case g vz of
    Nothing -> Nothing
    Just v  -> Just (v, v : vz) -- I say "vz", not "vs" to remember it's reversed

ps = growList $ \pz -> Just (sum (zipWith (*) sigmas pz) `div` (length pz + 1))

sigmas = [ sigma j | j <- [1 ..] ]

sigma = undefined

newtype Nu f =
  In (f (Nu f))

ana :: Functor f => (seed -> f seed) -> seed -> Nu f
ana coalg s = In (fmap (ana coalg) (coalg s))

newtype K1 a x =
  K1 a -- constants (labels)
  deriving Show

newtype I x =
  I x -- substructure places
  deriving Show

data (f :+: g) x
  = L1 (f x)
  | R1 (g x) -- choice (like Either)
  deriving Show

data (f :*: g) x =
  f x :*: g x -- pairing (like (,))
  deriving Show

newtype (f :.: g) x = C {unC :: f (g x)}  deriving Show

instance Functor (K1 a) where
  fmap f (K1 a) = K1 a

instance Functor I where
  fmap f (I s) = I (f s)

instance (Functor f, Functor g) => Functor (f :+: g) where
  fmap h (L1 fs) = L1 (fmap h fs)
  fmap h (R1 gs) = R1 (fmap h gs)

instance (Functor f, Functor g) => Functor (f :*: g) where
  fmap h (fx :*: gx) = fmap h fx :*: fmap h gx

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

type ListF value = K1 () :+: (K1 value :*: I)

-- seed -> (K1 () :+: (K1 value :*: I)) seed
list :: Nu (ListF a) -> [a]
list (In (L1 _              )) = []
list (In (R1 (K1 a :*: I as))) = a : list as

class Bifunctor b where
  bimap :: (c -> c') -> (j -> j') -> b c j -> b c' j'

newtype K2 a c j =
  K2 a

data (f :++: g) c j
  = L2 (f c j)
  | R2 (g c j)

data (f :**: g) c j =
  f c j :**: g c j

newtype Clowns f c j =
  Clowns (f c)

newtype Jokers f c j =
  Jokers (f j)

instance Bifunctor (K2 a) where
  bimap h k (K2 a) = K2 a

instance (Bifunctor f, Bifunctor g) => Bifunctor (f :++: g) where
  bimap h k (L2 fcj) = L2 (bimap h k fcj)
  bimap h k (R2 gcj) = R2 (bimap h k gcj)

instance (Bifunctor f, Bifunctor g) => Bifunctor (f :**: g) where
  bimap h k (fcj :**: gcj) = bimap h k fcj :**: bimap h k gcj

instance Functor f => Bifunctor (Clowns f) where
  bimap h k (Clowns fc) = Clowns (fmap h fc)

instance Functor f => Bifunctor (Jokers f) where
  bimap h k (Jokers fj) = Jokers (fmap k fj)

class (Functor f, Bifunctor (Diss f)) =>
      Dissectable f
  where
  type Diss f :: * -> * -> *
  rightward :: Either (f j) (Diss f c j, c) -> Either (j, Diss f c j) (f c)

instance Dissectable (K1 a) where
  type Diss (K1 a) = K2 Void
  rightward (Left  (K1 a)   ) = Right (K1 a)
  rightward (Right (K2 v, _)) = absurd v

instance Dissectable I where
  type Diss I = K2 ()
  rightward (Left  (I j)     ) = Left (j, K2 ())
  rightward (Right (K2 (), c)) = Right (I c)

instance (Dissectable f, Dissectable g) => Dissectable (f :*: g) where
  type Diss (f :*: g) = (Diss f :**: Jokers g) :++: (Clowns f :**: Diss g)
  rightward x = case x of
    Left (fj :*: gj) -> ll (rightward (Left fj)) gj
    Right (L2 (df :**: Jokers gj), c) -> ll (rightward (Right (df, c))) gj
    Right (R2 (Clowns fc :**: dg), c) -> rr fc (rightward (Right (dg, c)))
   where
    ll (Left  (j, df)) gj = Left (j, L2 (df :**: Jokers gj))
    ll (Right fc     ) gj = rr fc (rightward (Left gj)) -- (!)
    rr fc (Left  (j, dg)) = Left (j, R2 (Clowns fc :**: dg))
    rr fc (Right gc     ) = Right (fc :*: gc)

--rightward :: Either (f x) (Diss f Void x, Void) -> Either (x, Diss f Void x) (f Void)
type Quotient f x = Diss f Void x

leftmost :: Dissectable f => f x -> Either (x, Quotient f x) (f Void)
leftmost = rightward . Left

type Fox f x = Diss f x ()

grow :: Dissectable f => ([Fox f (Nu f)] -> f ()) -> Nu f
grow g = go []
 where
  go stk = In (walk (rightward (Left (g stk))))
   where
    walk (Left  ((), df)) = walk (rightward (Right (df, go (df : stk))))
    walk (Right fm      ) = fm


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"))