木の数え上げ

code:Tree.hs

module Tree where

import Data.Bool (bool)

import Data.List (genericIndex, genericTake, findIndex, scanl')

import Data.List.NonEmpty (NonEmpty(..))

import Numeric.Natural

import Control.Comonad.Cofree (Cofree(..))

import Data.Functor.Foldable

import Data.Functor.Base hiding (head, tail)

木の定義

ここで扱う木は以下のように定義した全二分木です．以降この記事では単に木と呼ぶことにします．

（コンテナではなく構造だけであることに注意してください）

code:Tree.hs

data Tree

= Leaf

| Tree :^: Tree

deriving (Eq, Show)

定義に再帰的な構造があるので，再帰スキームを入れておきましょう．

code:Tree.hs

data TreeF r

= LeafF

| r :^^: r

deriving (Eq, Show)

instance Functor TreeF where

fmap f = \ case

LeafF -> LeafF

x :^^: y -> f x :^^: f y

type instance Base Tree = TreeF

instance Recursive Tree where

project = \ case

Leaf -> LeafF

s :^: t -> s :^^: t

instance Corecursive Tree where

embed = \ case

LeafF -> Leaf

s :^^: t -> s :^: t

木の構成

code:Tree.hs

{- -- 後で改良

trees = \ case

-- -}

code:Tree.hs

splits = (zip <*> reverse) . enumFromTo 0

全ての木を列挙する

code:Tree.hs

toIndex :: Tree -> Natural

toIndex = head . flip genericFindIndices allTrees . (==)

列挙ができたので，すべての木に自然数を付与できます．

code:Tree.hs

{- -- 後で改良

toIndex :: Tree -> Natural

toIndex = head . flip genericFindIndices allTrees . (==)

where

fromIndex :: Natural -> Tree

fromIndex = genericIndex allTrees

-- -}

木を数える

すべての木を列挙しているので，その構成方法から考えることができます．数える方も木に含まれる分岐の数をパラメータとしましょう．

code:Tree.hs

{- -- 次で変更

countTrees :: Natural -> Natural

countTrees = \ case

0 -> 1

-- -}

code:Tree.hs

{- -- 後で改良

countTrees :: Natural -> Natural

countTrees = count . downFrom

downFrom = \ case

n+1 -> enumFromThen (n+1) n

count = \ case

_:[] -> 1

_:xs@(_:_) -> sum $ zipWith (*) <*> reverse $ map countTrees xs

-- -}

code:Tree.hs

countTrees :: Natural -> Natural

countTrees = count . downFrom

downFrom :: Natural -> NonEmpty Natural

downFrom = ana psi

where

psi :: Natural -> NonEmptyF Natural Natural

psi = \ case

0 -> NonEmptyF 0 Nothing

n+1 -> NonEmptyF (n+1) (Just n)

count :: NonEmpty Natural -> Natural

count = histo phi

where

phi :: NonEmptyF Natural (Cofree (NonEmptyF Natural) Natural) -> Natural

phi = \ case

NonEmptyF 0 _ -> 1

NonEmptyF n (Just ns) -> sum $ zipWith (*) <*> reverse $ xs

where

xs = taking n ns

taking = \ case

0 -> const []

n+1 -> \ case

x :< NonEmptyF _ (Just xs) -> x : taking n xs

木の構成（改良）

code:Tree.hs

trees = mkTrees . downFrom

mkTrees = histo phi

where

phi = \ case

NonEmptyF n (Just ns) -> concat $ zipWith (*^*) (reverse xs) xs

where

xs = taking n ns

ss *^* ts = (:^:) <$> ss <*> ts

Catalan数

$ C_0 = 1

$ C_{n+1} = \sum_{i=0}^{n}C_i C_{n-i}

$ C_n = \frac{(2n)!}{(n+1)!n!}

code:Tree.hs

catalan :: Natural -> Natural

catalan = \ case

0 -> 1

where

dwnprd a m n | m < n = a

| otherwise = dwnprd (a*m) (pred m) n

また，

$ C_{n+1} = \frac{2(2n+1)}{n+2}C_n

なので，カタラン数列は以下のように構成できます．

code:Tree.hs

where

木のインデックス付け

すべての木を列挙するときの方法から考えて，分岐数と，その分岐数の木のなかでの順番との対でインデックスを付けるのが自然です．まずこの方法で木にインデックスを付けてみましょう．

code:Tree.hs

toLocalIndex :: Tree -> (Natural, Natural)

toLocalIndex = cata phi

where

phi :: TreeF (Natural, Natural) -> (Natural, Natural)

phi = \ case

LeafF -> (0, 0)

(m,i) :^^: (n,j) -> (o, k)

where

o = succ (m + n)

k = acc 0 m 0 (m + n) + i * catalan n + j

acc a 0 _ _ = a

acc a p q r = acc (a + catalan q * catalan (r - q)) (pred p) (succ q) r

code:Tree.hs

toIndex :: Tree -> Natural

toIndex = l2g . toLocalIndex

where

l2g = \ case

(0,_) -> 0

(o,k) -> genericIndex accCatalans o + k

accCatalans = scanl' (+) 0 catalans

つぎにインデックスから木を再現する方法を改良しましょう．

code:Tree.hs

fromLocalIndex :: (Natural, Natural) -> Tree

fromLocalIndex = ana psi

where

psi = \ case

(0, _) -> LeafF

(o, k) -> (m, i) :^^: (n, j)

where

cs = accDeconCatalans o

m = spanCount (<= k) cs

n = pred o - m

cn = catalan n

k' = k - genericIndex cs (pred m)

j = bool (bool (k' - cn * i) k (m == 0)) 0 (n < 2)

accDeconCatalans = scanl1 (+) . deconCatalan

deconCatalan = (zipWith (*) <*> reverse) . flip genericTake catalans

spanCount p = cata phi

where

phi = \ case

Nil -> 0

Cons x c -> bool 0 (succ c) (p x)

code:Tree.hs

fromIndex :: Natural -> Tree

fromIndex = fromLocalIndex . g2l

where

g2l = \ case

0 -> (0, 0)

m@(n+1) -> (o, k)

where

o = pred (spanCount (<= m) accCatalans)

k = m - genericIndex accCatalans o