never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2
3 module Conjure.Representations.MSet.ExplicitWithRepetition ( msetExplicitWithRepetition ) where
4
5 -- conjure
6 import Conjure.Prelude
7 import Conjure.Language
8 import Conjure.Language.DomainSizeOf
9 import Conjure.Language.Expression.DomainSizeOf ()
10 import Conjure.Language.ZeroVal ( zeroVal, EnumerateDomain )
11 import Conjure.Representations.Internal
12 import Conjure.Representations.Common
13
14
15 msetExplicitWithRepetition :: forall m . (MonadFailDoc m, NameGen m, EnumerateDomain m) => Representation m
16 msetExplicitWithRepetition = Representation chck downD structuralCons downC up symmetryOrdering
17
18 where
19
20 chck :: TypeOf_ReprCheck m
21 chck f (DomainMSet _ attrs innerDomain) =
22 map (DomainMSet MSet_ExplicitWithRepetition attrs) <$> f innerDomain
23 chck _ _ = return []
24
25 nameFlag = mkOutName (Just "Flag")
26 nameValues = mkOutName (Just "Values")
27
28 getMaxSize attrs innerDomain = case attrs of
29 MSetAttr (SizeAttr_Size x) _ -> return x
30 MSetAttr (SizeAttr_MaxSize x) _ -> return x
31 MSetAttr (SizeAttr_MinMaxSize _ x) _ -> return x
32 MSetAttr _ (OccurAttr_MaxOccur x) -> do y <- domainSizeOf innerDomain ; return (x * y)
33 MSetAttr _ (OccurAttr_MinMaxOccur _ x) -> do y <- domainSizeOf innerDomain ; return (x * y)
34 _ -> failDoc ("getMaxSize, mset not supported. attributes:" <+> pretty attrs)
35
36 getMinOccur attrs = case attrs of
37 MSetAttr _ (OccurAttr_MinOccur x) -> Just x
38 MSetAttr _ (OccurAttr_MinMaxOccur x _) -> Just x
39 _ -> Nothing
40
41 getMaxOccur attrs = case attrs of
42 MSetAttr _ (OccurAttr_MaxOccur x) -> return x
43 MSetAttr _ (OccurAttr_MinMaxOccur _ x) -> return x
44 _ -> failDoc ("getMaxOccur, mset not supported. attributes:" <+> pretty attrs)
45
46 downD :: TypeOf_DownD m
47 downD (name, domain@(DomainMSet _ attrs innerDomain)) = do
48 (indexDomain, flagDomain) <-
49 case attrs of
50 MSetAttr (SizeAttr_Size size) _ -> do
51 let indexDomain = mkDomainIntB 1 size
52 let flagDomain = defRepr $ DomainInt TagInt [RangeSingle size]
53 return (indexDomain, flagDomain)
54 _ -> do
55 maxSize <- getMaxSize attrs innerDomain
56 let indexDomain = mkDomainIntB 1 maxSize
57 let flagDomain = defRepr $ mkDomainIntB 0 maxSize
58 return (indexDomain, flagDomain)
59 return $ Just
60 [ ( nameFlag domain name
61 , flagDomain
62 )
63 , ( nameValues domain name
64 , DomainMatrix indexDomain innerDomain
65 )
66 ]
67 downD _ = na "{downD} ExplicitVarSizeWithRepetition"
68
69 structuralCons :: TypeOf_Structural m
70 structuralCons f downX1 (DomainMSet MSet_ExplicitWithRepetition attrs@(MSetAttr sizeAttrs _) innerDomain) = do
71 maxSize <- getMaxSize attrs innerDomain
72 let maxIndex = maxSize
73 let
74 orderingUpToFlag flag values = do
75 (iPat, i) <- quantifiedVar
76 return $ return $ -- list
77 [essence|
78 forAll &iPat : int(1..&maxIndex-1) , &i+1 <= &flag . &values[&i] .<= &values[&i+1]
79 |]
80
81 dontCareAfterFlag flag values = do
82 (iPat, i) <- quantifiedVar
83 return $ return $ -- list
84 [essence|
85 forAll &iPat : int(1..&maxIndex) , &i > &flag . dontCare(&values[&i])
86 |]
87
88 minOccurrenceCons mset = do
89 (iPat, i) <- quantifiedVar
90 return
91 [ [essence|
92 forAll &iPat : &innerDomain .
93 freq(&mset, &i) >= &minOccur
94 |]
95 | Just minOccur <- [getMinOccur attrs]
96 ]
97
98 maxOccurrenceCons mset flag values = do
99 (iPat, i) <- quantifiedVar
100 return
101 [ [essence|
102 forAll &iPat : int(1..&maxIndex) , &i <= &flag .
103 freq(&mset, &values[&i]) <= &maxOccur_
104 |]
105 | Just maxOccur_ <- [getMaxOccur attrs]
106 ]
107
108 innerStructuralCons flag values = do
109 (iPat, i) <- quantifiedVarOverDomain [essenceDomain| int(1..&maxIndex) |]
110 let activeZone b = [essence| forAll &iPat : int(1..&maxIndex) , &i <= &flag . &b |]
111
112 -- preparing structural constraints for the inner guys
113 innerStructuralConsGen <- f innerDomain
114
115 let inLoop = [essence| &values[&i] |]
116 outs <- innerStructuralConsGen inLoop
117 return (map activeZone outs)
118
119 return $ \ mset -> do
120 refs <- downX1 mset
121 case refs of
122 [flag, values] ->
123 concat <$> sequence
124 [ orderingUpToFlag flag values
125 , dontCareAfterFlag flag values
126 , minOccurrenceCons mset
127 , maxOccurrenceCons mset flag values
128 , return (mkSizeCons sizeAttrs flag)
129 , innerStructuralCons flag values
130 ]
131 _ -> na "{structuralCons} ExplicitVarSizeWithRepetition"
132
133 structuralCons _ _ _ = na "{structuralCons} ExplicitVarSizeWithRepetition"
134
135 downC :: TypeOf_DownC m
136 downC ( name
137 , domain@(DomainMSet _ attrs innerDomain)
138 , viewConstantMSet -> Just constants
139 ) = case attrs of
140 MSetAttr (SizeAttr_Size size) _ -> do
141 let indexDomain = mkDomainIntB 1 size
142 let flagDomain = DomainInt TagInt [RangeSingle size]
143
144 return $ Just
145 [ ( nameFlag domain name
146 , defRepr flagDomain
147 , ConstantInt TagInt (genericLength constants)
148 )
149 , ( nameValues domain name
150 , DomainMatrix indexDomain innerDomain
151 , ConstantAbstract $ AbsLitMatrix indexDomain constants
152 )
153 ]
154
155 _ -> do
156 maxSize <- getMaxSize attrs innerDomain
157 maxSizeInt <-
158 case maxSize of
159 ConstantInt _ x -> return x
160 _ -> failDoc $ vcat
161 [ "Expecting an integer for the maxSize attribute."
162 , "But got:" <+> pretty maxSize
163 , "When working on:" <+> pretty name
164 , "With domain:" <+> pretty domain
165 ]
166 let indexDomain = mkDomainIntB 1 maxSize
167 let flagDomain = mkDomainIntB 0 maxSize
168
169 z <- zeroVal innerDomain
170 let zeroes = replicate (fromInteger (maxSizeInt - genericLength constants)) z
171
172 return $ Just
173 [ ( nameFlag domain name
174 , defRepr flagDomain
175 , ConstantInt TagInt (genericLength constants)
176 )
177 , ( nameValues domain name
178 , DomainMatrix indexDomain innerDomain
179 , ConstantAbstract $ AbsLitMatrix indexDomain (constants ++ zeroes)
180 )
181 ]
182
183 downC _ = na "{downC} ExplicitVarSizeWithRepetition"
184
185 up :: TypeOf_Up m
186 up ctxt (name, domain) =
187 case (lookup (nameFlag domain name) ctxt, lookup (nameValues domain name) ctxt) of
188 (Just flag, Just constantMatrix) ->
189 case viewConstantInt flag of
190 -- TODO: check if indices match
191 Just flagInt ->
192 case viewConstantMatrix constantMatrix of
193 Just (_, vals) ->
194 return (name, ConstantAbstract $ AbsLitMSet
195 (genericTake flagInt vals) )
196 _ -> failDoc $ vcat
197 [ "Expecting a matrix literal for:" <+> pretty (nameValues domain name)
198 , "But got:" <+> pretty constantMatrix
199 , "When working on:" <+> pretty name
200 , "With domain:" <+> pretty domain
201 ]
202 _ -> failDoc $ vcat
203 [ "Expecting an integer literal for:" <+> pretty (nameFlag domain name)
204 , "But got:" <+> pretty flag
205 , "When working on:" <+> pretty name
206 , "With domain:" <+> pretty domain
207 ]
208 (Nothing, _) -> failDoc $ vcat $
209 [ "(in MSet ExplicitVarSizeWithRepetition up 1)"
210 , "No value for:" <+> pretty (nameFlag domain name)
211 , "When working on:" <+> pretty name
212 , "With domain:" <+> pretty domain
213 ] ++
214 ("Bindings in context:" : prettyContext ctxt)
215 (_, Nothing) -> failDoc $ vcat $
216 [ "(in MSet ExplicitVarSizeWithRepetition up 2)"
217 , "No value for:" <+> pretty (nameValues domain name)
218 , "When working on:" <+> pretty name
219 , "With domain:" <+> pretty domain
220 ] ++
221 ("Bindings in context:" : prettyContext ctxt)
222
223 symmetryOrdering :: TypeOf_SymmetryOrdering m
224 symmetryOrdering innerSO downX1 inp domain = do
225 [marker, values] <- downX1 inp
226 Just [_, (_, DomainMatrix index inner)] <- downD ("SO", domain)
227 (iPat, i) <- quantifiedVar
228 soValues <- innerSO downX1 [essence| &values[&i] |] inner
229 return
230 [essence|
231 ( &marker
232 , [ &soValues
233 | &iPat : &index
234 ]
235 )
236 |]
237