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

Merge branch 'feature/exponentials'

parents 68fc692e ed837097
......@@ -66,5 +66,11 @@ checkForFunctor ::
checkForFunctor (Functor a b) = return (Functor a b)
checkForFunctor Variable = fail "Functor expression needs at least one function symbol"
parseFunctorExpression :: [[FunctorParser f]] -> String -> Text -> Either ParseErr (FunctorExpression f Precedence)
parseFunctorExpression = parse . functorsParser . concat
-- FIXME: The double list is unnecessary currently
parseFunctorExpression ::
[[FunctorParser f]]
-> String
-> Text
-> Either ParseErr (FunctorExpression f Precedence)
parseFunctorExpression functors =
parse (functorsParser (concat functors) <* eof)
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Polynomial functor with co-products, products, exponentials and constants
module MA.Functors.Polynomial
( Polynomial(..)
, polynomial
( -- * Functor expression parser
polynomial
-- * Types exported for easier testing
, Polynomial(..)
, Sum(..)
, Product(..)
, Factor(..)
......@@ -12,18 +17,23 @@ module MA.Functors.Polynomial
, FactorValue(..)
) where
import Data.Bifunctor
import Data.Foldable
import Control.Monad
import Data.Bifunctor
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (catMaybes, maybeToList)
import Data.Maybe (fromMaybe)
import Data.Tuple (swap)
import qualified Data.Vector.Algorithms.Intro as V (sort)
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 Lens.Micro
import MA.Coalgebra.Parser
import MA.Coalgebra.RefinementTypes
......@@ -44,6 +54,7 @@ newtype Product a = Product (NonEmpty (Factor a))
data Factor a
= Const (Vector Text)
| Identity a
| Exponential a (Vector Text)
deriving (Functor, Foldable, Traversable)
$(deriveEq1 ''Factor)
......@@ -74,12 +85,31 @@ parseProductExpr inner = do
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)
parseFactorExpr :: MonadParser m => m a -> m (Factor a)
parseFactorExpr inner = (Const <$> parseConstExpr) <|> (parseIdOrExp inner)
parseConstExpr :: MonadParser m => m (Vector Text)
parseConstExpr = V.fromList <$> (L.braces (L.name `sepBy` L.comma))
parseIdOrExp :: MonadParser m => m a -> m (Factor a)
parseIdOrExp inner = do
x <- inner
(Exponential x <$> (try (L.symbol "^") *> parseExponent))
<|> (return (Identity x))
parseExponent :: MonadParser m => m (Vector Text)
parseExponent = L.braces $ do
names <- (V.modify V.sort . V.fromList) <$> L.name `sepBy` L.comma
let iter (unique :: Bool, last :: Maybe Text) (current :: Text) =
let sameAsLast = last == Just current
in (unique && (not sameAsLast), Just current)
allUnique = fst (foldl' iter (True, Nothing) names)
unless allUnique $
fail "exponential: domain must be uniquely defined"
return names
-- Index into coproduct and corresponding product value
data SumValue a = SumValue Int (ProductValue a)
deriving (Eq, Ord, Show, Functor)
......@@ -89,8 +119,12 @@ data ProductValue a =
deriving (Eq, Ord, Show, Functor)
data FactorValue a
= ConstValue Int
= -- | Index of constant in vector of possible values
ConstValue Int
-- | One placeholder
| IdValue a
-- | Essentially the same as a product of "IdValue"s
| ExponentialValue (Vector a)
deriving (Eq, Ord, Show, Functor)
......@@ -98,9 +132,19 @@ data Three = ToRest | ToCompound | ToSub
deriving (Show, Eq, Ord, Enum)
type instance H1 Polynomial = SumValue ()
type instance Label Polynomial = Int -- Index of edge product (independent of
-- toplevel-sum)
type instance Weight Polynomial = SumValue Bool -- H2
-- | Tuple @(a, b)@ of
--
-- [a]: Index of this edge in the product on the second level
-- [b]: Index of this edge in the exponential on the third level
--
-- For "Identity"s, @b@ is 0. Also note that the top-level co-product doesn't
-- appear in the label at all. It already appears in "H1".
type instance Label Polynomial = (Int, Int)
-- | Defined as H2
type instance Weight Polynomial = SumValue Bool
type instance H3 Polynomial = SumValue Three
instance ParseMorphism Polynomial where
......@@ -142,33 +186,49 @@ parseSum (Sum summands) i = do
-- | Parse either a single factor without parens or a tuple.
parseProduct1 ::
MonadParser m => Product (m a) -> m (ProductValue (), [(a, Int)])
MonadParser m => Product (m a) -> m (ProductValue (), [(a, (Int, Int))])
parseProduct1 product@(Product (factor :| [])) =
let mkProduct = bimap (ProductValue . V.singleton) (maybeToList . fmap (,0))
let mkProduct f = f & _1 %~ (ProductValue . V.singleton)
& _2 %~ (_Just . each . _2 %~ (0,) <&> fromMaybe [])
in (mkProduct <$> parseFactor factor) <|> parseProduct product
parseProduct1 other = parseProduct other
parseProduct ::
MonadParser m => Product (m a) -> m (ProductValue (), [(a, Int)])
MonadParser m => Product (m a) -> m (ProductValue (), [(a, (Int, Int))])
parseProduct (Product (f :| fs)) = L.parens $ do
factors <- (:)
<$> parseFactor f
<*> traverse (\x -> L.comma *> parseFactor x) fs
let (h1, successors) = unzip factors
labeledSuccessors = zipWith (\a i -> fmap (,i) a) successors [0..]
labeledSuccessors =
zipWith
(\x i -> x & _Just . traversed . _2 %~ (i,) & fromMaybe [])
successors
[0..]
return ( ProductValue (V.fromList h1) , catMaybes labeledSuccessors)
return ( ProductValue (V.fromList h1) , concat labeledSuccessors)
----------- Factor parser
parseFactor :: MonadParser m => Factor (m a) -> m (FactorValue (), Maybe a)
parseFactor :: MonadParser m => Factor (m a) -> m (FactorValue (), Maybe [(a, Int)])
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)
return (IdValue (), Just [(successor, 0)])
parseFactor (Exponential inner names) = L.braces $ do
successors <- ((,) <$> someName names <*> (L.colon *> inner)) `sepBy` L.comma
let allIdxUsedOnce = [0..length names-1] == sort (map fst successors)
unless allIdxUsedOnce $
fail ("exponential: map must be well-defined on " ++ show names)
return ( ExponentialValue (V.replicate (length successors) ())
, Just (map swap successors)
)
someName :: MonadParser m => Vector Text -> m Int
someName v =
......@@ -180,18 +240,26 @@ 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 ::
[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
up (labels, weight) = fmapIndex (\i j bi -> bi +? ((i,j) `elem` labels)) weight
(+?) :: Bool -> Bool -> Three
(+?) a b = toEnum (fromEnum a + fromEnum b)
fmapIndex :: (Int -> a -> b) -> SumValue a -> SumValue b
fmapIndex :: forall a b. (Int -> Int -> a -> b) -> SumValue a -> SumValue b
fmapIndex f (SumValue s (ProductValue factors)) =
SumValue s (ProductValue (V.imap (fmap . f) factors))
SumValue s (ProductValue (V.imap fmapFactor factors))
where
fmapFactor :: Int -> FactorValue a -> FactorValue b
fmapFactor i (ExponentialValue as) = ExponentialValue (V.imap (f i) as)
fmapFactor i other = fmap (f i 0) other
......@@ -3,6 +3,7 @@ module MA.Functors.PolynomialSpec (spec) where
import Test.Hspec
import Test.Hspec.Megaparsec
import Data.List (isInfixOf)
import Control.Monad.ST
import Data.Either (isRight)
import Data.Functor.Classes
......@@ -10,6 +11,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy
import Type.Reflection
import Text.Megaparsec (parseErrorPretty)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Text (Text)
......@@ -98,6 +100,39 @@ functorExpressionSpec = describe "functorExpression" $ do
,[ Identity (Functor 2 (SomeFunctor (PrefixFunctor Variable))) ]
])))
it "parses an exponential" $ do
p "X^{a,b}"
`shouldParse` (Functor 1 (mkPoly [[Exponential Variable (v ["a", "b"])]]))
it "parses an exponential under a product" $ do
p "X^{a} x X" `shouldParse`
(Functor 1 (mkPoly [[Exponential Variable (v ["a"]), ident]]))
p "XxX^{a}" `shouldParse`
(Functor 1 (mkPoly [[ident, Exponential Variable (v ["a"])]]))
it "parses an exponential under a coproduct" $ do
p "X^{a} + X" `shouldParse`
(Functor 1 (mkPoly [[Exponential Variable (v ["a"])], [ident]]))
p "X + X^{a}" `shouldParse`
(Functor 1 (mkPoly [[ident], [Exponential Variable (v ["a"])]]))
it "parses a deply nested exponential" $ do
p "X^{a}xX + X" `shouldParse`
(Functor 1 (mkPoly [[Exponential Variable (v ["a"]), ident], [ident]]))
it "errors if exponential has non-uniquely defined domain" $
p `shouldFailOn` "X^{a, a}"
-- This is a bit of a hack: We need to exclude the following behaviour:
-- 1. The parser tries to parse ^{a, a} and fails because of non-unique keys
-- 2. The parser parses the "X" instead as an identity
-- 3. The whole parser fails with an error saying that you can't just have an
-- "X" as functor.
it "gives a useful error message for non-unique keys" $ do
let Left err = p "X^{a, a}"
parseErrorPretty err `shouldSatisfy` ("unique" `isInfixOf`)
data SomeFunctor a where
SomeFunctor :: (Eq1 f, Typeable f, Show1 f) => f a -> SomeFunctor a
......@@ -139,7 +174,7 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do
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)]
encoding [(1, mkVal 0 [IdValue ()]), (1, mkVal 0 [IdValue ()])] [(0, (1, (0, 0)), 1), (1, (1, (0,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)"
......@@ -147,11 +182,11 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do
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)]
encoding [(1, mkVal 0 [ConstValue 0, IdValue ()])] [(0, (1, (1, 0)), 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)]
encoding [(1, mkVal 0 [IdValue (), IdValue ()])] [(0, (1, (0, 0)), 0), (0, (1, (1, 0)), 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`
......@@ -163,13 +198,13 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do
"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)]
[(0, (1, (0, 0)), 1), (1, (1, (1, 0)), 0)]
it "allows to omit 'inj' for co-products with only one factor" $ do
morphp (mkPoly [[Const (v ["a"])]]) "x: (a)" `shouldParse`
encoding [(1, mkVal 0 [ConstValue 0])] []
morphp (mkPoly [[Identity Variable, Identity Variable]]) "x: (x, x)" `shouldParse`
encoding [(1, mkVal 0 [IdValue (), IdValue ()])] [(0, (1, 0), 0), (0, (1, 1), 0)]
encoding [(1, mkVal 0 [IdValue (), IdValue ()])] [(0, (1, (0, 0)), 0), (0, (1, (1, 0)), 0)]
it "doesn't confuse a constant called inj and an injection" $ do
morphp (mkPoly [[Const (v ["injection"])]]) "x: injection" `shouldParse`
......@@ -187,6 +222,32 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do
morphp (mkPoly [[Const (v ["a"])]]) "x: a" `shouldParse`
encoding [(1, mkVal 0 [ConstValue 0])] []
it "parses an exponential" $ do
morphp (mkPoly [[Exponential Variable (v ["a"])]]) "x: {a: x}"
`shouldParse`
encoding [(1, mkVal 0 [ExponentialValue (v [()])])] [(0, (1, (0, 0)), 0)]
it "fails to parse an exponential that isn't totally defined" $ do
morphp (mkPoly [[Exponential Variable (v ["a", "b"])]])
`shouldFailOn` "x: {a: x}"
it "fails to parse an exponential that isn't uniquely defined" $ do
morphp (mkPoly [[Exponential Variable (v ["a", "b"])]])
`shouldFailOn` "x: {a: x, b: x, b: x}"
it "parses an exponential under a coproduct" $ do
morphp (mkPoly [[Exponential Variable (v ["a", "b"])], [Identity Variable]])
"x: inj0 {a: x, b: y}\ny: inj1 y"
`shouldParse`
(encoding
[ (1, mkVal 0 [ExponentialValue (v [(), ()])])
, (1, mkVal 1 [IdValue ()])
]
[ (0, (1, (0, 0)), 0)
, (0, (1, (0, 1)), 1)
, (1, (1, (0, 0)), 1)
])
refineSpec :: Spec
refineSpec = describe "refining" $ do
let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) "" input
......@@ -215,7 +276,18 @@ refineSpec = describe "refining" $ do
part <- stToIO (refine (Proxy @(Desorted Polynomial)) enc)
(Part.numBlocks part) `shouldBe` 4
it "correctly distinguishes different exponential values" $ do
-- {a,b} + X^2
let f = mkPoly [[Const (v ["A", "B"])], [Exponential Variable (v ["i", "j"])]]
let res = morphp f
"a: inj 0 (A)\n\
\b: inj 0 (B)\n\
\x: inj 1 {i: a, j: b}\n\
\y: inj 1 {i: b, j: 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
......
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