Функтор Haskell для красно-черного дерева

instance Functor (Rbtree c) where
  fmap = fmap_even where
     fmap_even _ EmptyTree = EmptyTree
     fmap_even f (Node x left right) = Node x (fmap_odd f left) (fmap_odd f right)
     fmap_odd  _ EmptyTree = EmptyTree
     fmap_odd  f (Node x left right) = Node (f x) (fmap_even f left) (fmap_even f right)

Ваше определение дерева RB не имеет для меня особого смысла, но на случай, если мне что-то не хватает, вот экземпляр Functor, совместимый с ним.

Вы можете сделать свой Rbtree a Bifunctor (см. bifunctors package) следующим образом:

import Data.Bifunctor

data Rbtree a1 b1 = EmptyTree | Node a1 (Rbtree b1 a1) (Rbtree b1 a1)

instance Bifunctor Rbtree where
  bimap _ _ EmptyTree = EmptyTree
  bimap f g (Node x l r) = Node (f x) (bimap g f l) (bimap g f r)

В этом экземпляре у вас теперь есть функции first и second для сопоставления красных или черных узлов (second ~ fmap). Фактически вы можете определить экземпляр Functor следующим образом:

instance Functor (Rbtree c) where
  fmap = second

Пример

>>> let t = Node 1 (Node "hello" EmptyTree EmptyTree) EmptyTree
>>> bimap show length t
Node "1" (Node 5 EmptyTree EmptyTree) EmptyTree
>>> fmap length t
Node 1 (Node 5 EmptyTree EmptyTree) EmptyTree
>>> first show t
Node "1" (Node "hello" EmptyTree EmptyTree) EmptyTree

Вы можете принудительно применить все красно-черные инварианты дерева с помощью GADT и некоторые виды хакерства (количественная оценка существования, арифметика типов, типы данных). Свойства:

1. Узел бывает либо красным, либо черным.
2. Корень черный.
3. Все листья (NIL) черные.
4. Каждый красный узел должен иметь два черных дочерних узла.
5. Каждый путь от данного узла к любому из его дочерних листьев содержит одинаковое количество черных узлов.

А вот пример кода:

{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification,
             KindSignatures, DataKinds #-}

data Nat = Zero | Succ Nat
data Color = Red | Black

data Node :: Color -> Nat -> * -> * where
    Nil :: Node Black Zero a
    RedNode :: a -> Node Black n a -> Node Black n a -> Node Red n a
    BlackNode :: a -> Node c1 n a -> Node c2 n a -> Node Black (Succ n) a

data RBTree a = forall n. RBTree (Node Black n a)

deriving instance (Show a) => Show (Node c n a)
deriving instance (Show a) => Show (RBTree a)

instance Functor (Node c n) where
    fmap f Nil = Nil
    fmap f (RedNode   x l r) = RedNode   (f x) (fmap f l) (fmap f r)
    fmap f (BlackNode x l r) = BlackNode (f x) (fmap f l) (fmap f r)

instance Functor RBTree where
    fmap f (RBTree t) = RBTree (fmap f t)

Вы можете использовать это так:

tree = RBTree $ BlackNode 3 (RedNode 4 Nil Nil) (RedNode 5 Nil Nil)
main = print $ fmap (*5) tree

Результат:

RBTree (BlackNode 15 (RedNode 20 Nil Nil) (RedNode 25 Nil Nil))

Но это не скомпилируется:

tree = RBTree $ BlackNode 3 (RedNode 4 Nil Nil) (BlackNode 5 Nil Nil)

Вы получите красивое сообщение об ошибке:

Couldn't match type `Succ Zero' with `Zero'
Expected type: Node Black Zero a0
  Actual type: Node Black (Succ Zero) a0
In the return type of a call of `BlackNode'
In the third argument of `BlackNode', namely
  `(BlackNode 5 Nil Nil)'
In the second argument of `($)', namely
  `BlackNode 3 (RedNode 4 Nil Nil) (BlackNode 5 Nil Nil)'