在Apomorphism中使用Paramorphism的Haskell实现问题

背景代码 #

先定义函子的不动点、Paramorphism与Apomorphism：

-- 函子的不动点
newtype Fix f = In (f (Fix f))

deriving instance (Eq (f (Fix f))) => Eq (Fix f)
deriving instance (Ord (f (Fix f))) => Ord (Fix f)
deriving instance (Show (f (Fix f))) => Show (Fix f)

out :: Fix f -> f (Fix f)
out (In f) = f

type RAlgebra f a = f (Fix f, a) -> a

para :: (Functor f) => RAlgebra f a -> Fix f -> a
para rAlg = rAlg . fmap fanout . out
        where fanout t = (t, para rAlg t)

-- Apomorphism
type RCoalgebra f a = a -> f (Either (Fix f) a)

apo :: Functor f => RCoalgebra f a -> a -> Fix f
apo rCoalg = In . fmap fanin . rCoalg
        where fanin = either id (apo rCoalg)

要实现的递归函数concat3逻辑如下（伪代码）：

fun concat3 (v,E,r) = add(r,v)
   | concat3 (v,l,E) = add(l,v)
   | concat3 (v, l as T(v1,n1,l1,r1), r as T(v2,n2,l2,r2)) =
       if weight*n1 < n2 then T’(v2,concat3(v,l,l2),r2)
       else if weight*n2 < n1 then T’(v1,l1,concat3(v,r1,r))
       else N(v,l,r)

该函数接收一个元素v（大于左树所有值、小于右树所有值）和两个二叉树，合并为新二叉树，类型为value -> tree1 -> tree2 -> tree3。

已用Paramorphism实现插入元素的add函数：

add :: Ord a => a -> RAlgebra (ATreeF a) (ATreeF' a)
add elem EmptyATreeF = In (NodeATreeF elem 1 (In EmptyATreeF) (In EmptyATreeF))
add elem (NodeATreeF cur _ (prevLeft, left) (prevRight, right))
        | elem < cur = bATreeConstruct cur left prevRight
        | elem > cur = bATreeConstruct cur prevLeft right
        | otherwise = nATreeConstruct cur prevLeft prevRight

遇到的类型错误 #

尝试将concat3定义为Apomorphism时：

concat3 :: Ord a => a -> RCoalgebra (ATreeF a) (ATreeF' a, ATreeF' a)                 
concat3 elem (In EmptyATreeF, In (NodeATreeF cur2 size2 left2 right2)) = 
     out para (insertATreeFSetPAlg elem) (In (NodeATreeF cur2 size2 (Left left2) (Left right2)))
     ...

编译器抛出类型不匹配错误：

Couldn't match type: Fix (ATreeF a)                                             
                     with: Either (Fix (ATreeF a)) (ATreeF' a, ATreeF' a)             
      Expected: ATreeF a (Either (Fix (ATreeF a)) (ATreeF' a, ATreeF' a))             
        Actual: ATreeF a (Fix (ATreeF a)) 

1. 修正Apomorphism的Coalgebra输出类型 #

错误核心是RCoalgebra要求返回f (Either (Fix f) a)，但当前代码直接返回了f (Fix f)。需将add的结果包装为Either结构，明确区分“直接使用的完整树”和“需要递归处理的子问题”：

-- 调整输入类型为Fix包装的树，避免类型混淆
concat3 :: Ord a => a -> RCoalgebra (ATreeF a) (Fix (ATreeF a), Fix (ATreeF a))
-- 左树为空：调用add得到结果后，拆为函子结构并将子节点用Left包装（无需递归）
concat3 elem (In EmptyATreeF, r) = 
    let addedTree = para (add elem) r
    in fmap Left (out addedTree)
-- 右树为空：同理处理
concat3 elem (l, In EmptyATreeF) = 
    let addedTree = para (add elem) l
    in fmap Left (out addedTree)

2. 处理双树非空的递归分支 #

对于两个树都非空的情况，根据大小判断递归方向：需要继续处理的子问题用Right包装（交给Apomorphism递归），无需处理的部分用Left直接复用现有节点：

concat3 elem (l@(In (NodeATreeF v1 n1 l1 r1)), r@(In (NodeATreeF v2 n2 l2 r2)))
    | weight * n1 < n2 = 
        NodeATreeF v2 (n1 + n2 + 1) (Right (l, l2)) (Left r2)
    | weight * n2 < n1 = 
        NodeATreeF v1 (n1 + n2 + 1) (Left l1) (Right (r1, r))
    | otherwise = 
        NodeATreeF elem (n1 + n2 + 1) (Left l) (Left r)

3. 类型一致性检查 #

确保RCoalgebra的输入类型是(Fix (ATreeF a), Fix (ATreeF a))，如果ATreeF'是Fix (ATreeF a)的别名则无需调整，否则需添加类型转换逻辑。

4. 备选方案：使用Elgot Apomorphism #

若需要更灵活的递归混合模式，可使用Elgot Apomorphism，它允许直接嵌入已计算的结果，适合此类“部分直接构造、部分递归”的场景：

-- 自定义Elgot Apomorphism实现
elgotApo :: Functor f => (a -> f (Fix f)) -> (a -> f a) -> a -> Fix f
elgotApo g h = In . fmap (either id (elgotApo g h)) . fmap (Right <$>) g <|> h

使用时可以将直接构造的逻辑放在g，递归子问题放在h，简化代码结构。

内容的提问来源于stack exchange，提问作者cocorudeboy