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

Just for completeness. The corresponding `max` implementations were already
there.

src/Copar/Functors.hs

 {-# 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]
   ]

src/Copar/Functors/MonoidValued.hs

@@ -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

src/Data/Float/Utils.hs

@@ -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

tests/Copar/Functors/MonoidValuedSpec.hs

@@ -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))