Commit 3598c971 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Implement RefinementInterface for Polynomial

parent 997f2047
......@@ -24,33 +24,34 @@ import MA.Coalgebra.Parser
import MA.Coalgebra.RefinementTypes
import qualified MA.Parser.Lexer as L
import MA.Parser.Types
import MA.RefinementInterface
newtype Polynomial a = Polynomial (Sum a)
deriving (Functor)
deriving (Functor, Foldable, Traversable)
newtype Sum a = Sum (NonEmpty (Product a))
deriving (Functor)
deriving (Functor, Foldable, Traversable)
newtype Product a = Product (NonEmpty (Factor a))
deriving (Functor)
deriving (Functor, Foldable, Traversable)
data Factor a
= Const (Vector Text)
| Identity a
deriving (Functor)
deriving (Functor, Foldable, Traversable)
-- Index into coproduct and corresponding product value
data SumValue a = SumValue Int (ProductValue a)
deriving (Eq, Show)
deriving (Eq, Ord, Show, Functor)
data ProductValue a =
ProductValue (Vector (FactorValue a))
deriving (Eq, Show)
deriving (Eq, Ord, Show, Functor)
data FactorValue a
= ConstValue Int
| IdValue a
deriving (Eq, Show)
deriving (Eq, Ord, Show, Functor)
data Three = ToRest | ToCompound | ToSub
......@@ -105,3 +106,24 @@ instance ParseMorphism Polynomial where
someName v =
(V.ifoldr (\i new old -> (L.symbol new *> pure i) <|> old) empty v)
<?> ("one of " ++ show v)
instance RefinementInterface Polynomial where
init :: H1 Polynomial -> [Label Polynomial] -> Weight Polynomial
init h1 _ = fmap (const True) h1
update :: [Label Polynomial] -> Weight Polynomial -> (Weight Polynomial, H3 Polynomial, Weight Polynomial)
update = curry (val . up)
where
val :: H3 Polynomial -> (Weight Polynomial, H3 Polynomial, Weight Polynomial)
val h3 = (fmap (== ToSub) h3, h3, fmap (== ToCompound) h3)
up :: ([Label Polynomial], Weight Polynomial) -> H3 Polynomial
up (labels, weight) = fmapIndex (\i bi -> bi +? (i `elem` labels)) weight
(+?) :: Bool -> Bool -> Three
(+?) a b = toEnum (fromEnum a + fromEnum b)
fmapIndex :: (Int -> a -> b) -> SumValue a -> SumValue b
fmapIndex f (SumValue s (ProductValue factors)) =
SumValue s (ProductValue (V.imap (fmap . f) factors))
......@@ -4,19 +4,26 @@ 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.Vector (Vector)
import qualified Data.Vector as V
import MA.Algorithm
import qualified Data.Partition as Part
import Data.MorphismEncoding (Encoding)
import qualified Data.MorphismEncoding as Encoding
import MA.Coalgebra.Parser
import MA.FunctorExpression.Desorting
import MA.FunctorExpression.Type
import MA.Functors.Polynomial
spec :: Spec
spec = do
parseMorphismPointSpec
refineSpec
parseMorphismPointSpec :: Spec
parseMorphismPointSpec = describe "parseMorphismPoint" $ do
......@@ -56,6 +63,38 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do
[(1, mkVal 0 [IdValue ()]), (1, mkVal 1 [ConstValue 0, IdValue ()])]
[(0, (1, 0), 1), (1, (1, 1), 0)]
refineSpec :: Spec
refineSpec = describe "refining" $ do
let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) "" input
it "distinguishes constants" $ do
let Right enc = morphp (mkPoly [[Const (v ["a", "b"])]]) "x: inj 0 (a)\ny: inj 0 (b)"
part <- stToIO (refine (Proxy @(Desorted Polynomial)) enc)
(Part.toBlocks part) `shouldMatchList` [[0], [1]]
it "distinguishes co-factors" $ do
let f = mkPoly [[Const (v ["a"])], [Const (v ["a"])]]
let Right enc = morphp f "x: inj 0 (a)\ny: inj 1 (a)"
part <- stToIO (refine (Proxy @(Desorted Polynomial)) enc)
(Part.toBlocks part) `shouldMatchList` [[0], [1]]
it "correctly identifies factors" $ do
-- {a,b} + X^2
let f = mkPoly [[Const (v ["A", "B"])], [Identity Variable, Identity Variable]]
let res = morphp f
"a: inj 0 (A)\n\
\b: inj 0 (B)\n\
\x: inj 1 (a, b)\n\
\y: inj 1 (b, a)"
res `shouldSatisfy` isRight
let Right enc = res
part <- stToIO (refine (Proxy @(Desorted Polynomial)) enc)
(Part.numBlocks part) `shouldBe` 4
-- Helpers
mkPoly :: [[Factor a]] -> Polynomial a
mkPoly =
Polynomial . Sum . NonEmpty.fromList . map (Product . NonEmpty.fromList)
......
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