这个答案有三个部分。第一部分，我介绍我最喜欢的两个解决方案的总结，是最重要的部分。第二部分包含类型和进口，以及对解决方案的扩展评论。第三部分着重于重新关联表达式的任务，这个答案的原始版本（即第二部分）没有给予应有的重视。
在一天结束时，我结束了两个值得讨论的解决方案。第一个是expandDirect（比较。第三部分）：
expandDirect :: E a -> E a
expandDirect = cata alg
where
alg = \case
Var' s -> Var s
Add' x y -> apo coalgAdd (Add x y)
Mul' x y -> (apo coalgAdd' . apo coalgMul) (Mul x y)
coalgAdd = \case
Add (Add x x') y -> Add' (Left x) (Right (Add x' y))
x -> Left <$> project x
coalgAdd' = \case
Add (Add x x') y -> Add' (Left x) (Right (Add x' y))
Add x (Add y y') -> Add' (Left x) (Right (Add y y'))
x -> Left <$> project x
coalgMul = \case
Mul (Add x x') y -> Add' (Right (Mul x y)) (Right (Mul x' y))
Mul x (Add y y') -> Add' (Right (Mul x y)) (Right (Mul x y'))
x -> Left <$> project x
有了它，我们从底部（cata）重建树。在每一个分支上，如果我们发现一些无效的东西，我们回头重写子树（apo），根据需要重新分配和重新关联，直到所有直接孩子被正确安排（apo使得可以做到这一点，而不必将每一次都重写到最底部）。
第二个解决方案expandMeta是来自第三部分的expandFlat的简化版本。
expandMeta :: E a -> E a
expandMeta = apo coalg . cata alg
where
alg = \case
Var' s -> pure (Var s)
Add' x y -> x <> y
Mul' x y -> Mul <$> x <*> y
coalg = \case
x :| [] -> Left <$> project x
x :| (y:ys) -> Add' (Left x) (Right (y :| ys))
expandMeta是变质;也就是一个变质作用，然后是一个变形作用（当我们在这里也使用apo时，一个apomorphism只是一种奇特的变形，所以我猜这个命名法仍然适用）。变形变性将树变成非空列表 - 隐式地处理重新关联的列表 - 用于分配乘法的列表应用（很像你的建议）。然后，余代数非常简单地将非空列表转换回具有适当形状的树。
谢谢你的问题 - 我有很多的乐趣！预赛：
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Data.Functor.Foldable
import qualified Data.List.NonEmpty as N
import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup
import Data.Foldable (toList)
import Data.List (nub)
import qualified Data.Map as M
import Data.Map (Map, (!))
import Test.QuickCheck
data E a = Var a | Add (E a) (E a) | Mul (E a) (E a)
deriving (Eq, Show, Functor, Foldable)
data EF a b = Var' a | Add' b b | Mul' b b
deriving (Eq, Show, Functor)
type instance Base (E a) = EF a
instance Recursive (E a) where
project = \case
Var x -> Var' x
Add x y -> Add' x y
Mul x y -> Mul' x y
instance Corecursive (E a) where
embed = \case
Var' x -> Var x
Add' x y -> Add x y
Mul' x y -> Mul x y
首先，我的第一个工作（如果有缺陷）的尝试，它使用的（非空）列出了应用性的实例来分配：
expandTooClever :: E a -> E a
expandTooClever = cata $ \case
Var' s -> Var s
Add' x y -> Add x y
Mul' x y -> foldr1 Add (Mul <$> flatten x <*> flatten y)
where
flatten :: E a -> NonEmpty (E a)
flatten = cata $ \case
Var' s -> pure (Var s)
Add' x y -> x <> y
Mul' x y -> pure (foldr1 Mul (x <> y))
expandTooClever有一个比较严重的问题：因为它调用flatten，这是一个全面的折叠，对于这两个子树，只要它达到了Mul，它就有可怕的渐近线链Mul。
蛮力，最简单的一种 - 事物 - 这 - 能 - 可能是工作的解决方案，与代数是递归调用自身：
expandBrute :: E a -> E a
expandBrute = cata alg
where
alg = \case
Var' s -> Var s
Add' x y -> Add x y
Mul' (Add x x') y -> Add (alg (Mul' x y)) (alg (Mul' x' y))
Mul' x (Add y y') -> Add (alg (Mul' x y)) (alg (Mul' x y'))
Mul' x y -> Mul x y
需要的递归调用，因为分布可能推出下Add新出现Mul。
A的expandBrute稍微更雅致的变型中，与所述递归调用因子而成为一个单独的函数：
expandNotSoBrute :: E a -> E a
expandNotSoBrute = cata alg
where
alg = \case
Var' s -> Var s
Add' x y -> Add x y
Mul' x y -> dis x y
dis (Add x x') y = Add (dis x y) (dis x' y)
dis x (Add y y') = Add (dis x y) (dis x y')
dis x y = Mul x y
甲驯服expandNotSoBrute，与dis正在变成一个apomorphism。这种措辞表达方式很好地表达了正在发生的事情的全貌：如果您只有Var s和Add s，您可以轻松地在世界上自由地重现树状结构;但是，如果你点击一个Mul，你必须返回并重建整个子树来执行分发（我想知道是否有专门的递归方案来捕获这种模式）。
expandEvert :: E a -> E a
expandEvert = cata alg
where
alg :: EF a (E a) -> E a
alg = \case
Var' s -> Var s
Add' x y -> Add x y
Mul' x y -> apo coalg (x, y)
coalg :: (E a, E a) -> EF a (Either (E a) (E a, E a))
coalg (Add x x', y) = Add' (Right (x, y)) (Right (x', y))
coalg (x, Add y y') = Add' (Right (x, y)) (Right (x, y'))
coalg (x, y) = Mul' (Left x) (Left y)
apo因为我们要预见到最终的结果，如果没有别的分配是必要的。（还有就是它ana写的方式;然而，这需要不改变Mul小号浪费重建树，这导致了同样的渐近性问题expandTooClever了。）
最后，但并非最不重要的，一个解决方案，既成功实现了我曾尝试过的expandTooClever和我对amalloy's answer的解释。 BT是一个花园式的二叉树，叶子上有值。产品由BT a代表，而产品的总和是树木。
expandSOP :: E a -> E a
expandSOP = cata algS . fmap (cata algP) . cata algSOP
where
algSOP :: EF a (BT (BT a)) -> BT (BT a)
algSOP = \case
Var' s -> pure (pure s)
Add' x y -> x <> y
Mul' x y -> (<>) <$> x <*> y
algP :: BTF a (E a) -> E a
algP = \case
Leaf' s -> Var s
Branch' x y -> Mul x y
algS :: BTF (E a) (E a) -> E a
algS = \case
Leaf' x -> x
Branch' x y -> Add x y
BT及其实例：
data BT a = Leaf a | Branch (BT a) (BT a)
deriving (Eq, Show)
data BTF a b = Leaf' a | Branch' b b
deriving (Eq, Show, Functor)
type instance Base (BT a) = BTF a
instance Recursive (BT a) where
project (Leaf s) = Leaf' s
project (Branch l r) = Branch' l r
instance Corecursive (BT a) where
embed (Leaf' s) = Leaf s
embed (Branch' l r) = Branch l r
instance Semigroup (BT a) where
l <> r = Branch l r
-- Writing this, as opposed to deriving it, for the sake of illustration.
instance Functor BT where
fmap f = cata $ \case
Leaf' x -> Leaf (f x)
Branch' l r -> Branch l r
instance Applicative BT where
pure x = Leaf x
u <*> v = ana coalg (u, v)
where
coalg = \case
(Leaf f, Leaf x) -> Leaf' (f x)
(Leaf f, Branch xl xr) -> Branch' (Leaf f, xl) (Leaf f, xr)
(Branch fl fr, v) -> Branch' (fl, v) (fr, v)
为了总结的东西了，测试套件：
newtype TestE = TestE { getTestE :: E Char }
deriving (Eq, Show)
instance Arbitrary TestE where
arbitrary = TestE <$> sized genExpr
where
genVar = Var <$> choose ('a', 'z')
genAdd n = Add <$> genSub n <*> genSub n
genMul n = Mul <$> genSub n <*> genSub n
genSub n = genExpr (n `div` 2)
genExpr = \case
0 -> genVar
n -> oneof [genVar, genAdd n, genMul n]
data TestRig b = TestRig (Map Char b) (E Char)
deriving (Show)
instance Arbitrary b => Arbitrary (TestRig b) where
arbitrary = do
e <- genExpr
d <- genDict e
return (TestRig d e)
where
genExpr = getTestE <$> arbitrary
genDict x = M.fromList . zip (keys x) <$> (infiniteListOf arbitrary)
keys = nub . toList
unsafeSubst :: Ord a => Map a b -> E a -> E b
unsafeSubst dict = fmap (dict !)
eval :: Num a => E a -> a
eval = cata $ \case
Var' x -> x
Add' x y -> x + y
Mul' x y -> x * y
evalRig :: (E Char -> E Char) -> TestRig Integer -> Integer
evalRig f (TestRig d e) = eval (unsafeSubst d (f e))
mkPropEval :: (E Char -> E Char) -> TestRig Integer -> Bool
mkPropEval f = (==) <$> evalRig id <*> evalRig f
isDistributed :: E a -> Bool
isDistributed = para $ \case
Add' (_, x) (_, y) -> x && y
Mul' (Add _ _, _) _ -> False
Mul' _ (Add _ _, _) -> False
Mul' (_, x) (_, y) -> x && y
_ -> True
mkPropDist :: (E Char -> E Char) -> TestE -> Bool
mkPropDist f = isDistributed . f . getTestE
main = mapM_ test
[ ("expandTooClever" , expandTooClever)
, ("expandBrute" , expandBrute)
, ("expandNotSoBrute", expandNotSoBrute)
, ("expandEvert" , expandEvert)
, ("expandSOP" , expandSOP)
]
where
test (header, func) = do
putStrLn $ "Testing: " ++ header
putStr "Evaluation test: "
quickCheck $ mkPropEval func
putStr "Distribution test: "
quickCheck $ mkPropDist func
所生产的产品和我的意思是一种“咖喱的“产品的n元总和。产品总和的简明定义是我想要一个没有任何括号的表达式，所有的parens都由关联性和优先级表示。
我们可以调整上面的解决方案，以便重新关联这些和。最简单的方法是用NonEmpty替换expandSOP中的外部BT。鉴于这种倍增，很像你的建议，liftA2 (<>)，这可以马上使用。
expandFlat :: E a -> E a
expandFlat = cata algS . fmap (cata algP) . cata algSOP
where
algSOP :: EF a (NonEmpty (BT a)) -> NonEmpty (BT a)
algSOP = \case
Var' s -> pure (Leaf s)
Add' x y -> x <> y
Mul' x y -> (<>) <$> x <*> y
algP :: BTF a (E a) -> E a
algP = \case
Leaf' s -> Var s
Branch' x y -> Mul x y
algS :: NonEmptyF (E a) (E a) -> E a
algS = \case
NonEmptyF x Nothing -> x
NonEmptyF x (Just y) -> Add x y
另一种选择是使用任何其他解决方案并在分开的步骤中重新关联分布式树中的总和。
flattenSum :: E a -> E a
flattenSum = cata alg
where
alg = \case
Add' x y -> apo coalg (x, y)
x -> embed x
coalg = \case
(Add x x', y) -> Add' (Left x) (Right (x', y))
(x, y) -> Add' (Left x) (Left y)
我们还可以推出flattenSum和expandEvert成一个单一的功能。请注意，总和代数在得到分布代数的结果时需要一个额外的情况。发生这种情况是因为，随着代数从上到下，我们不能确定它生成的子树是否正确关联。
-- This is written in a slightly different style than the previous functions.
expandDirect :: E a -> E a
expandDirect = cata alg
where
alg = \case
Var' s -> Var s
Add' x y -> apo coalgAdd (Add x y)
Mul' x y -> (apo coalgAdd' . apo coalgMul) (Mul x y)
coalgAdd = \case
Add (Add x x') y -> Add' (Left x) (Right (Add x' y))
x -> Left <$> project x
coalgAdd' = \case
Add (Add x x') y -> Add' (Left x) (Right (Add x' y))
Add x (Add y y') -> Add' (Left x) (Right (Add y y'))
x -> Left <$> project x
coalgMul = \case
Mul (Add x x') y -> Add' (Right (Mul x y)) (Right (Mul x' y))
Mul x (Add y y') -> Add' (Right (Mul x y)) (Right (Mul x y'))
x -> Left <$> project x
或许有写expandDirect更聪明的方式，但我还没有想通出来呢。
我已在您的更新中为地址点＃2的答案添加了一个额外的部分。 – duplode
对我的答案进一步编辑，这次添加一个包含非常简单的非空列表解决方案的摘要。 – duplode