Commit 87b8ef1d authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

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

parent 7a6be645
......@@ -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
......
......@@ -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
......
......@@ -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]]
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