From 123bbbec73d682b95100f8879a984bdbdbba55e7 Mon Sep 17 00:00:00 2001
From: daniel <jcpetruzza@gmail.com>
Date: Thu, 30 Jan 2014 12:10:32 +0100
Subject: [PATCH] can now have top-level conjunctions and disjunctions
---
randcool/randcool.hs | 32 +++++++++++++++++++++++++++-----
1 file changed, 27 insertions(+), 5 deletions(-)
diff --git a/randcool/randcool.hs b/randcool/randcool.hs
index dfa9c89..96839b9 100644
--- a/randcool/randcool.hs
+++ b/randcool/randcool.hs
@@ -86,6 +86,8 @@ data RandConf
,minDis :: Nat -- min number of disjuncts per disjunction (0 allows for Bot)
,maxDis :: Nat -- max number of disjuncts per disjunction
,probAt :: Float -- probability of having an atom
+ ,topCon :: Bool -- allow conjunctions at the top level
+ ,topDis :: Bool -- allow disjunctions at the top level
}
@@ -114,19 +116,30 @@ someFormula modGen conf = go (depth conf)
lits
= let as = [1..1+numAts conf] in [top,bot] ++ map PAt as ++ map NAt as
+ juncts junct_type r = \f ->
+ do n <- inRange r
+ junct_type <$> exactly n f
+
formulaOfDepth d
- = do (m,junct,r) <- oneOf [(Dia,Con,(minCon conf,maxCon conf))
- ,(Box,Dis,(minDis conf,maxDis conf))]
- n <- inRange r
- m <$> modGen <*> (junct <$> exactly n (go d))
+ = do (diabox,xxjuncts) <- oneOf [(Dia,Con `juncts` (minCon conf,maxCon conf))
+ ,(Box,Dis `juncts` (minDis conf,maxDis conf))]
+ diabox <$> modGen <*> xxjuncts (go d)
+
p = max 0 $ min 1 $ probAt conf
go d
| d == 0
= oneOf lits
+
| d == depth conf
- = formulaOfDepth (d-1)
+ = let modal_form = formulaOfDepth (d-1)
+ in join $ oneOf $ concat
+ [ [modal_form]
+ , [Con `juncts` (minCon conf,maxCon conf) $ modal_form | topCon conf]
+ , [Dis `juncts` (minDis conf,maxDis conf) $ modal_form | topDis conf]
+ ]
+
| otherwise
= join $ fromFreqs [oneOf lits `withFreq` p
,formulaOfDepth (d-1) `withFreq` (1-p)]
@@ -252,6 +265,15 @@ randConf
<> help "Probability of an atom occurring instead of a modality"
<> showDefault
)
+ <*> flag True False
+ ( long "no-toplevel-conj"
+ <> help "Don't generate conjunctions at the top-level"
+ )
+ <*> flag True False
+ ( long "no-toplevel-disj"
+ <> help "Don't generate disjunctions at the top-level"
+ )
+
--
GitLab