Commit dda4b114 authored by Paul Ogris's avatar Paul Ogris
Browse files

Add support for constraints

parent b88066d0
......@@ -67,7 +67,10 @@ instance Pretty Rule where
<+> PP.hcat (PP.punctuate (PP.comma <> PP.space) (map PP.pretty bs))
<> PP.dot
data Head = HeadAtom Atom | HeadChoice (Maybe Int) (NonEmpty Atom) [Atom] (Maybe Int)
data Head
= HeadAtom Atom
| HeadChoice (Maybe Int) (NonEmpty Atom) [Atom] (Maybe Int)
| HeadFalse
deriving (Eq, Show, Ord, Read)
instance Pretty Head where
......@@ -85,6 +88,7 @@ instance Pretty Head where
_ -> PP.colon <+> PP.hcat
(PP.punctuate (PP.comma <> PP.space) (fmap PP.textStrict b))
in maybe mempty PP.int l <+> set <+> maybe mempty PP.int u
pretty HeadFalse = mempty
instance IsString Head where
fromString s = HeadAtom (pack s)
......@@ -142,7 +146,7 @@ rule =
Rule <$> head_ <*> option [] (ruleIf *> bodyElement `sepBy1` comma) <* dot
head_ :: Parser Head
head_ = (HeadAtom <$> atom) <|> choice_
head_ = (HeadAtom <$> atom) <|> choice_ <|> pure HeadFalse
where
choice_ = do
l <- optional (lexeme L.decimal)
......
......@@ -5,7 +5,7 @@ import Data.Maybe ( mapMaybe )
import Data.Foldable ( toList )
relax :: [Statement] -> [Statement]
relax = map normalRules . concatMap splitChoices
relax = map normalRules . concatMap splitChoices . filter (not . isConstraint)
where
normalRules (StmtRule (Rule h@HeadAtom{} bs)) =
StmtRule (Rule h (mapMaybe removeNegation bs))
......@@ -17,6 +17,9 @@ relax = map normalRules . concatMap splitChoices
pure $ Rule (HeadAtom h) bs'
splitChoices x = [x]
isConstraint (StmtRule (Rule HeadFalse _)) = True
isConstraint _ = False
removeNegation :: BodyElement -> Maybe BodyElement
removeNegation (BodyAtom (Negative _)) = Nothing
removeNegation (BodyAtom (Positive x)) = Just (BodyAtom (Positive x))
......
pigeon(1..5). hole(1..4).
1 { place(P,H) : hole(H) } 1 :- pigeon(P).
:- place(P1,H), place(P2,H), P1 == P2.
......@@ -64,6 +64,9 @@ pprint = parallel $ do
it "pretty prints choices with guards"
$ prettyOneLine (HeadChoice (Just 1) ["a", "b"] [] (Just 1))
`shouldBe` "1 {a; b} 1"
it "pretty prints constraints"
$ prettyOneLine (Rule HeadFalse [BodyAtom (Positive "a")])
`shouldBe` ":- a."
parser :: Spec
parser = parallel $ do
......@@ -106,3 +109,6 @@ parser = parallel $ do
it "parses choices with guards"
$ parse head_ "" "1 { a; b } 1"
`shouldParse` HeadChoice (Just 1) ["a", "b"] [] (Just 1)
it "parses constraints" $ parse rule "" ":- a." `shouldParse` Rule
HeadFalse
[BodyAtom (Positive "a")]
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