-
Notifications
You must be signed in to change notification settings - Fork 1
/
Generate.hs
87 lines (77 loc) · 3.78 KB
/
Generate.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
module Trees.Generate (
genSynTree,
syntaxShape,
) where
import Test.QuickCheck (choose, Gen, oneof, shuffle, suchThat, elements)
import Test.QuickCheck.Gen (vectorOf)
import Trees.Types (SynTree(..), BinOp(..), allBinaryOperators)
import Trees.Helpers (collectLeaves, relabelShape, maxNodesForDepth, consecutiveNegations)
chooseList :: Bool -> [BinOp]
chooseList allowArrowOperators = if allowArrowOperators
then allBinaryOperators
else [And, Or]
randomList :: [c] -> [c] -> Integer -> Gen [c]
randomList availableLetters atLeastOccurring listLength = let
restLength = fromIntegral listLength - length atLeastOccurring
in do
randomRest <- vectorOf restLength (elements availableLetters)
shuffle (atLeastOccurring ++ randomRest)
genSynTree :: (Integer, Integer) -> Integer -> [c] -> Integer -> Bool -> Integer -> Gen (SynTree BinOp c)
genSynTree (minNodes, maxNodes) maxDepth availableLetters atLeastOccurring allowArrowOperators maxConsecutiveNegations =
if maxConsecutiveNegations /= 0
then do
nodes <- choose (minNodes, maxNodes)
sample <- syntaxShape nodes maxDepth allowArrowOperators True
`suchThat` \synTree ->
(fromIntegral (length (collectLeaves synTree)) >= atLeastOccurring) &&
consecutiveNegations synTree <= maxConsecutiveNegations
usedList <- randomList availableLetters (take (fromIntegral atLeastOccurring) availableLetters) $
fromIntegral $ length $ collectLeaves sample
return (relabelShape sample usedList )
else do
nodes <- choose (minNodes, maxNodes) `suchThat` odd
sample <- syntaxShape nodes maxDepth allowArrowOperators False
`suchThat` \synTree -> fromIntegral (length (collectLeaves synTree)) >= atLeastOccurring
usedList <- randomList availableLetters (take (fromIntegral atLeastOccurring) availableLetters) $
fromIntegral $ length $ collectLeaves sample
return (relabelShape sample usedList )
syntaxShape :: Integer -> Integer -> Bool -> Bool -> Gen (SynTree BinOp ())
syntaxShape nodes maxDepth allowArrowOperators allowNegation
| nodes == 1 = positiveLiteral
| nodes == 2 = negativeLiteral
| not allowNegation = oneof mapBinaryOperator
| maxNodesForDepth (maxDepth - 1) < nodes - 1 = oneof mapBinaryOperator
| otherwise = oneof $ negativeForm : mapBinaryOperator
where
mapBinaryOperator = map (binaryOperator nodes maxDepth allowArrowOperators allowNegation . Binary) $
chooseList allowArrowOperators
negativeForm = negativeFormula nodes maxDepth allowArrowOperators
binaryOperator
:: Integer
-> Integer
-> Bool -> Bool
-> (SynTree BinOp ()
-> SynTree BinOp ()
-> SynTree BinOp ())
-> Gen (SynTree BinOp ())
binaryOperator nodes maxDepth allowArrowOperators allowNegation operator =
let minNodesPerSide = max 1 (restNodes - maxNodesForDepth newMaxDepth)
restNodes = nodes - 1
newMaxDepth = maxDepth - 1
in do
leftNodes <- choose (minNodesPerSide , restNodes - minNodesPerSide)
`suchThat` \leftNodes -> allowNegation || odd leftNodes
leftTree <- syntaxShape leftNodes newMaxDepth allowArrowOperators allowNegation
rightTree <- syntaxShape (restNodes - leftNodes ) newMaxDepth allowArrowOperators allowNegation
return (operator leftTree rightTree)
negativeFormula :: Integer -> Integer -> Bool -> Gen (SynTree BinOp ())
negativeFormula nodes maxDepth allowArrowOperators =
let restNodes = nodes - 1
newMaxDepth = maxDepth - 1
in do
e <- syntaxShape restNodes newMaxDepth allowArrowOperators True
return (Not e)
negativeLiteral :: Gen (SynTree o ())
negativeLiteral = Not <$> positiveLiteral
positiveLiteral :: Gen (SynTree o ())
positiveLiteral = return (Leaf ())