Расширение выражения с использованием рекурсивных схем

Question

У меня есть тип данных, представляющий арифметические выражения:

data E = Add E E | Mul E E | Var String

Я хочу написать функцию расширения, которая преобразует выражение в сумму произведений переменных (своего рода расширение фигурных скобок). Использование рекурсивных схем конечно.

Я мог только придумать алгоритм в духе "прогресса и сохранения". Алгоритм на каждом шаге строит термины, которые полностью раскрываются, поэтому нет необходимости перепроверять.

Обработка Mul сделал меня сумасшедшим, поэтому вместо того, чтобы делать это напрямую, я использовал изоморфный тип [[String]] и воспользовался concat а также concatMap уже реализовано для меня:

type Poly = [Mono]
type Mono = [String]

mulMonoBy :: Mono -> Poly -> Poly
mulMonoBy x = map (x ++)

mulPoly :: Poly -> Poly -> Poly
mulPoly x = concatMap (flip mulMonoBy x)

Итак, я просто использую cata:

expandList :: E -> Poly
expandList = cata $ \case
   Var x -> [[x]]
   Add e1 e2 = e1 ++ e2
   Mul e1 e2 = mulPoly e1 e2

И преобразовать обратно:

fromPoly :: Poly -> Expr
fromPoly = foldr1 Add . map fromMono where
   fromMono = foldr1 Mul . map Var

Существуют ли значительно лучшие подходы?

Upd: Есть немного путаницы.

1. Решение позволяет использовать многострочные имена переменных. Add (Val "foo" (Mul (Val "foo) (Var "bar"))) это представление foo + foo * bar, Я не представляю x*y*z с Val "xyz" или что-то. Обратите внимание, что, так как нет скаляров, повторные переменные, такие как "foo * foo * quux", вполне допустимы.

2. Под суммой продуктов я подразумеваю вид "карри" n-арной суммы продуктов. Краткое определение суммы произведений заключается в том, что я хочу выражение без скобок, где все символы представлены ассоциативностью и приоритетом.

Так (foo * bar + bar) + (foo * bar + bar) не сумма продуктов, так как из-за среднего + это сумма сумм

(foo * bar + (bar + (foo * bar + bar))) или соответствующие левоассоциативные версии являются правильными ответами, хотя мы должны гарантировать, что ассоциативность всегда остается всегда справа. Таким образом, правильный тип для правильно-ассоциативного решения

data Poly = Sum Mono Poly
          | Product Mono

который изоморфен непустым спискам: NonEmpty Poly (нота Sum Mono Poly вместо Sum Poly Poly). Если мы допустим пустые суммы или продукты, то получим только список представлений списка, который я использовал.

3. Кроме того, вы не заботитесь о производительности, умножение кажется просто liftA2 (++)

Answer 1

Я не эксперт в рекурсивных схемах, но, поскольку кажется, что вы пытаетесь их практиковать, надеюсь, вы не найдете слишком обременительным преобразование решения, использующего рекурсию вручную, в решение, использующее схемы рекурсии. Сначала я напишу его со смешанной прозой и кодом, а в конце снова включу полный код для более простого копирования / вставки.

Это не так уж сложно сделать, используя просто свойство дистрибутива и немного рекурсивной алгебры. Прежде чем мы начнем, давайте определим лучший тип результата, который гарантирует, что мы можем только когда-либо представлять суммы продуктов:

data Poly term = Sum (Poly term) (Poly term)
               | Product (Mono term) 
               deriving Show

data Mono term = Term term
               | MonoMul (Mono term) (Mono term)
               deriving Show

Таким образом, мы не можем испортить и случайно дать неверный результат, как

(Mul (Var "x") (Add (Var "y") (Var "z")))

Теперь давайте напишем нашу функцию.

expand :: E -> Poly String

Во-первых, базовый случай: тривиально расширять Var, потому что он уже находится в форме суммы продуктов. Но мы должны немного преобразовать его, чтобы он соответствовал нашему типу результата Poly:

expand (Var x) = Product (Term x)

Далее, обратите внимание, что дополнение можно легко расширить: просто разверните два подвыражения и сложите их вместе.

expand (Add x y) = Sum (expand x) (expand y)

Как насчет умножения? Это немного сложнее, так как

Product (expand x) (expand y)

плохо напечатан: мы не можем умножать многочлены, только одночлены. Но мы знаем, как выполнять алгебраические манипуляции, чтобы превратить умножение полиномов в сумму умножений мономов с помощью правила распределения. Как и в вашем вопросе, нам понадобится функция mulPoly, Но давайте просто предположим, что существует, и реализуем это позже.

expand (Mul x y) = mulPoly (expand x) (expand y)

Это обрабатывает все случаи, так что остается только реализовать mulPoly распределяя умножения по терминам двух полиномов. Мы просто разбиваем один из многочленов по одному члену за раз и умножаем член на каждое из членов другого многочлена, складывая результаты.

mulPoly :: Poly String -> Poly String -> Poly String
mulPoly (Product x) y = mulMonoBy x y
mulPoly (Sum a b) x = Sum (mulPoly a x) (mulPoly b x)

mulMonoBy :: Mono String -> Poly -> Poly
mulMonoBy x (Product y) = Product $ MonoMul x y
mulMonoBy x (Sum a b) = Sum (mulPoly a x') (mulPoly b x')
  where x' = Product x

И, наконец, мы можем проверить, что он работает как задумано:

expand (Mul (Add (Var "a") (Var "b")) (Add (Var "y") (Var "z")))
{- results in: Sum (Sum (Product (MonoMul (Term "y") (Term "a"))) 
                        (Product (MonoMul (Term "z") (Term "a")))) 
                   (Sum (Product (MonoMul (Term "y") (Term "b"))) 
                        (Product (MonoMul (Term "z") (Term "b"))))
-}

Или же,

(a + b)(y * z) = ay + az + by + bz

что мы знаем, чтобы быть правильным.

Полное решение, как обещано выше:

data E = Add E E | Mul E E | Var String

data Poly term = Sum (Poly term) (Poly term)
               | Product (Mono term) 
               deriving Show

data Mono term = Term term
               | MonoMul (Mono term) (Mono term)
               deriving Show

expand :: E -> Poly String
expand (Var x) = Product (Term x)
expand (Add x y) = Sum (expand x) (expand y)
expand (Mul x y) = mulPoly (expand x) (expand y)

mulPoly :: Poly String -> Poly String -> Poly String
mulPoly (Product x) y = mulMonoBy x y
mulPoly (Sum a b) x = Sum (mulPoly a x) (mulPoly b x)

mulMonoBy :: Mono String -> Poly String -> Poly String
mulMonoBy x (Product y) = Product $ MonoMul x y
mulMonoBy x (Sum a b) = Sum (mulPoly a x') (mulPoly b x')
  where x' = Product x

main = print $ expand (Mul (Add (Var "a") (Var "b")) (Add (Var "y") (Var "z")))

Answer 2

Этот ответ состоит из трех разделов. Первый раздел, краткий обзор, в котором я представляю два моих любимых решения, является наиболее важным. Второй раздел содержит типы и импорт, а также расширенные комментарии по пути к решениям. Третий раздел посвящен задаче повторного сопоставления выражений, чему оригинальная версия ответа (т.е. второй раздел) не была уделена должное внимание.

В итоге я получил два решения, которые стоит обсудить. Первый 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 и здесь апоморфизм - это просто причудливый вид анаморфизма, так что, я думаю, номенклатура все еще применяется). Катаморфизм превращает дерево в непустой список, который неявно обрабатывает повторную ассоциацию Add s - с аппликативным списком, используемым для распределения умножения (очень как вы предлагаете). Затем коалгебра довольно просто преобразует непустой список обратно в дерево с соответствующей формой.

---

Спасибо за вопрос - мне было очень весело! Отборочные:

{-# 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,

Немного более со вкусом вариант 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 превращается в апоморфизм. Этот способ выразить это хорошо отражает общую картину того, что происходит: если у вас есть только Var с и 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 s без изменений, что приводит к той же проблеме асимптотики expandTooClever имел.)

И последнее, но не менее важное, решение, которое одновременно является успешной реализацией того, с чем я пытался expandTooClever и моя интерпретация ответа Амаллоя. 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-арной суммы продуктов. Краткое определение суммы произведений заключается в том, что я хочу выражение без скобок, где все символы представлены ассоциативностью и приоритетом.

Мы можем скорректировать приведенные выше решения таким образом, чтобы суммы были пересвязаны. Самый простой способ заменить внешнюю BT в expandSOP с NonEmpty, Учитывая, что умножение существует, как вы и предполагаете, 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, но я еще не понял это.