摘录的一篇故关于RecursionSchemes函数式编程的内容

Recursion Schemes

Fixed Point 不动点

1
newtype Term f = In { out:: f (Term f) } -- Fixed Point

Generic Traversals 泛化遍历

Bottom to Up

To traverse a Term down-top with a function ƒ, we:

  1. Unpack the term so as to access its children.
  2. Recursively traverse each child of the unpacked term with ƒ.
  3. Repack the term.
  4. Apply ƒ to it

Up to Bottom

To traverse a Term top-down with a function ƒ, we:

  1. Apply ƒ to the term.
  2. Unpack the term so as to access its children.
  3. Recursively traverse each child of the term with ƒ.
  4. Repack the term.

Code

1
2
3
4
5
topDown, bottomUp :: Functor f => (Term f -> Term f) -> Term f -> Term f

topDown f  = In <<< fmap (topDown f) <<< out <<< f

bottomUp f = out >>> fmap (bottomUp f) >>> In >>> f

Catamorphism && Anamorphism

Algebra

Indeed, functions of type f a -> a are so ubiquitous that we refer to them by their own name:

1
type Algebra f a = f a

Catamorphism

1
2
cata :: (Functor f) => Algebra f a -> Term f -> a
cata f = out >>> fmap (cata f) >>> f

Bottom To Up with Catamorphism

1
bottomUp f = cata (In >>> f)

Coalgebra

Reverse of the algebra

1
type Coalgebra f a = a -> f a

Anamorphism

1
2
ana :: (Functor f) => Coalgebra f a -> a -> Term f  
ana f = In <<< fmap (ana f) <<< f

Paramorphism && Apomorphism

R-algebra

1
type RAlgebra f a = f (Term f, a) -> a

Paramorphism

1
2
3
4
5
6
7
8
para :: (Functor f) => RAlgebra f a -> Term f -> a  
para rAlg = out >>> fmap fanout >>> rAlg  
    where fanout :: Term f -> (Term f, a)
          fanout t = (t, para rAlg t)

-- With Control.Arrow
para' :: Functor f => RAlgebra f a -> Term f -> a  
para' f = out >>> fmap (id &&& para' f) >>> f

Paramorphism Version 2

1
2
3
4
type RAlgebra' f a = Term f -> f a -> a

para'' :: Functor f => RAlgebra' f a -> Term f -> a  
para'' alg t = out t & fmap (para'' alg) & alg t

Catamorphism with Paramorphism

1
2
cata' :: Functor f => Algebra f a -> Term f -> a  
cata' f = para'' (const f)

R-Coalgebra

1
type RCoalgebra f a = a -> f (Either (Term f) a)

Apomorphism

1
2
apo :: Functor f => RCoalgebra f a -> a -> Term f  
apo f = In <<< fmap (id ||| apo f) <<< f

Histomorphism && Futumorphism

Brand New Term - Attribute

1
2
3
4
data Attr f a = Attr  
              { attribute :: a
              , hole      :: f (Attr f a)
              }

CV-Algebra

1
type CVAlgebra f a = f (Attr f a) -> a

Histomorphism

1
2
3
4
histo :: Functor f => CVAlgebra f a -> Term f -> a  
histo h = worker >>> attribute where  
  worker = out >>> fmap worker >>> (h &&& id) >>> mkAttr
  mkAttr (a, b) = Attr a b

Example - Change Making Problem

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
type Cent = Int

coins :: [Cent]
coins = [50, 25, 10, 5, 1]

data Nat a
    = Zero
    | Next a
    deriving Functor

-- Convert from a natural number to its foldable equivalent, and vice versa.
expand :: Int -> Term Nat
expand 0 = In Zero
expand n = In (Next (expand (n - 1)))

compress :: Nat (Attr Nat a) -> Int
compress Zero              = 0
compress (Next (Attr _ x)) = 1 + compress x

change :: Cent -> Int
change amt = histo go (expand amt) where
  go :: Nat (Attr Nat Int) -> Int
  go Zero = 1
  go curr@(Next attr) = let
    given               = compress curr
    validCoins          = filter (<= given) coins
    remaining           = map (given -) validCoins
    (zeroes, toProcess) = partition (== 0) remaining
    results             = sum (map (lookup attr) toProcess)
    in length zeroes + results

lookup :: Attr Nat a -> Int -> a
lookup cache 0 = attribute cache
lookup cache n = lookup inner (n - 1) where (Next inner) = hole cache

Catamorphism with Histomorphism

1
2
cata :: Functor f => Algebra f a -> Term f -> a  
cata f = histo (fmap attribute >>> f)

Paramorphism with Histomorphism

1
2
3
para :: Functor f => RAlgebra f a -> Term f -> a  
para f = histo (fmap worker >>> f) where  
  worker (Attr a h) = (In (fmap (worker >>> fst) h), a)

Co-Attribute

1
2
3
data CoAttr f a
  = Automatic a
  | Manual (f (CoAttr f a))

CV-Co-Algebra

1
type CVCoalgebra f a = a -> f (CoAttr f a)

Futumorphism

1
2
3
4
futu :: Functor f => CVCoalgebra f a -> a -> Term f
futu f = In <<< fmap worker <<< f where
    worker (Automatic a) = futu f a
    worker (Manual g) = In (fmap worker g)

Anamorphism and Apomorphism With Futumorphism

1
2
3
4
5
6
ana :: (Functor f) => Coalgebra f a -> a -> Term f
ana f = futu (fmap Automatic <<< f)

apo :: Functor f => RCoalgebra f a -> a -> Term f
apo f = futu (fmap (either termToCoattr Automatic) <<< f)
  where termToCoattr = Manual <<< fmap termToCoattr <<< out

Co-Monad

Co-Attribute === Free Monad

1
2
3
data Free f a
    = Pure a
    | Impure (f (Free f a))

Attribute === Cofree comonad

1
data Cofree f a = a :< (f (Cofree f a))

Hylomorphism && Chronomorphism

Hylomorphism

1
2
hylo :: Functor f => Algebra f b -> Coalgebra f a -> a -> b
hylo alg coalg = ana coalg >>> cata alg

Better Hylomorphism

1
2
hylo' :: Functor f => Algebra f b -> Coalgebra f a -> a -> b
hylo' alg coalg = coalg >>> fmap (hylo' alg coalg) >>> alg

Elgot Algebra

1
elgot :: Functor f => Algebra f b -> (a -> Either b (f a)) -> a -> b
1
2
elgot :: Functor f => Algebra f b -> (a -> Either b (f a)) -> a -> b
elgot alg coalg = coalg >>> (id ||| (fmap (elgot alg coalg) >>> alg))
1
2
coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot alg coalg = alg <<< (id &&& (fmap (coelgot alg coalg) <<< coalg))
1
2
hypo :: Functor f => RAlgebra f b -> RCoalgebra f a -> a -> b
hypo ralg rcoalg = apo rcoalg >>> para ralg