public
Created

Composing algebras using Arrow and Applicative.

  • Download Gist
g1.hs
Haskell
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)))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.