Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
Software
CoPaR
Commits
74c8b14e
Commit
74c8b14e
authored
Mar 13, 2019
by
Hans-Peter Deifel
🐢
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Refactor MonoidValued module to reduce code duplication
parent
1ae4befb
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
79 additions
and
191 deletions
+79
-191
src/Copar/Functors/MonoidValued.hs
src/Copar/Functors/MonoidValued.hs
+79
-191
No files found.
src/Copar/Functors/MonoidValued.hs
View file @
74c8b14e
...
...
@@ -28,8 +28,9 @@ import Data.Foldable
import
qualified
Data.Vector
as
V
import
Text.Megaparsec
import
qualified
Data.Text.Prettyprint
as
Doc
import
Data.Text.Prettyprint
((
<+>
))
import
qualified
Data.Text.Prettyprint
as
Doc
import
Data.Text.Prettyprint
(
(
<+>
)
)
import
Data.Text
(
Text
)
import
qualified
Data.Vector.Utils
as
V
import
Copar.RefinementInterface
...
...
@@ -59,29 +60,43 @@ deriving instance Functor (SlowMonoidValued m)
deriving
instance
Foldable
(
SlowMonoidValued
m
)
deriving
instance
Traversable
(
SlowMonoidValued
m
)
-- | The @(ℤ, max)^X@ functor
maxIntValued
::
FunctorDescription
(
SlowMonoidValued
(
Max
Int
))
maxIntValued
=
FunctorDescription
{
name
=
"Max-valued"
,
syntaxExample
=
"(Z, max)^X"
,
description
=
Just
maxIntHelp
data
MonoidValuedDescription
m
=
MonoidValued
{
mvName
::
Text
,
mvDescription
::
Text
,
mvSet
::
(
Text
,
Text
)
-- (ascii, unicode)
,
mvOperation
::
Text
,
mvTerm
::
Text
}
makeMonoidValued
::
MonoidValuedDescription
m
->
FunctorDescription
(
SlowMonoidValued
m
)
makeMonoidValued
desc
=
FunctorDescription
{
name
=
mvName
desc
<>
"-valued"
,
syntaxExample
=
syntax
fst
<>
" | "
<>
syntax
snd
,
description
=
Just
(
makeMVHelp
desc
)
,
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
"Z"
<|>
L
.
symbol
"ℤ"
)
>>
L
.
comma
>>
L
.
symbol
"max"
)
(
(
L
.
symbol
(
fst
(
mvSet
desc
))
<|>
L
.
symbol
(
snd
(
mvSet
desc
)))
>>
L
.
comma
>>
L
.
symbol
(
mvOperation
desc
)
)
)
>>
L
.
symbol
"^"
>>
pure
SlowMonoidValued
)
}
where
syntax
f
=
functorSyntax
(
f
(
mvSet
desc
))
(
mvOperation
desc
)
functorSyntax
::
Text
->
Text
->
Text
functorSyntax
s
o
=
"("
<>
s
<>
", "
<>
o
<>
")^X"
ma
xInt
Help
::
Doc
.
Doc
Doc
.
AnsiStyle
ma
xIntHelp
=
Doc
.
reflow
(
"Weighted systems with
the monoid (Z, max)."
)
ma
keMV
Help
::
MonoidValuedDescription
m
->
Doc
.
Doc
Doc
.
AnsiStyle
ma
keMVHelp
desc
=
Doc
.
reflow
(
"Weighted systems with
"
<>
mvDescription
desc
)
<>
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
\
...
...
@@ -89,191 +104,77 @@ maxIntHelp =
\
asymptotically slower than for the others."
<>
Doc
.
line
<>
Doc
.
line
<>
Doc
.
annotate
Doc
.
bold
"Functor syntax:"
<+>
Doc
.
reflow
"(Z, max)^X"
<+>
Doc
.
reflow
(
syntax
fst
<>
" | "
<>
syntax
snd
)
<>
Doc
.
line
<>
Doc
.
line
<>
Doc
.
annotate
Doc
.
bold
"Coalgebra syntax:"
<+>
Doc
.
reflow
"'{' X ':' int, ... '}'"
<+>
Doc
.
reflow
(
"'{' X ':' "
<>
mvTerm
desc
<>
", ... '}'"
)
where
syntax
f
=
functorSyntax
(
f
(
mvSet
desc
))
(
mvOperation
desc
)
-- | The @(ℤ, max)^X@ functor
maxIntValued
::
FunctorDescription
(
SlowMonoidValued
(
Max
Int
))
maxIntValued
=
makeMonoidValued
$
MonoidValued
{
mvName
=
"Max"
,
mvSet
=
(
"Z"
,
"ℤ"
)
,
mvOperation
=
"max"
,
mvDescription
=
"the monoid (Z, max)"
,
mvTerm
=
"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
)
minIntValued
=
makeMonoidValued
$
MonoidValued
{
mvName
=
"Min"
,
mvSet
=
(
"Z"
,
"ℤ"
)
,
mvOperation
=
"min"
,
mvDescription
=
"the monoid (Z, min)"
,
mvTerm
=
"int"
}
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
maxRealHelp
,
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
)
maxRealValued
=
makeMonoidValued
$
MonoidValued
{
mvName
=
"Max"
,
mvSet
=
(
"R"
,
"ℝ"
)
,
mvOperation
=
"max"
,
mvDescription
=
"the monoid (R, max)"
,
mvTerm
=
"real"
}
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,
\
\
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, max)^X"
<>
Doc
.
line
<>
Doc
.
line
<>
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
)
minRealValued
=
makeMonoidValued
$
MonoidValued
{
mvName
=
"Min"
,
mvSet
=
(
"R"
,
"ℝ"
)
,
mvOperation
=
"min"
,
mvDescription
=
"the monoid (R, min)"
,
mvTerm
=
"real"
}
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, ... '}'"
-- | The @(ℕ, and)^X@ functor
andWordValued
::
FunctorDescription
(
SlowMonoidValued
(
BitAnd
Word
))
andWordValued
=
FunctorDescription
{
name
=
"BitAnd-valued"
,
syntaxExample
=
"(N, and)^X"
,
description
=
Just
andWordHelp
,
functorExprParser
=
prefix
-- We need this try here, so that parenthesis can still be parsed as
-- normal if they don't contain exactly (N, and)
(
try
(
L
.
parens
((
L
.
symbol
"N"
<|>
L
.
symbol
"ℕ"
)
>>
L
.
comma
>>
L
.
symbol
"and"
)
)
>>
L
.
symbol
"^"
>>
pure
SlowMonoidValued
)
andWordValued
=
makeMonoidValued
$
MonoidValued
{
mvName
=
"BitAnd"
,
mvSet
=
(
"N"
,
"ℕ"
)
,
mvOperation
=
"and"
,
mvDescription
=
"bitvectors and bitwise 'and' as monoid weight"
,
mvTerm
=
"0xCAFE"
}
andWordHelp
::
Doc
.
Doc
Doc
.
AnsiStyle
andWordHelp
=
Doc
.
reflow
(
"Weighted systems with bitvectors and bitwise 'and' 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, and)^X"
<>
Doc
.
line
<>
Doc
.
line
<>
Doc
.
annotate
Doc
.
bold
"Coalgebra syntax:"
<+>
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
)
orWordValued
=
makeMonoidValued
$
MonoidValued
{
mvName
=
"BitOr"
,
mvSet
=
(
"N"
,
"ℕ"
)
,
mvOperation
=
"or"
,
mvDescription
=
"bitvectors and bitwise 'or' as monoid weight"
,
mvTerm
=
"0xCAFE"
}
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
...
...
@@ -306,41 +207,28 @@ instance (Monoid m, Ord m) => RefinementInterface (SlowMonoidValued m) where
instance
ParseMorphism
(
SlowMonoidValued
(
Max
Int
))
where
parseMorphismPoint
(
SlowMonoidValued
inner
)
=
parseMorphismPointHelper
inner
(
Max
<$>
(
L
.
signed
L
.
decimal
))
=<<
(
not
<$>
noSanityChecks
)
parseMorphismPoint
=
parseMorphismPointHelper
(
Max
<$>
(
L
.
signed
L
.
decimal
))
instance
ParseMorphism
(
SlowMonoidValued
(
Min
Int
))
where
parseMorphismPoint
(
SlowMonoidValued
inner
)
=
parseMorphismPointHelper
inner
(
Min
<$>
(
L
.
signed
L
.
decimal
))
=<<
(
not
<$>
noSanityChecks
)
parseMorphismPoint
=
parseMorphismPointHelper
(
Min
<$>
(
L
.
signed
L
.
decimal
))
instance
ParseMorphism
(
SlowMonoidValued
MaxDouble
)
where
parseMorphismPoint
(
SlowMonoidValued
inner
)
=
parseMorphismPointHelper
inner
(
MaxDouble
<$>
L
.
signed
L
.
float
)
=<<
(
not
<$>
noSanityChecks
)
parseMorphismPoint
=
parseMorphismPointHelper
(
MaxDouble
<$>
L
.
signed
L
.
float
)
instance
ParseMorphism
(
SlowMonoidValued
MinDouble
)
where
parseMorphismPoint
(
SlowMonoidValued
inner
)
=
parseMorphismPointHelper
inner
(
MinDouble
<$>
L
.
signed
L
.
float
)
=<<
(
not
<$>
noSanityChecks
)
parseMorphismPoint
=
parseMorphismPointHelper
(
MinDouble
<$>
L
.
signed
L
.
float
)
instance
ParseMorphism
(
SlowMonoidValued
(
BitAnd
Word
))
where
parseMorphismPoint
(
SlowMonoidValued
inner
)
=
parseMorphismPointHelper
inner
L
.
hex
=<<
(
not
<$>
noSanityChecks
)
parseMorphismPoint
=
parseMorphismPointHelper
L
.
hex
instance
ParseMorphism
(
SlowMonoidValued
(
BitOr
Word
))
where
parseMorphismPoint
(
SlowMonoidValued
inner
)
=
parseMorphismPointHelper
inner
L
.
hex
=<<
(
not
<$>
noSanityChecks
)
parseMorphismPoint
=
parseMorphismPointHelper
L
.
hex
parseMorphismPointHelper
::
(
HasSanityChecks
m
,
MonadParser
m
,
Ord
x
,
Monoid
w
)
=>
m
w
->
SlowMonoidValued
w
(
m
x
)
->
m
(
w
,
V
.
Vector
(
x
,
w
))
parseMorphismPointHelper
weightParser
(
SlowMonoidValued
inner
)
=
do
sanity
<-
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
True
->
do
succs
<-
V
.
sortOn
fst
.
V
.
fromList
<$>
L
.
braces
(
edge
`
sepBy
`
L
.
comma
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment