Commit e34f4979 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

Implement (Z, min) and (R, min) monoids

Just for completeness. The corresponding `max` implementations were already
there.
parent e13739a7
{-# LANGUAGE PolyKinds #-}
module Copar.Functors
( registeredFunctors
) where
module Copar.Functors (registeredFunctors) where
import Prelude hiding (product)
import Prelude hiding ( product )
import Copar.FunctorDescription
import Copar.Functors.Bag (bag)
import Copar.Functors.Distribution (distribution)
import Copar.Functors.GroupValued (intValued, realValued, complexValued, rationalValued)
import Copar.Functors.Polynomial (polynomial)
import Copar.Functors.Powerset (powerset)
import Copar.Functors.MonoidValued (maxIntValued, maxRealValued)
import Copar.Functors.SomeFunctor
import Copar.FunctorDescription
import Copar.Functors.Bag ( bag )
import Copar.Functors.Distribution ( distribution )
import Copar.Functors.GroupValued ( intValued
, realValued
, complexValued
, rationalValued
)
import Copar.Functors.Polynomial ( polynomial )
import Copar.Functors.Powerset ( powerset )
import Copar.Functors.MonoidValued ( maxIntValued
, minIntValued
, maxRealValued
, minRealValued
)
import Copar.Functors.SomeFunctor
registeredFunctors :: [[FunctorDescription SomeFunctor]]
registeredFunctors =
[ [ someFunctor maxIntValued, someFunctor maxRealValued ]
, [ someFunctor intValued, someFunctor realValued, someFunctor complexValued
[ [ someFunctor maxIntValued
, someFunctor minIntValued
, someFunctor maxRealValued
, someFunctor minRealValued
]
, [ someFunctor intValued
, someFunctor realValued
, someFunctor complexValued
, someFunctor rationalValued
]
, [ someFunctor powerset, someFunctor bag, someFunctor distribution]
, [ someFunctor polynomial]
, [someFunctor powerset, someFunctor bag, someFunctor distribution]
, [someFunctor polynomial]
]
......@@ -12,12 +12,14 @@
module Copar.Functors.MonoidValued
( SlowMonoidValued(..)
, maxIntValued
, minIntValued
, maxRealValued
, minRealValued
)
where
import Data.List ( foldl' )
import Data.Semigroup ( Max(..) )
import Data.Semigroup ( Max(..), Min(..) )
import Data.Functor.Classes
import Control.Monad
import Data.Foldable
......@@ -33,7 +35,9 @@ import Copar.FunctorDescription
import qualified Copar.Parser.Lexer as L
import Copar.FunctorExpression.Parser
import Copar.Coalgebra.Parser
import Data.Float.Utils ( MaxDouble(..) )
import Data.Float.Utils ( MaxDouble(..)
, MinDouble(..)
)
import Copar.Parser.Types
import Data.SumBag (SumBag)
import qualified Data.SumBag as SumBag
......@@ -57,7 +61,7 @@ maxIntValued :: FunctorDescription (SlowMonoidValued (Max Int))
maxIntValued = FunctorDescription
{ name = "Max-valued"
, syntaxExample = "(Z, max)^X"
, description = Just intHelp
, description = Just maxIntHelp
, functorExprParser =
prefix
-- We need this try here, so that parenthesis can still be parsed as
......@@ -72,8 +76,8 @@ maxIntValued = FunctorDescription
}
intHelp :: Doc.Doc Doc.AnsiStyle
intHelp =
maxIntHelp :: Doc.Doc Doc.AnsiStyle
maxIntHelp =
Doc.reflow ("Weighted systems with the monoid (Z, max).")
<> Doc.line <> Doc.line
<> Doc.reflow "This is similar to all the group valued functors (int, real, \
......@@ -88,12 +92,48 @@ intHelp =
<+> Doc.reflow "'{' X ':' int, ... '}'"
-- | The @(ℤ, min)^X@ functor
minIntValued :: FunctorDescription (SlowMonoidValued (Min Int))
minIntValued = FunctorDescription
{ name = "Min-valued"
, syntaxExample = "(Z, min)^X"
, description = Just minIntHelp
, functorExprParser =
prefix
-- We need this try here, so that parenthesis can still be parsed as
-- normal if they don't contain exactly (Z, min)
( try
(L.parens
((L.symbol "Z" <|> L.symbol "ℤ") >> L.comma >> L.symbol "min")
)
>> L.symbol "^"
>> pure SlowMonoidValued
)
}
minIntHelp :: Doc.Doc Doc.AnsiStyle
minIntHelp =
Doc.reflow ("Weighted systems with the monoid (Z, min).")
<> Doc.line <> Doc.line
<> Doc.reflow "This is similar to all the group valued functors (int, real, \
\etc) but isn't actually a group as it lacks an inverse. Thus \
\the refinement interface implementation for this functor is\
\asymptotically slower than for the others."
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Functor syntax:"
<+> Doc.reflow "(Z, min)^X"
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Coalgebra syntax:"
<+> Doc.reflow "'{' X ':' int, ... '}'"
-- | The @(ℝ, max)^X@ functor
maxRealValued :: FunctorDescription (SlowMonoidValued MaxDouble)
maxRealValued = FunctorDescription
{ name = "Max-valued"
, syntaxExample = "(R, max)^X"
, description = Just realHelp
, description = Just maxRealHelp
, functorExprParser =
prefix
-- We need this try here, so that parenthesis can still be parsed as
......@@ -107,8 +147,8 @@ maxRealValued = FunctorDescription
)
}
realHelp :: Doc.Doc Doc.AnsiStyle
realHelp =
maxRealHelp :: Doc.Doc Doc.AnsiStyle
maxRealHelp =
Doc.reflow ("Weighted systems with the monoid (R, max).")
<> Doc.line <> Doc.line
<> Doc.reflow "This is similar to all the group valued functors (int, real, \
......@@ -122,6 +162,43 @@ realHelp =
<> Doc.annotate Doc.bold "Coalgebra syntax:"
<+> Doc.reflow "'{' X ':' real, ... '}'"
-- | The @(ℝ, max)^X@ functor
minRealValued :: FunctorDescription (SlowMonoidValued MinDouble)
minRealValued = FunctorDescription
{ name = "Min-valued"
, syntaxExample = "(R, min)^X"
, description = Just minRealHelp
, functorExprParser =
prefix
-- We need this try here, so that parenthesis can still be parsed as
-- normal if they don't contain exactly (Z, min)
( try
(L.parens
((L.symbol "R" <|> L.symbol "ℝ") >> L.comma >> L.symbol "min")
)
>> L.symbol "^"
>> pure SlowMonoidValued
)
}
minRealHelp :: Doc.Doc Doc.AnsiStyle
minRealHelp =
Doc.reflow ("Weighted systems with the monoid (R, min).")
<> Doc.line <> Doc.line
<> Doc.reflow "This is similar to all the group valued functors (int, real, \
\etc) but isn't actually a group as it lacks an inverse. Thus \
\the refinement interface implementation for this functor is \
\asymptotically slower than for the others."
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Functor syntax:"
<+> Doc.reflow "(R, min)^X"
<> Doc.line <> Doc.line
<> Doc.annotate Doc.bold "Coalgebra syntax:"
<+> Doc.reflow "'{' X ':' real, ... '}'"
type instance Label (SlowMonoidValued m) = m
type instance Weight (SlowMonoidValued m) = (m, SumBag m)
type instance F1 (SlowMonoidValued m) = m
......@@ -159,12 +236,24 @@ instance ParseMorphism (SlowMonoidValued (Max Int)) where
=<< (not <$> noSanityChecks)
instance ParseMorphism (SlowMonoidValued (Min Int)) where
parseMorphismPoint (SlowMonoidValued inner) =
parseMorphismPointHelper inner (Min <$> (L.signed L.decimal))
=<< (not <$> noSanityChecks)
instance ParseMorphism (SlowMonoidValued MaxDouble) where
parseMorphismPoint (SlowMonoidValued inner) =
parseMorphismPointHelper inner (MaxDouble <$> L.signed L.float)
=<< (not <$> noSanityChecks)
instance ParseMorphism (SlowMonoidValued MinDouble) where
parseMorphismPoint (SlowMonoidValued inner) =
parseMorphismPointHelper inner (MinDouble <$> L.signed L.float)
=<< (not <$> noSanityChecks)
parseMorphismPointHelper :: (MonadParser m, Ord x, Monoid w) => m x -> m w -> Bool -> m (w, V.Vector (x, w))
parseMorphismPointHelper inner weightParser sanity = do
!successors <- case sanity of
......
......@@ -3,7 +3,13 @@
-- | Various utilities for floating point numbers
module Data.Float.Utils (EqDouble, fromDouble, MaxDouble(..)) where
module Data.Float.Utils
( EqDouble
, fromDouble
, MaxDouble(..)
, MinDouble(..)
)
where
import Control.DeepSeq ( NFData )
import qualified Numeric.IEEE as IEEE
......@@ -34,10 +40,14 @@ fromDouble = EqDouble
-- | We cast the double to float and compare the result exactly. This ensures a
-- transitive relation.
instance Eq EqDouble where
(EqDouble a) == (EqDouble b) =
(double2Float a) == (double2Float b)
(EqDouble a) == (EqDouble b) = (double2Float a) == (double2Float b)
-- | A wrapper around double that has a monoid instance with the following
-- semantics:
--
-- * 'mempty' is negative infinity
-- * '<>' is implemented in terms of 'IEEE.maxNum'
newtype MaxDouble = MaxDouble Double
deriving newtype ( Show
, Eq
......@@ -51,10 +61,33 @@ newtype MaxDouble = MaxDouble Double
, NFData
)
instance Semigroup MaxDouble where
(MaxDouble d1) <> (MaxDouble d2) = MaxDouble (IEEE.maxNum d1 d2)
instance Monoid MaxDouble where
mempty = MaxDouble (negate IEEE.infinity)
-- | A wrapper around double that has a monoid instance with the following
-- semantics:
--
-- * 'mempty' is positive infinity
-- * '<>' is implemented in terms of 'IEEE.minNum'
newtype MinDouble = MinDouble Double
deriving newtype ( Show
, Eq
, Ord
, Num
, Real
, Fractional
, RealFrac
, Floating
, RealFloat
, NFData
)
instance Semigroup MinDouble where
(MinDouble d1) <> (MinDouble d2) = MinDouble (IEEE.minNum d1 d2)
instance Monoid MinDouble where
mempty = MinDouble IEEE.infinity
......@@ -5,24 +5,18 @@ module Copar.Functors.MonoidValuedSpec (spec) where
import Test.Hspec
import Data.Semigroup ( Max(..) )
import qualified Data.List.NonEmpty as NonEmpty
import Data.Semigroup ( Max(..)
, Min(..)
)
import Control.Monad.ST
import Data.Proxy
import Type.Reflection
import Data.Functor.Classes
import qualified Data.Text as T
import Data.Text ( Text )
import Test.Hspec.Megaparsec
import qualified Data.Vector as V
import Lens.Micro.Platform
import Copar.FunctorExpression.Parser
import Copar.Functors.MonoidValued
import Copar.Parser.Types
import Copar.FunctorExpression.Type
import qualified Copar.Parser.Lexer as L
import Copar.FunctorDescription
import Copar.Coalgebra.Parser
import Data.MorphismEncoding ( Encoding )
......@@ -31,16 +25,18 @@ import Copar.FunctorExpression.Sorts ( Sorted(..) )
import Copar.FunctorExpression.Desorting
import qualified Data.Partition as Part
import Copar.Algorithm
import Copar.Functors.Polynomial
import Copar.RefinementInterface
import Data.Float.Utils
spec :: Spec
spec = do
maxIntParseSpec
minIntParseSpec
maxIntRefineSpec
minIntRefineSpec
maxRealParseSpec
minRealParseSpec
maxRealRefineSpec
minRealRefineSpec
maxIntParseSpec :: Spec
......@@ -85,6 +81,48 @@ maxIntParseSpec = describe "maxInt parsing" $ do
it "works with negative numbers" $ p `shouldSucceedOn` "x: {x: -2}"
minIntParseSpec :: Spec
minIntParseSpec = describe "minIntParse" $ do
it "can parse (Z, min)^X as functor expression"
$ parseFunctorExpression [[functorExprParser minIntValued]] "" "(Z, min)^X"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
it "can parse (ℤ, min)^X as functor expression"
$ parseFunctorExpression [[functorExprParser minIntValued]] "" "(ℤ, min)^X"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
it "nests correctly in functor expressions"
$ parseFunctorExpression [[functorExprParser minIntValued]]
""
"(Z, min)^((Z, min)^X)"
`shouldParse` (Functor
1
(SlowMonoidValued (Functor 1 (SlowMonoidValued Variable)))
)
it "still parses parenthesis in functor expressions correctly" $ do
parseFunctorExpression [[functorExprParser minIntValued]] "" "((Z, min)^X)"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
parseFunctorExpression [[functorExprParser minIntValued]] "" "(Z, min)^(X)"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
let p = fmap snd
. parseMorphisms (Functor 1 (SlowMonoidValued @(Min Int) Variable)) EnableSanityChecks ""
it "parses an empty successor list"
$ p "x: {}"
`shouldParse` encoding [Sorted 1 maxBound] []
it "parses a simple example"
$ p "x: {x: 2, y: 3}\ny: {}"
`shouldParse` encoding [Sorted 1 2, Sorted 1 maxBound]
[(0, (Sorted 1 2), 0), (0, (Sorted 1 3), 1)]
it "fails on duplicate edges" $ p `shouldFailOn` "x: {x: 2, x: 3}"
it "works with negative numbers" $ p `shouldSucceedOn` "x: {x: -2}"
maxIntRefineSpec :: Spec
maxIntRefineSpec = describe "maxInt refine" $ do
......@@ -103,6 +141,23 @@ maxIntRefineSpec = describe "maxInt refine" $ do
(Part.toBlocks part) `shouldMatchList` [[0, 1]]
minIntRefineSpec :: Spec
minIntRefineSpec = describe "minInt refine" $ do
let p = fmap snd
. parseMorphisms (Functor 1 (SlowMonoidValued @(Min Int) Variable)) EnableSanityChecks ""
proxy = Proxy @(Desorted (SlowMonoidValued (Min Int)))
it "it distinguishes different minimas with equal sums" $ do
let Right enc = p "x: {x: 1, y: 3}\ny: {x: 2, y: 2}"
part <- stToIO (refine proxy enc True)
(Part.toBlocks part) `shouldMatchList` [[0], [1]]
it "identifies equal minimas with different sums" $ do
let Right enc = p "x: {x: 1, y: 3}\ny: {x: 4, y: 1}"
part <- stToIO (refine proxy enc True)
(Part.toBlocks part) `shouldMatchList` [[0, 1]]
maxRealParseSpec :: Spec
maxRealParseSpec = describe "maxReal parsing" $ do
it "can parse (R, max)^X as functor expression"
......@@ -146,6 +201,49 @@ maxRealParseSpec = describe "maxReal parsing" $ do
it "works with negative numbers" $ p `shouldSucceedOn` "x: {x: -2.8}"
minRealParseSpec :: Spec
minRealParseSpec = describe "minReal parsing" $ do
it "can parse (R, min)^X as functor expression"
$ parseFunctorExpression [[functorExprParser minRealValued]] "" "(R, min)^X"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
it "can parse (ℝ, min)^X as functor expression"
$ parseFunctorExpression [[functorExprParser minRealValued]] "" "(ℝ, min)^X"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
it "nests correctly in functor expressions"
$ parseFunctorExpression [[functorExprParser minRealValued]]
""
"(R, min)^((R, min)^X)"
`shouldParse` (Functor
1
(SlowMonoidValued (Functor 1 (SlowMonoidValued Variable)))
)
it "still parses parenthesis in functor expressions correctly" $ do
parseFunctorExpression [[functorExprParser minRealValued]] "" "((R, min)^X)"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
parseFunctorExpression [[functorExprParser minRealValued]] "" "(R, min)^(X)"
`shouldParse` (Functor 1 (SlowMonoidValued Variable))
let p = fmap snd
. parseMorphisms (Functor 1 (SlowMonoidValued @MinDouble Variable)) EnableSanityChecks ""
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 2.5, 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
......@@ -163,6 +261,22 @@ maxRealRefineSpec = describe "maxReal refine" $ do
(Part.toBlocks part) `shouldMatchList` [[0, 1]]
minRealRefineSpec :: Spec
minRealRefineSpec = describe "minReal refine" $ do
let p = fmap snd
. parseMorphisms (Functor 1 (SlowMonoidValued @MinDouble Variable)) EnableSanityChecks ""
proxy = Proxy @(Desorted (SlowMonoidValued MinDouble))
it "it distinguishes different minimas 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 True)
(Part.toBlocks part) `shouldMatchList` [[0], [1]]
it "identifies equal minimas with different sums" $ do
let Right enc = p "x: {x: 1.1, y: 3.1}\ny: {x: 1.1, y: 2.1}"
part <- stToIO (refine proxy enc True)
(Part.toBlocks part) `shouldMatchList` [[0, 1]]
-- FIXME: Remove duplicate definition of this function
encoding :: [f1] -> [(Int, l, Int)] -> Encoding l f1
encoding f1 es = Encoding.new (V.fromList f1) (V.fromList (map toEdge es))
......
Markdown is supported
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