Implement bitvectors and bitwise 'or' as monoid-valued functor

src/Copar/Functors.hs

@@ -19,6 +19,7 @@ import           Copar.Functors.MonoidValued    ( maxIntValued
                                                 , maxRealValued
                                                 , minRealValued
                                                 , andWordValued
+                                                , orWordValued
                                                 )
 import           Copar.Functors.SomeFunctor
 
@@ -29,6 +30,7 @@ registeredFunctors =
     , someFunctor maxRealValued
     , someFunctor minRealValued
     , someFunctor andWordValued
+    , someFunctor orWordValued
     ]
   , [ someFunctor intValued
     , someFunctor realValued

src/Copar/Functors/MonoidValued.hs

@@ -16,6 +16,7 @@ module Copar.Functors.MonoidValued
   , maxRealValued
   , minRealValued
   , andWordValued 
+  , orWordValued
   )
 where
 
@@ -237,6 +238,42 @@ andWordHelp =
   <+> Doc.reflow "'{' X ':' 0xCAFE, ... '}'"
 
 
+-- | The @(ℕ, or)^X@ functor
+orWordValued :: FunctorDescription (SlowMonoidValued (BitOr Word))
+orWordValued = FunctorDescription
+  { name = "BitOr-valued"
+  , syntaxExample = "(N, or)^X"
+  , description = Just orWordHelp
+  , functorExprParser =
+    prefix
+      -- We need this try here, so that parenthesis can still be parsed as
+      -- normal if they don't contain exactly (N, or)
+      (  try
+          (L.parens
+            ((L.symbol "N" <|> L.symbol "ℕ") >> L.comma >> L.symbol "or")
+          )
+      >> L.symbol "^"
+      >> pure SlowMonoidValued
+      )
+  }
+
+
+orWordHelp :: Doc.Doc Doc.AnsiStyle
+orWordHelp =
+  Doc.reflow ("Weighted systems with bitvectors or bitwise 'or' as monoid weight.")
+  <> 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 "(N, or)^X"
+  <> Doc.line <> Doc.line
+  <> Doc.annotate Doc.bold "Coalgebra syntax:"
+  <+> Doc.reflow "'{' X ':' 0xCAFE, ... '}'"
+
+
 type instance Label (SlowMonoidValued m) = m
 type instance Weight (SlowMonoidValued m) = (m, SumBag m)
 type instance F1 (SlowMonoidValued m) = m
@@ -297,6 +334,11 @@ instance ParseMorphism (SlowMonoidValued (BitAnd Word)) where
     parseMorphismPointHelper inner L.hex =<< (not <$> noSanityChecks)
 
 
+instance ParseMorphism (SlowMonoidValued (BitOr Word)) where
+  parseMorphismPoint (SlowMonoidValued inner) =
+    parseMorphismPointHelper inner L.hex =<< (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

tests/Copar/Functors/MonoidValuedSpec.hs

@@ -38,6 +38,8 @@ spec = do
   minRealRefineSpec 
   andWordParseSpec
   andWordRefineSpec
+  orWordParseSpec
+  orWordRefineSpec
 
 
 maxIntParseSpec :: Spec
@@ -336,3 +338,62 @@ andWordRefineSpec = describe "andWord refine" $ do
     let Right enc = p "x: {x: 0xA0, y: 0x0A}\ny: {x: 0x0B, y: 0xB0}"
     part <- stToIO (refine proxy enc True)
     (Part.toBlocks part) `shouldMatchList` [[0, 1]]
+
+
+orWordParseSpec :: Spec
+orWordParseSpec = describe "bit-or parsing" $ do
+  it "can parse (N, or)^X as functor expression"
+    $ parseFunctorExpression [[functorExprParser orWordValued]] "" "(N, or)^X"
+    `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+
+  it "can parse (ℕ, or)^X as functor expression"
+    $ parseFunctorExpression [[functorExprParser orWordValued]] "" "(ℕ, or)^X"
+    `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+
+  it "nests correctly in functor expressions"
+    $ parseFunctorExpression [[functorExprParser orWordValued]]
+                             ""
+                             "(N, or)^((N, or)^X)"
+    `shouldParse` (Functor
+                    1
+                    (SlowMonoidValued (Functor 1 (SlowMonoidValued Variable)))
+                  )
+
+  it "still parses parenthesis in functor expressions correctly" $ do
+    parseFunctorExpression [[functorExprParser orWordValued]] "" "((N, or)^X)"
+      `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+    parseFunctorExpression [[functorExprParser orWordValued]] "" "(N, or)^(X)"
+      `shouldParse` (Functor 1 (SlowMonoidValued Variable))
+
+  let p = fmap snd . parseMorphisms
+        (Functor 1 (SlowMonoidValued @(BitOr Word) Variable))
+        EnableSanityChecks
+        ""
+
+  it "parses an empty successor list"
+    $ p "x: {}"
+    `shouldParse` encoding [Sorted 1 mempty] []
+
+  it "parses a simple example"
+    $ p "x: {x: 0xA0, y: 0x0A}\ny: {}"
+    `shouldParse` encoding [Sorted 1 0xAA, Sorted 1 mempty]
+                           [(0, (Sorted 1 0xA0), 0), (0, (Sorted 1 0x0A), 1)]
+
+  it "fails on duplicate edges" $ p `shouldFailOn` "x: {x: 0xA, x: 0xA}"
+
+
+orWordRefineSpec :: Spec
+orWordRefineSpec = describe "orWord refine" $ do
+  let p = fmap snd
+        . parseMorphisms (Functor 1 (SlowMonoidValued @(BitOr Word) Variable)) EnableSanityChecks ""
+      proxy = Proxy @(Desorted (SlowMonoidValued (BitOr Word)))
+
+  it "it distinguishes different joins with equal sums" $ do
+    let Right enc = p "x: {x: 0xAA, y: 0xCC}\ny: {x: 0xBB, y: 0xBB}"
+    part <- stToIO (refine proxy enc True)
+    (Part.toBlocks part) `shouldMatchList` [[0], [1]]
+
+  it "identifies equal joins with different sums" $ do
+    let Right enc = p "x: {x: 0xA0, y: 0x0A}\ny: {x: 0xAA, y: 0x00}"
+    part <- stToIO (refine proxy enc True)
+    (Part.toBlocks part) `shouldMatchList` [[0, 1]]