diff --git a/src/Data/Float/Utils.hs b/src/Data/Float/Utils.hs
index 9639ba360a57be4345fa930df6ad5eb1d109e079..4ce7ee745a1402d52186ce8df1fa4c20f21f1c5b 100644
--- a/src/Data/Float/Utils.hs
+++ b/src/Data/Float/Utils.hs
@@ -45,6 +45,7 @@ newtype MaxDouble = MaxDouble Double
, RealFrac
, Floating
, RealFloat
+ , NFData
)
diff --git a/src/MA/Functors.hs b/src/MA/Functors.hs
index c254fcad66b4393419c9e2474ee2d44ba8ad2543..abb501ea66e0bd81ea2258e1ffaa004df6f55f1b 100644
--- a/src/MA/Functors.hs
+++ b/src/MA/Functors.hs
@@ -12,12 +12,12 @@ import MA.Functors.Distribution (distribution)
import MA.Functors.GroupValued (intValued, realValued, complexValued)
import MA.Functors.Polynomial (polynomial)
import MA.Functors.Powerset (powerset)
-import MA.Functors.MonoidValued (maxIntValued)
+import MA.Functors.MonoidValued (maxIntValued, maxRealValued)
import MA.Functors.SomeFunctor
registeredFunctors :: [[FunctorDescription SomeFunctor]]
registeredFunctors =
- [ [someFunctor maxIntValued]
+ [ [someFunctor maxIntValued, someFunctor maxRealValued ]
, [someFunctor intValued, someFunctor realValued, someFunctor complexValued]
, [someFunctor powerset, someFunctor bag, someFunctor distribution]
, [someFunctor polynomial]
diff --git a/src/MA/Functors/MonoidValued.hs b/src/MA/Functors/MonoidValued.hs
index e8d3d658ec6183bdda7ea5aee4266c587152ab23..bca6ad7eb51a7e46877ca05cf41a4f65c907a6d9 100644
--- a/src/MA/Functors/MonoidValued.hs
+++ b/src/MA/Functors/MonoidValued.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -8,7 +9,12 @@
-- The 'RefinementInterface' implementation for such functors doesn't fulfil the
-- same runtime complexity criteria as the other functors and it also uses tons
-- of space, but it works and satisfies the axioms.
-module MA.Functors.MonoidValued (SlowMonoidValued(..), maxIntValued) where
+module MA.Functors.MonoidValued
+ ( SlowMonoidValued(..)
+ , maxIntValued
+ , maxRealValued
+ )
+where
import Data.List ( foldl' )
import Data.Semigroup ( Max(..) )
@@ -27,6 +33,9 @@ import MA.FunctorDescription
import qualified MA.Parser.Lexer as L
import MA.FunctorExpression.Parser
import MA.Coalgebra.Parser
+import Data.Float.Utils ( MaxDouble(..) )
+import MA.Parser.Types
+
data SlowMonoidValued m a = SlowMonoidValued a
@@ -45,7 +54,7 @@ deriving instance Traversable (SlowMonoidValued m)
maxIntValued :: FunctorDescription (SlowMonoidValued (Max Int))
maxIntValued = FunctorDescription
{ name = "Max-valued"
- , syntaxExample = "Max^X"
+ , syntaxExample = "(Z, max)^X"
, functorExprParser =
prefix
-- We need this try here, so that parenthesis can still be parsed as
@@ -59,6 +68,26 @@ maxIntValued = FunctorDescription
)
}
+
+-- | The @(ℝ, max)^X@ functor
+maxRealValued :: FunctorDescription (SlowMonoidValued MaxDouble)
+maxRealValued = FunctorDescription
+ { name = "Max-valued"
+ , syntaxExample = "(R, max)^X"
+ , functorExprParser =
+ prefix
+ -- We need this try here, so that parenthesis can still be parsed as
+ -- normal if they don't contain exactly (Z, max)
+ ( try
+ (L.parens
+ ((L.symbol "R" <|> L.symbol "ℝ") >> L.comma >> L.symbol "max")
+ )
+ >> L.symbol "^"
+ >> pure SlowMonoidValued
+ )
+ }
+
+
type LabelCountMap m = M.Map m Int
type instance Label (SlowMonoidValued m) = m
@@ -96,8 +125,17 @@ sumCounts :: Monoid m => LabelCountMap m -> m
sumCounts = M.foldlWithKey' (\a x -> (<> a) . multiply x) mempty
where multiply x n = mconcat (replicate n x)
+
instance ParseMorphism (SlowMonoidValued (Max Int)) where
- parseMorphismPoint (SlowMonoidValued inner) = do
+ parseMorphismPoint (SlowMonoidValued inner) = parseMorphismPointHelper inner (Max <$> (L.signed L.decimal))
+
+
+instance ParseMorphism (SlowMonoidValued MaxDouble) where
+ parseMorphismPoint (SlowMonoidValued inner) = parseMorphismPointHelper inner (MaxDouble <$> L.signed L.float)
+
+
+parseMorphismPointHelper :: (MonadParser m, Ord x, Monoid w) => m x -> m w -> m (w, V.Vector (x, w))
+parseMorphismPointHelper inner weightParser = do
!successors <- V.sortOn fst . V.fromList <$> L.braces (edge `sepBy` L.comma)
when (V.hasDuplicates (fmap fst successors))
@@ -105,4 +143,4 @@ instance ParseMorphism (SlowMonoidValued (Max Int)) where
let !h1 = fold (V.map snd successors)
return (h1, successors)
- where edge = (,) <$> inner <*> (L.colon *> (Max <$> (L.signed L.decimal)))
+ where edge = (,) <$> inner <*> (L.colon *> weightParser)
diff --git a/tests/MA/Functors/MonoidValuedSpec.hs b/tests/MA/Functors/MonoidValuedSpec.hs
index 901e12eca87eaa3a6520507975f530c3a95caa66..6f2c4579fc3b3747163907a5a80ff5f8e5849db8 100644
--- a/tests/MA/Functors/MonoidValuedSpec.hs
+++ b/tests/MA/Functors/MonoidValuedSpec.hs
@@ -32,11 +32,14 @@ import qualified Data.Partition as Part
import MA.Algorithm
import MA.Functors.Polynomial
import MA.Coalgebra.RefinementTypes
+import Data.Float.Utils
spec :: Spec
spec = do
maxIntParseSpec
maxIntRefineSpec
+ maxRealParseSpec
+ maxRealRefineSpec
maxIntParseSpec :: Spec
@@ -81,6 +84,7 @@ maxIntParseSpec = describe "maxInt parsing" $ do
it "works with negative numbers" $ p `shouldSucceedOn` "x: {x: -2}"
+
maxIntRefineSpec :: Spec
maxIntRefineSpec = describe "maxInt refine" $ do
let p = fmap snd
@@ -97,6 +101,67 @@ maxIntRefineSpec = describe "maxInt refine" $ do
part <- stToIO (refine proxy enc)
(Part.toBlocks part) `shouldMatchList` [[0, 1]]
+
+maxRealParseSpec :: Spec
+maxRealParseSpec = describe "maxReal parsing" $ do
+ it "can parse (R, max)^X as functor expression"
+ $ parseFunctorExpression [[functorExprParser maxRealValued]] "" "(R, max)^X"
+ `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+
+ it "can parse (ℝ, max)^X as functor expression"
+ $ parseFunctorExpression [[functorExprParser maxRealValued]] "" "(ℝ, max)^X"
+ `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+
+ it "nests correctly in functor expressions"
+ $ parseFunctorExpression [[functorExprParser maxRealValued]]
+ ""
+ "(R, max)^((R, max)^X)"
+ `shouldParse` (Functor
+ 1
+ (SlowMonoidValued (Functor 1 (SlowMonoidValued Variable)))
+ )
+
+ it "still parses parenthesis in functor expressions correctly" $ do
+ parseFunctorExpression [[functorExprParser maxRealValued]] "" "((R, max)^X)"
+ `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+ parseFunctorExpression [[functorExprParser maxRealValued]] "" "(R, max)^(X)"
+ `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+
+
+ let p = fmap snd
+ . parseMorphisms (Functor 1 (SlowMonoidValued @MaxDouble Variable)) ""
+
+ it "parses an empty successor list"
+ $ p "x: {}"
+ `shouldParse` encoding [Sorted 1 mempty] []
+
+ it "parses a simple example"
+ $ p "x: {x: 2.5, y: 3.7}\ny: {}"
+ `shouldParse` encoding [Sorted 1 3.7, Sorted 1 mempty]
+ [(0, (Sorted 1 2.5), 0), (0, (Sorted 1 3.7), 1)]
+
+ it "fails on duplicate edges" $ p `shouldFailOn` "x: {x: 2.3, x: 3.6}"
+
+ it "works with negative numbers" $ p `shouldSucceedOn` "x: {x: -2.8}"
+
+
+maxRealRefineSpec :: Spec
+maxRealRefineSpec = describe "maxReal refine" $ do
+ let p = fmap snd
+ . parseMorphisms (Functor 1 (SlowMonoidValued @MaxDouble Variable)) ""
+ proxy = Proxy @(Desorted (SlowMonoidValued MaxDouble))
+
+ it "it distinguishes different maximas with equal sums" $ do
+ let Right enc = p "x: {x: 1.1, y: 3.1}\ny: {x: 2.1, y: 2.1}"
+ part <- stToIO (refine proxy enc)
+ (Part.toBlocks part) `shouldMatchList` [[0], [1]]
+
+ it "identifies equal maximas with different sums" $ do
+ let Right enc = p "x: {x: 1.1, y: 3.1}\ny: {x: 3.1, y: 2.1}"
+ part <- stToIO (refine proxy enc)
+ (Part.toBlocks part) `shouldMatchList` [[0, 1]]
+
+
-- FIXME: Remove duplicate definition of this function
encoding :: [h1] -> [(Int, l, Int)] -> Encoding l h1
encoding h1 es = Encoding.new (V.fromList h1) (V.fromList (map toEdge es))