Commit 39d563b8 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Implement functor expression parser for polynomial

parent 3598c971
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
module MA.Functors.Polynomial
( Polynomial(..)
, polynomial
, Sum(..)
, Product(..)
, Factor(..)
......@@ -19,12 +21,15 @@ import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Text.Megaparsec
import Data.Eq.Deriving (deriveEq1)
import Text.Show.Deriving (deriveShow1)
import MA.Coalgebra.Parser
import MA.Coalgebra.RefinementTypes
import qualified MA.Parser.Lexer as L
import MA.Parser.Types
import MA.RefinementInterface
import MA.FunctorExpression.Parser
newtype Polynomial a = Polynomial (Sum a)
deriving (Functor, Foldable, Traversable)
......@@ -40,6 +45,40 @@ data Factor a
| Identity a
deriving (Functor, Foldable, Traversable)
$(deriveEq1 ''Factor)
$(deriveEq1 ''Product)
$(deriveEq1 ''Sum)
$(deriveEq1 ''Polynomial)
$(deriveShow1 ''Factor)
$(deriveShow1 ''Product)
$(deriveShow1 ''Sum)
$(deriveShow1 ''Polynomial)
polynomial :: FunctorParser Polynomial
polynomial = FunctorParser $ \inner -> do
parseSumExpr inner >>= \case
Sum (Product (Identity a :| []) :| []) -> return (Left a)
other -> return (Right (Polynomial other))
parseSumExpr :: MonadParser m => m a -> m (Sum a)
parseSumExpr inner = do
left <- parseProductExpr inner
rest <- many (L.symbol "+" *> parseProductExpr inner)
return $ Sum (left :| rest)
parseProductExpr :: MonadParser m => m a -> m (Product a)
parseProductExpr inner = do
left <- parseFactorExpr inner
rest <- many (L.symbol "x" *> parseFactorExpr inner)
return $ Product (left :| rest)
parseFactorExpr :: MonadParser f => f a -> f (Factor a)
parseFactorExpr inner = (Const <$> parseConstExpr) <|> (Identity <$> inner)
parseConstExpr :: MonadParser m => m (Vector Text)
parseConstExpr = V.fromList <$> (L.braces (L.name `sepBy` L.comma))
-- Index into coproduct and corresponding product value
data SumValue a = SumValue Int (ProductValue a)
deriving (Eq, Ord, Show, Functor)
......
......@@ -3,14 +3,19 @@ module MA.Functors.PolynomialSpec (spec) where
import Test.Hspec
import Test.Hspec.Megaparsec
import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy
import Control.Monad.ST
import Data.Either (isRight)
import Data.Functor.Classes
import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy
import Type.Reflection
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Text (Text)
import qualified Data.Text as T
import qualified MA.Parser.Lexer as L
import MA.Algorithm
import qualified Data.Partition as Part
import Data.MorphismEncoding (Encoding)
......@@ -19,12 +24,109 @@ import MA.Coalgebra.Parser
import MA.FunctorExpression.Desorting
import MA.FunctorExpression.Type
import MA.Functors.Polynomial
import MA.Functors.Powerset
import MA.FunctorExpression.Parser
spec :: Spec
spec = do
functorExpressionSpec
parseMorphismPointSpec
refineSpec
functorExpressionSpec :: Spec
functorExpressionSpec = describe "functorExpression" $ do
let p = parseFunctorExpression [[polynomial]] ""
ident = Identity Variable
it "parses a constant" $
p "{a, b}" `shouldParse` (Functor 1 (mkPoly [[c ["a", "b"]]]))
it "parses a product" $ do
p "X x X" `shouldParse` (Functor 1 (mkPoly [[ident, ident]]))
p "{a} x {b}" `shouldParse` (Functor 1 (mkPoly [[c ["a"], c ["b"]]]))
p "X x {b}" `shouldParse` (Functor 1 (mkPoly [[ident, c ["b"]]]))
p "{a} x X" `shouldParse` (Functor 1 (mkPoly [[c ["a"], ident]]))
it "parses a co-product" $ do
p "X + X" `shouldParse` (Functor 1 (mkPoly [[ident], [ident]]))
p "{a} + {b}" `shouldParse` (Functor 1 (mkPoly [[c ["a"]], [c ["b"]]]))
p "{a} + X" `shouldParse` (Functor 1 (mkPoly [[c ["a"]], [ident]]))
p "X + {b}" `shouldParse` (Functor 1 (mkPoly [[ident], [c ["b"]]]))
it "parses a product with more than two factors" $ do
p "X x X x X" `shouldParse` (Functor 1 (mkPoly [[ident, ident, ident]]))
it "parses a co-product with more than two factors" $ do
p "X + X + X" `shouldParse` (Functor 1 (mkPoly [[ident], [ident], [ident]]))
it "parses a complex nested expression" $ do
p "{a} + Xx{b,c} + Xx{d}xX" `shouldParse`
(Functor 1 (mkPoly [ [c ["a"]]
, [ident, c ["b", "c"]]
, [ident, c ["d"], ident]]))
it "correctly parses a single subfunctor" $ do
parseFunctorExpression [ [transParser SomeFunctor prefixParser]
, [transParser SomeFunctor polynomial]
]
""
"P X" `shouldParse` (Functor 2 (SomeFunctor (PrefixFunctor Variable)))
it "parses a product of two subfunctors" $ do
parseFunctorExpression [ [transParser SomeFunctor prefixParser]
, [transParser SomeFunctor polynomial]
]
""
"PX x PX"
`shouldParse`
(Functor 1
(SomeFunctor
(mkPoly [[ Identity (Functor 2 (SomeFunctor (PrefixFunctor Variable)))
, Identity (Functor 2 (SomeFunctor (PrefixFunctor Variable)))
]])))
it "parses a co-product of two subfunctors" $ do
parseFunctorExpression [ [transParser SomeFunctor prefixParser]
, [transParser SomeFunctor polynomial]
]
""
"PX + PX"
`shouldParse`
(Functor 1
(SomeFunctor
(mkPoly [[ Identity (Functor 2 (SomeFunctor (PrefixFunctor Variable))) ]
,[ Identity (Functor 2 (SomeFunctor (PrefixFunctor Variable))) ]
])))
data SomeFunctor a where
SomeFunctor :: (Eq1 f, Typeable f, Show1 f) => f a -> SomeFunctor a
instance Eq1 SomeFunctor where
liftEq eq (SomeFunctor (f1 :: tf1 a)) (SomeFunctor (f2 :: tf2 b)) =
case eqTypeRep (typeRep @tf1) (typeRep @tf2) of
Nothing -> False -- different types
Just HRefl -> liftEq eq f1 f2
instance Show1 SomeFunctor where
liftShowsPrec show' showList' prec (SomeFunctor f) = liftShowsPrec show' showList' prec f
data PrefixFunctor a = PrefixFunctor a
deriving (Functor, Foldable, Traversable, Show)
instance Eq1 PrefixFunctor where
liftEq f (PrefixFunctor x) (PrefixFunctor y) = f x y
instance Show1 PrefixFunctor where
liftShowsPrec show' _ prec (PrefixFunctor x) rest
| prec > 10 = "(PrefixFunctor " ++ show' 11 x (rest ++ ")")
| otherwise = "PrefixFunctor " ++ show' 11 x rest
prefixParser :: FunctorParser PrefixFunctor
prefixParser = prefix (L.symbol "P" >> return PrefixFunctor)
c :: [Text] -> Factor a
c = Const . V.fromList
parseMorphismPointSpec :: Spec
parseMorphismPointSpec = describe "parseMorphismPoint" $ do
let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) "" input
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment