Commit 21be6587 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Implement morphism parsing for polynomial functor

This begins the implementation of the polynomial functor. It currently
only implements the morphism parser and neither the refinement
interface nor the functor expression parser. Both will come at a later
state.
parent 1b44b80f
......@@ -37,6 +37,7 @@ library
, MA.Functors.MonoidValued
, MA.Functors.Distribution
, MA.Functors.Product
, MA.Functors.Polynomial
, MA.Functors.SomeFunctor
, MA.Parser
, MA.Parser.Lexer
......@@ -110,6 +111,7 @@ test-suite spec
, MA.Functors.MonoidValuedSpec
, MA.Functors.BagSpec
, MA.Functors.DistributionSpec
, MA.Functors.PolynomialSpec
, MA.FunctorExpression.ParserSpec
, MA.FunctorExpression.PrettySpec
, MA.FunctorExpression.SortsSpec
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module MA.Functors.Polynomial
( Polynomial(..)
, Sum(..)
, Product(..)
, Factor(..)
, SumValue(..)
, ProductValue(..)
, FactorValue(..)
) where
import Control.Monad
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Text.Megaparsec
import MA.Coalgebra.Parser
import MA.Coalgebra.RefinementTypes
import qualified MA.Parser.Lexer as L
import MA.Parser.Types
newtype Polynomial a = Polynomial (Sum a)
deriving (Functor)
data Sum a = Sum (NonEmpty (Product a))
deriving (Functor)
data Product a = Product (NonEmpty (Factor a))
deriving (Functor)
data Factor a
= Const (Vector Text)
| Identity a
deriving (Functor)
data Three = ToRest | ToCompound | ToSub
deriving (Show, Eq, Ord, Enum)
data SumValue a = SumValue Int (ProductValue a)
deriving (Eq, Show)
data ProductValue a =
ProductValue (Vector (FactorValue a))
deriving (Eq, Show)
data FactorValue a
= ConstValue Int
| IdValue a
deriving (Eq, Show)
type instance H1 Polynomial = SumValue ()
type instance Label Polynomial = Int
type instance Weight Polynomial = SumValue Bool
type instance H3 Polynomial = SumValue Three
instance ParseMorphism Polynomial where
parseMorphismPoint (Polynomial expr) = parseSum expr
where
parseSum ::
MonadParser m => Sum (m a) -> m (SumValue (), [(a, Label Polynomial)])
parseSum (Sum summands) = do
void $ L.symbol "inj"
i <- L.decimal
when (i < 0 || i >= length summands) $
fail ("polynomial: injection " ++ show i ++ " is out of bounds")
(h1, successors) <- parseProduct (summands NonEmpty.!! i)
return (SumValue i h1, successors)
parseProduct ::
MonadParser m => Product (m a) -> m (ProductValue (), [(a, Int)])
parseProduct (Product (f :| fs)) = L.parens $ do
factors <-
(:) <$> parseFactor f <*> traverse (\x -> L.comma *> parseFactor x) fs
let (h1, successors) = unzip factors
return
( ProductValue (V.fromList h1)
, catMaybes (map (\(i, s) -> fmap (, i) s) (zip [0 ..] successors)))
parseFactor :: MonadParser m => Factor (m a) -> m (FactorValue (), Maybe a)
parseFactor (Const names) = do
h1 <- ConstValue <$> someName names
return (h1, Nothing) -- const has no successors
parseFactor (Identity inner) = do
successor <- inner
return (IdValue (), Just successor)
someName :: MonadParser m => Vector Text -> m Int
someName v =
(V.ifoldr (\i new old -> (L.symbol new *> pure i) <|> old) empty v)
<?> ("one of " ++ show v)
module MA.Functors.PolynomialSpec (spec) where
import Test.Hspec
import Test.Hspec.Megaparsec
import qualified Data.List.NonEmpty as NonEmpty
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.MorphismEncoding (Encoding)
import qualified Data.MorphismEncoding as Encoding
import MA.Coalgebra.Parser
import MA.FunctorExpression.Type
import MA.Functors.Polynomial
spec :: Spec
spec = do
parseMorphismPointSpec
parseMorphismPointSpec :: Spec
parseMorphismPointSpec = describe "parseMorphismPoint" $ do
let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) "" input
it "parses a constant" $ do
morphp (mkPoly [[Const (v ["a", "b", "c"])]]) "x: inj 0 (a)" `shouldParse`
encoding [(1, mkVal 0 [ConstValue 0])] []
morphp (mkPoly [[Const (v ["a", "b", "c"])]]) "x: inj 0 (b)" `shouldParse`
encoding [(1, mkVal 0 [ConstValue 1])] []
it "parses the identity" $
morphp (mkPoly [[Identity Variable]]) "x: inj 0 (y)\ny: inj 0 (x)" `shouldParse`
encoding [(1, mkVal 0 [IdValue ()]), (1, mkVal 0 [IdValue ()])] [(0, (1, 0), 1), (1, (1, 0), 0)]
it "gives a useful error if the injection index is out of bounds" $ do
morphp (mkPoly [[Const (v ["a"])]]) `shouldFailOn `"x: inj 5 (a)"
morphp (mkPoly [[Const (v ["a"])]]) `shouldFailOn `"x: inj -1 (a)"
it "parses a product of a constant and an X" $
morphp (mkPoly [[Const (v ["a"]), Identity Variable]]) "x: inj 0 (a, x)" `shouldParse`
encoding [(1, mkVal 0 [ConstValue 0, IdValue ()])] [(0, (1, 1), 0)]
it "parses a product of two elements" $
morphp (mkPoly [[Identity Variable, Identity Variable]]) "x: inj 0 (x, x)" `shouldParse`
encoding [(1, mkVal 0 [IdValue (), IdValue ()])] [(0, (1, 0), 0), (0, (1, 1), 0)]
it "parses a sum of two constants" $
morphp (mkPoly [[Const (v ["a"])], [Const (v ["b"])]]) "x: inj 0 (a)\ny: inj 1 (b)" `shouldParse`
encoding [(1, mkVal 0 [ConstValue 0]), (1, mkVal 1 [ConstValue 0])] []
it "parses X+(AxX)" $
morphp
(mkPoly [[Identity Variable], [Const (v ["a"]), Identity Variable]])
"x: inj 0 (y)\ny: inj 1 (a, x)" `shouldParse`
encoding
[(1, mkVal 0 [IdValue ()]), (1, mkVal 1 [ConstValue 0, IdValue ()])]
[(0, (1, 0), 1), (1, (1, 1), 0)]
mkPoly :: [[Factor a]] -> Polynomial a
mkPoly =
Polynomial . Sum . NonEmpty.fromList . map (Product . NonEmpty.fromList)
mkVal :: Int -> [FactorValue a] -> SumValue a
mkVal i = SumValue i . ProductValue . v
v :: [a] -> Vector a
v = V.fromList
encoding :: [h1] -> [(Int, l, Int)] -> Encoding l h1
encoding h1 es = Encoding.new (V.fromList h1) (V.fromList (map toEdge es))
where
toEdge (from, lab, to) = Encoding.Edge from lab to
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