Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

Composing algebras using Arrow and Applicative.

View g1.hs
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
{-# LANGUAGE GADTs, TypeOperators, TupleSections #-}
module Generics.Algebra where
 
import Control.Category
import Control.Arrow
import Control.Applicative
import Prelude hiding ((.), id)
 
import Generics.Combinator
 
-------------------------------------------------------------------------------
 
-- | Generic algebra type.
 
type Alg i -- ^ An additional value used for algebra composition.
f -- ^ The recursive functor to decompose into a result.
a -- ^ Additional input for the algebra.
b -- ^ Result of running the algebra.
= a -> f (i, b) -> (i, b)
 
data Algebra f a b where
Algebra :: Alg i f a b -> Algebra f a b
 
algebra :: Functor f => (a -> f b -> b) -> Algebra f a b
algebra alg = Algebra (\a -> (,) () . alg a . fmap snd)
 
type Phi f b = Algebra f () b
 
phi :: Functor f => (f b -> b) -> Phi f b
phi f = algebra (const f)
 
-------------------------------------------------------------------------------
 
-- | Generic coalgebra type.
 
type Coalg f -- ^ The recursive functor to construct from a seed value.
a -- ^ Additional input for the coalgebra.
b -- ^ Type of the input seed.
= a -> b -> f b
 
data Coalgebra f a b where
Coalgebra :: Coalg f a b -> Coalgebra f a b
 
coalgebra :: Functor f => (a -> b -> f b) -> Coalgebra f a b
coalgebra coalg = Coalgebra coalg
 
type Psi f b = Coalgebra f () b
 
psi :: Functor f => (b -> f b) -> Psi f b
psi f = coalgebra (const f)
 
-------------------------------------------------------------------------------
 
instance Functor f => Category (Algebra f) where
id = Algebra (const . (,) ())
Algebra a . Algebra b = Algebra (compose a b)
 
instance Functor f => Functor (Algebra f a) where
fmap f (Algebra g) = Algebra (amap f g)
 
instance Functor f => Applicative (Algebra f a) where
pure = Algebra . const . const . (,) ()
Algebra f <*> Algebra g = Algebra (ap f g)
 
instance Functor f => Arrow (Algebra f) where
arr f = Algebra (const . (,) () . f)
first (Algebra f) = Algebra (\(b, d) -> second (, d) . f b . fmap (second fst))
 
instance Functor f => ArrowLoop (Algebra f) where
loop (Algebra f) = Algebra $ \b inp ->
let (i, (c, d)) = f (b, d) (second (, d) <$> inp) in (i, c)
 
compose :: Functor f => Alg j f b c -> Alg i f a b -> Alg (j, (i, b)) f a c
compose f g a input =
let (i, b) = g a (prj_g <$> input)
(j, c) = f b (prj_f <$> input)
in ((j, (i, b)), c)
where prj_f ((j, (_, _)), c) = (j, c)
prj_g ((_, (i, b)), _) = (i, b)
 
ap :: Functor f => Alg j f c (a -> b) -> Alg i f c a -> Alg ((i, a), (j, a -> b)) f c b
ap f g c input =
let (i, a ) = g c (prj_g <$> input)
(j, ab) = f c (prj_f <$> input)
in (((i, a), (j, ab)), ab a)
where prj_f (((_, _), (j, ab)), _) = (j, ab)
prj_g (((i, a), (_, _ )), _) = (i, a)
 
amap :: Functor f => (a -> b) -> Alg i f c a -> Alg (i, a) f c b
amap fn f c input =
let (i, a) = f c (prj <$> input)
in ((i, a), fn a)
where prj ((i, a), _) = (i, a)
 
-------------------------------------------------------------------------------
 
-- Running algebras.
 
para :: Functor f => Algebra f (a, Fix f) b -> a -> Fix f -> b
para (Algebra alg) a = snd . recurse
where recurse g = alg (a, g) (recurse <$> out g)
 
cata :: Functor f => Algebra f a b -> a -> Fix f -> b
cata (Algebra alg) a = para (Algebra alg . arr fst) a
 
-- Like para but without an additional input.
 
para1 :: Functor f => Algebra f (Fix f) b -> Fix f -> b
para1 alg = para (alg . arr snd) ()
 
-- Running coalgebras.
 
ana :: Functor f => Coalgebra f a b -> a -> b -> Fix f
ana (Coalgebra coalg) a = In . fmap (ana (Coalgebra coalg) a) . coalg a
 
-- Lifting algebras to annotated structures.
 
lift :: Copointed n => Algebra f a b -> Algebra (n / f) a b
lift (Algebra alg) = Algebra (\n -> alg n . copoint . deC)
 
liftEndo :: (Copointed n, Functor n) => Algebra f (f r -> r) s -> Algebra (n / f) ((n / f) r -> r) s
liftEndo (Algebra alg) = Algebra (\en inp -> alg (\i -> en (mapC (const i) inp)) (copoint (deC inp)))
 
endoish :: (Copointed n, Functor n) => Algebra f (f r -> r, a) s -> Algebra (n / f) ((n / f) r -> r, a) s
endoish (Algebra alg) = Algebra (\(en, a) inp -> alg (\i -> en (mapC (const i) inp), a) (copoint (deC inp)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.