never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2 {-# LANGUAGE UndecidableInstances #-}
3
4 module Conjure.Compute.DomainOf ( DomainOf(..), domainOfR ) where
5
6 -- conjure
7 import Conjure.Prelude
8 import Conjure.Bug
9
10 import Conjure.Language
11 import Conjure.Language.RepresentationOf ( RepresentationOf(..) )
12 import Conjure.Compute.DomainUnion
13
14
15 type Dom = Domain () Expression
16
17 class DomainOf a where
18
19 -- | calculate the domain of `a`
20 domainOf ::
21 MonadFailDoc m =>
22 NameGen m =>
23 (?typeCheckerMode :: TypeCheckerMode) =>
24 a -> m Dom
25
26 -- | calculate the index domains of `a`
27 -- the index is the index of a matrix.
28 -- returns [] for non-matrix inputs.
29 -- has a default implementation in terms of domainOf, so doesn't need to be implemented specifically.
30 -- but sometimes it is better to implement this directly.
31 indexDomainsOf ::
32 MonadFailDoc m =>
33 NameGen m =>
34 Pretty a =>
35 (?typeCheckerMode :: TypeCheckerMode) =>
36 a -> m [Dom]
37 indexDomainsOf = defIndexDomainsOf
38
39
40 domainOfR ::
41 DomainOf a =>
42 RepresentationOf a =>
43 MonadFailDoc m =>
44 NameGen m =>
45 (?typeCheckerMode :: TypeCheckerMode) =>
46 a -> m (Domain HasRepresentation Expression)
47 domainOfR inp = do
48 dom <- domainOf inp
49 rTree <- representationTreeOf inp
50 applyReprTree dom rTree
51
52
53 defIndexDomainsOf ::
54 MonadFailDoc m =>
55 NameGen m =>
56 DomainOf a =>
57 (?typeCheckerMode :: TypeCheckerMode) =>
58 a -> m [Dom]
59 defIndexDomainsOf x = do
60 dom <- domainOf x
61 let
62 collect (DomainMatrix index inner) = index : collect inner
63 collect _ = []
64 return (collect dom)
65
66 instance DomainOf ReferenceTo where
67 domainOf (Alias x) = domainOf x
68 domainOf (InComprehension (GenDomainNoRepr Single{} dom)) = return dom
69 domainOf (InComprehension (GenDomainHasRepr _ dom)) = return (forgetRepr dom)
70 domainOf (InComprehension (GenInExpr Single{} x)) = domainOf x >>= innerDomainOf
71 domainOf x@InComprehension{} = failDoc $ vcat [ "domainOf-ReferenceTo-InComprehension", pretty x, pretty (show x) ]
72 domainOf (DeclNoRepr _ _ dom _) = return dom
73 domainOf (DeclHasRepr _ _ dom ) = return (forgetRepr dom)
74 domainOf RecordField{} = failDoc "domainOf-ReferenceTo-RecordField"
75 domainOf VariantField{} = failDoc "domainOf-ReferenceTo-VariantField"
76
77
78 instance DomainOf Expression where
79 domainOf (Reference _ (Just refTo)) = domainOf refTo
80 domainOf (Constant x) = domainOf x
81 domainOf (AbstractLiteral x) = domainOf x
82 domainOf (Op x) = domainOf x
83 domainOf (WithLocals h _) = domainOf h
84 domainOf (Comprehension h _) = do
85 domH <- domainOf h
86 return $ DomainMatrix (DomainInt TagInt [RangeLowerBounded 1]) domH
87 domainOf x = failDoc ("domainOf{Expression}:" <+> pretty (show x))
88
89 -- if an empty matrix literal has a type annotation
90 indexDomainsOf (Typed lit ty) | emptyCollectionX lit =
91 let
92 tyToDom (TypeMatrix (TypeInt nm) t) = DomainInt nm [RangeBounded 1 0] : tyToDom t
93 tyToDom _ = []
94 in
95 return (tyToDom ty)
96
97 indexDomainsOf (Reference _ (Just refTo)) = indexDomainsOf refTo
98 indexDomainsOf (Constant x) = indexDomainsOf x
99 indexDomainsOf (AbstractLiteral x) = indexDomainsOf x
100 indexDomainsOf (Op x) = indexDomainsOf x
101 indexDomainsOf (WithLocals h _) = indexDomainsOf h
102 indexDomainsOf x@(Comprehension h [Generator gen]) = do
103 TypeMatrix{} <- typeOf x
104 index <- case gen of
105 GenDomainNoRepr _ d -> return d
106 GenDomainHasRepr _ d -> return (forgetRepr d)
107 _ -> failDoc "indexDomainsOf: expected a domain generator"
108 innerIndices <- indexDomainsOf h
109 let positionalIndex = case index of
110 DomainInt tag _ -> DomainInt tag
111 [RangeBounded (Constant (ConstantInt tag 1)) (make opTwoBars (Domain index))]
112 _ -> index
113 return $ positionalIndex : innerIndices
114 indexDomainsOf x = failDoc ("indexDomainsOf{Expression}:" <+> pretty (show x))
115
116 -- this should be better implemented by some ghc-generics magic
117 instance (DomainOf x, TypeOf x, Pretty x, ExpressionLike x, Domain () x :< x, Dom :< x) => DomainOf (Op x) where
118 domainOf (MkOpActive x) = domainOf x
119 domainOf (MkOpAllDiff x) = domainOf x
120 domainOf (MkOpAllDiffExcept x) = domainOf x
121 domainOf (MkOpAnd x) = domainOf x
122 domainOf (MkOpApart x) = domainOf x
123 domainOf (MkOpCompose x) = domainOf x
124 domainOf (MkOpAtLeast x) = domainOf x
125 domainOf (MkOpAtMost x) = domainOf x
126 domainOf (MkOpAttributeAsConstraint x) = domainOf x
127 domainOf (MkOpCatchUndef x) = domainOf x
128 domainOf (MkOpDefined x) = domainOf x
129 domainOf (MkOpDiv x) = domainOf x
130 domainOf (MkOpDontCare x) = domainOf x
131 domainOf (MkOpDotLeq x) = domainOf x
132 domainOf (MkOpDotLt x) = domainOf x
133 domainOf (MkOpEq x) = domainOf x
134 domainOf (MkOpElementId x) = domainOf x
135 domainOf (MkOpFactorial x) = domainOf x
136 domainOf (MkOpFlatten x) = domainOf x
137 domainOf (MkOpFreq x) = domainOf x
138 domainOf (MkOpGCC x) = domainOf x
139 domainOf (MkOpGeq x) = domainOf x
140 domainOf (MkOpGt x) = domainOf x
141 domainOf (MkOpHist x) = domainOf x
142 domainOf (MkOpIff x) = domainOf x
143 domainOf (MkOpImage x) = domainOf x
144 domainOf (MkOpImageSet x) = domainOf x
145 domainOf (MkOpImply x) = domainOf x
146 domainOf (MkOpIn x) = domainOf x
147 domainOf (MkOpIndexing x) = domainOf x
148 domainOf (MkOpIntersect x) = domainOf x
149 domainOf (MkOpInverse x) = domainOf x
150 domainOf (MkOpLeq x) = domainOf x
151 domainOf (MkOpLexLeq x) = domainOf x
152 domainOf (MkOpLexLt x) = domainOf x
153 domainOf (MkOpLt x) = domainOf x
154 domainOf (MkOpMakeTable x) = domainOf x
155 domainOf (MkOpMax x) = domainOf x
156 domainOf (MkOpMin x) = domainOf x
157 domainOf (MkOpMinus x) = domainOf x
158 domainOf (MkOpMod x) = domainOf x
159 domainOf (MkOpNegate x) = domainOf x
160 domainOf (MkOpNeq x) = domainOf x
161 domainOf (MkOpNot x) = domainOf x
162 domainOf (MkOpOr x) = domainOf x
163 domainOf (MkOpParticipants x) = domainOf x
164 domainOf (MkOpParts x) = domainOf x
165 domainOf (MkOpParty x) = domainOf x
166 domainOf (MkOpPermInverse x) = domainOf x
167 domainOf (MkOpPow x) = domainOf x
168 domainOf (MkOpPowerSet x) = domainOf x
169 domainOf (MkOpPred x) = domainOf x
170 domainOf (MkOpPreImage x) = domainOf x
171 domainOf (MkOpProduct x) = domainOf x
172 domainOf (MkOpRange x) = domainOf x
173 domainOf (MkOpRelationProj x) = domainOf x
174 domainOf (MkOpRestrict x) = domainOf x
175 domainOf (MkOpSlicing x) = domainOf x
176 domainOf (MkOpSubsequence x) = domainOf x
177 domainOf (MkOpSubset x) = domainOf x
178 domainOf (MkOpSubsetEq x) = domainOf x
179 domainOf (MkOpSubstring x) = domainOf x
180 domainOf (MkOpSucc x) = domainOf x
181 domainOf (MkOpSum x) = domainOf x
182 domainOf (MkOpSupset x) = domainOf x
183 domainOf (MkOpSupsetEq x) = domainOf x
184 domainOf (MkOpTable x) = domainOf x
185 domainOf (MkOpTildeLeq x) = domainOf x
186 domainOf (MkOpTildeLt x) = domainOf x
187 domainOf (MkOpTogether x) = domainOf x
188 domainOf (MkOpToInt x) = domainOf x
189 domainOf (MkOpToMSet x) = domainOf x
190 domainOf (MkOpToRelation x) = domainOf x
191 domainOf (MkOpToSet x) = domainOf x
192 domainOf (MkOpTransform x) = domainOf x
193 domainOf (MkOpTrue x) = domainOf x
194 domainOf (MkOpTwoBars x) = domainOf x
195 domainOf (MkOpUnion x) = domainOf x
196 domainOf (MkOpXor x) = domainOf x
197 domainOf (MkOpPermutationOrderAfterRepresentation x) = domainOf x
198 domainOf (MkOpPermutationOrder x) = domainOf x
199 domainOf (MkOpApplySymmetries x) = domainOf x
200
201 indexDomainsOf (MkOpActive x) = indexDomainsOf x
202 indexDomainsOf (MkOpAllDiff x) = indexDomainsOf x
203 indexDomainsOf (MkOpAllDiffExcept x) = indexDomainsOf x
204 indexDomainsOf (MkOpAnd x) = indexDomainsOf x
205 indexDomainsOf (MkOpApart x) = indexDomainsOf x
206 indexDomainsOf (MkOpCompose x) = indexDomainsOf x
207 indexDomainsOf (MkOpAtLeast x) = indexDomainsOf x
208 indexDomainsOf (MkOpAtMost x) = indexDomainsOf x
209 indexDomainsOf (MkOpAttributeAsConstraint x) = indexDomainsOf x
210 indexDomainsOf (MkOpCatchUndef x) = indexDomainsOf x
211 indexDomainsOf (MkOpDefined x) = indexDomainsOf x
212 indexDomainsOf (MkOpDiv x) = indexDomainsOf x
213 indexDomainsOf (MkOpDontCare x) = indexDomainsOf x
214 indexDomainsOf (MkOpDotLeq x) = indexDomainsOf x
215 indexDomainsOf (MkOpDotLt x) = indexDomainsOf x
216 indexDomainsOf (MkOpEq x) = indexDomainsOf x
217 indexDomainsOf (MkOpElementId x) = indexDomainsOf x
218 indexDomainsOf (MkOpFactorial x) = indexDomainsOf x
219 indexDomainsOf (MkOpFlatten x) = indexDomainsOf x
220 indexDomainsOf (MkOpFreq x) = indexDomainsOf x
221 indexDomainsOf (MkOpGCC x) = indexDomainsOf x
222 indexDomainsOf (MkOpGeq x) = indexDomainsOf x
223 indexDomainsOf (MkOpGt x) = indexDomainsOf x
224 indexDomainsOf (MkOpHist x) = indexDomainsOf x
225 indexDomainsOf (MkOpIff x) = indexDomainsOf x
226 indexDomainsOf (MkOpImage x) = indexDomainsOf x
227 indexDomainsOf (MkOpImageSet x) = indexDomainsOf x
228 indexDomainsOf (MkOpImply x) = indexDomainsOf x
229 indexDomainsOf (MkOpIn x) = indexDomainsOf x
230 indexDomainsOf (MkOpIndexing x) = indexDomainsOf x
231 indexDomainsOf (MkOpIntersect x) = indexDomainsOf x
232 indexDomainsOf (MkOpInverse x) = indexDomainsOf x
233 indexDomainsOf (MkOpLeq x) = indexDomainsOf x
234 indexDomainsOf (MkOpLexLeq x) = indexDomainsOf x
235 indexDomainsOf (MkOpLexLt x) = indexDomainsOf x
236 indexDomainsOf (MkOpLt x) = indexDomainsOf x
237 indexDomainsOf (MkOpMakeTable x) = indexDomainsOf x
238 indexDomainsOf (MkOpMax x) = indexDomainsOf x
239 indexDomainsOf (MkOpMin x) = indexDomainsOf x
240 indexDomainsOf (MkOpMinus x) = indexDomainsOf x
241 indexDomainsOf (MkOpMod x) = indexDomainsOf x
242 indexDomainsOf (MkOpNegate x) = indexDomainsOf x
243 indexDomainsOf (MkOpNeq x) = indexDomainsOf x
244 indexDomainsOf (MkOpNot x) = indexDomainsOf x
245 indexDomainsOf (MkOpOr x) = indexDomainsOf x
246 indexDomainsOf (MkOpParticipants x) = indexDomainsOf x
247 indexDomainsOf (MkOpParts x) = indexDomainsOf x
248 indexDomainsOf (MkOpParty x) = indexDomainsOf x
249 indexDomainsOf (MkOpPermInverse x) = indexDomainsOf x
250 indexDomainsOf (MkOpPow x) = indexDomainsOf x
251 indexDomainsOf (MkOpPowerSet x) = indexDomainsOf x
252 indexDomainsOf (MkOpPred x) = indexDomainsOf x
253 indexDomainsOf (MkOpPreImage x) = indexDomainsOf x
254 indexDomainsOf (MkOpProduct x) = indexDomainsOf x
255 indexDomainsOf (MkOpRange x) = indexDomainsOf x
256 indexDomainsOf (MkOpRelationProj x) = indexDomainsOf x
257 indexDomainsOf (MkOpRestrict x) = indexDomainsOf x
258 indexDomainsOf (MkOpSlicing x) = indexDomainsOf x
259 indexDomainsOf (MkOpSubsequence x) = indexDomainsOf x
260 indexDomainsOf (MkOpSubset x) = indexDomainsOf x
261 indexDomainsOf (MkOpSubsetEq x) = indexDomainsOf x
262 indexDomainsOf (MkOpSubstring x) = indexDomainsOf x
263 indexDomainsOf (MkOpSucc x) = indexDomainsOf x
264 indexDomainsOf (MkOpSum x) = indexDomainsOf x
265 indexDomainsOf (MkOpSupset x) = indexDomainsOf x
266 indexDomainsOf (MkOpSupsetEq x) = indexDomainsOf x
267 indexDomainsOf (MkOpTable x) = indexDomainsOf x
268 indexDomainsOf (MkOpTildeLeq x) = indexDomainsOf x
269 indexDomainsOf (MkOpTildeLt x) = indexDomainsOf x
270 indexDomainsOf (MkOpTogether x) = indexDomainsOf x
271 indexDomainsOf (MkOpToInt x) = indexDomainsOf x
272 indexDomainsOf (MkOpToMSet x) = indexDomainsOf x
273 indexDomainsOf (MkOpToRelation x) = indexDomainsOf x
274 indexDomainsOf (MkOpToSet x) = indexDomainsOf x
275 indexDomainsOf (MkOpTransform (OpTransform _ x)) = indexDomainsOf x
276 indexDomainsOf (MkOpTrue x) = indexDomainsOf x
277 indexDomainsOf (MkOpTwoBars x) = indexDomainsOf x
278 indexDomainsOf (MkOpUnion x) = indexDomainsOf x
279 indexDomainsOf (MkOpXor x) = indexDomainsOf x
280 indexDomainsOf (MkOpPermutationOrderAfterRepresentation x) = indexDomainsOf x
281 indexDomainsOf (MkOpPermutationOrder x) = indexDomainsOf x
282 indexDomainsOf (MkOpApplySymmetries x) = indexDomainsOf x
283
284 instance DomainOf Constant where
285 domainOf ConstantBool{} = return DomainBool
286 domainOf i@(ConstantInt t _) = return $ DomainInt t [RangeSingle (Constant i)]
287 domainOf (ConstantEnum defn _ _ ) = return (DomainEnum defn Nothing Nothing)
288 domainOf ConstantField{} = failDoc "DomainOf-ConstantField"
289 domainOf (ConstantAbstract x) = domainOf (fmap Constant x)
290 domainOf (DomainInConstant dom) = return (fmap Constant dom)
291 domainOf (TypedConstant x ty) = domainOf (Typed (Constant x) ty)
292 domainOf ConstantUndefined{} = failDoc "DomainOf-ConstantUndefined"
293
294 indexDomainsOf ConstantBool{} = return []
295 indexDomainsOf ConstantInt{} = return []
296 indexDomainsOf ConstantEnum{} = return []
297 indexDomainsOf ConstantField{} = return []
298 indexDomainsOf (ConstantAbstract x) = indexDomainsOf (fmap Constant x)
299 indexDomainsOf DomainInConstant{} = return []
300 indexDomainsOf (TypedConstant x ty) = indexDomainsOf (Typed (Constant x) ty)
301 indexDomainsOf ConstantUndefined{} = return []
302
303 instance DomainOf (AbstractLiteral Expression) where
304
305 domainOf (AbsLitTuple xs) = DomainTuple <$> mapM domainOf xs
306
307 domainOf (AbsLitRecord xs) = DomainRecord <$> sequence [ do t <- domainOf x ; return (n,t)
308 | (n,x) <- xs ]
309
310 domainOf (AbsLitVariant Nothing _ _) = failDoc "Cannot calculate the domain of variant literal."
311 domainOf (AbsLitVariant (Just t) _ _) = return (DomainVariant t)
312
313 domainOf (AbsLitMatrix ind inn ) = DomainMatrix ind <$> (domainUnions =<< mapM domainOf inn)
314
315 domainOf (AbsLitSet [] ) = return $ DomainSet def attr (DomainAny "domainOf-AbsLitSet-[]" TypeAny)
316 where attr = SetAttr (SizeAttr_Size 0)
317 domainOf (AbsLitSet xs ) = DomainSet def attr <$> (domainUnions =<< mapM domainOf xs)
318 where attr = SetAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs)
319
320 domainOf (AbsLitMSet [] ) = return $ DomainMSet def attr (DomainAny "domainOf-AbsLitMSet-[]" TypeAny)
321 where attr = MSetAttr (SizeAttr_Size 0) OccurAttr_None
322 domainOf (AbsLitMSet xs ) = DomainMSet def attr <$> (domainUnions =<< mapM domainOf xs)
323 where attr = MSetAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs) OccurAttr_None
324
325 domainOf (AbsLitFunction [] ) = return $ DomainFunction def attr
326 (DomainAny "domainOf-AbsLitFunction-[]-1" TypeAny)
327 (DomainAny "domainOf-AbsLitFunction-[]-2" TypeAny)
328 where attr = FunctionAttr (SizeAttr_Size 0) def def
329 domainOf (AbsLitFunction xs ) = DomainFunction def attr
330 <$> (domainUnions =<< mapM (domainOf . fst) xs)
331 <*> (domainUnions =<< mapM (domainOf . snd) xs)
332 where attr = FunctionAttr (SizeAttr_MaxSize $ fromInt $ genericLength xs) def def
333
334 domainOf (AbsLitSequence [] ) = return $ DomainSequence def attr
335 (DomainAny "domainOf-AbsLitSequence-[]" TypeAny)
336 where attr = SequenceAttr (SizeAttr_Size 0) def
337 domainOf (AbsLitSequence xs ) = DomainSequence def attr
338 <$> (domainUnions =<< mapM domainOf xs)
339 where attr = SequenceAttr (SizeAttr_MaxSize (fromInt $ genericLength xs)) def
340
341 domainOf (AbsLitRelation [] ) = return $ DomainRelation def attr []
342 where attr = RelationAttr (SizeAttr_Size 0) def
343 domainOf (AbsLitRelation xss) = do
344 ty <- domainUnions =<< mapM (domainOf . AbsLitTuple) xss
345 case ty of
346 DomainTuple ts -> return (DomainRelation def attr ts)
347 _ -> bug "expecting DomainTuple in domainOf"
348 where attr = RelationAttr (SizeAttr_MaxSize (fromInt $ genericLength xss)) def
349
350 domainOf (AbsLitPartition [] ) = return $ DomainPartition def attr
351 (DomainAny "domainOf-AbsLitPartition-[]" TypeAny)
352 where attr = PartitionAttr (SizeAttr_Size 0) (SizeAttr_Size 0) False
353 domainOf (AbsLitPartition xss) = DomainPartition def attr <$> (domainUnions =<< mapM domainOf (concat xss))
354 where attr = PartitionAttr (SizeAttr_MaxSize (fromInt $ genericLength xss))
355 (SizeAttr_MaxSize (fromInt $ maximum [genericLength xs | xs <- xss]))
356 False
357 domainOf (AbsLitPermutation [] ) = return $ DomainPermutation def (PermutationAttr SizeAttr_None) (DomainAny "domainOf-AbsLitPermutation-[]" TypeAny)
358 domainOf (AbsLitPermutation xss) = DomainPermutation def (PermutationAttr SizeAttr_None) <$> (domainUnions =<< mapM domainOf (concat xss))
359
360 indexDomainsOf (AbsLitMatrix ind inn) = do
361 innerIndices <- mapM indexDomainsOf inn
362 if all null innerIndices
363 then return [ind]
364 else (ind :) <$> (mapM domainUnions innerIndices)
365 indexDomainsOf _ = return []
366
367
368
369
370 -- all the `Op`s
371
372 instance DomainOf (OpActive x) where
373 domainOf _ = return DomainBool
374
375 instance DomainOf (OpAllDiff x) where
376 domainOf _ = return DomainBool
377
378 instance DomainOf (OpAllDiffExcept x) where
379 domainOf _ = return DomainBool
380
381 instance DomainOf x => DomainOf (OpCatchUndef x) where
382 domainOf (OpCatchUndef x _) = domainOf x
383
384 instance DomainOf (OpAnd x) where
385 domainOf _ = return DomainBool
386
387 instance DomainOf (OpApart x) where
388 domainOf _ = return DomainBool
389
390 instance DomainOf (OpAttributeAsConstraint x) where
391 domainOf _ = return DomainBool
392
393 instance DomainOf x => DomainOf (OpDefined x) where
394 domainOf (OpDefined f) = do
395 fDom <- domainOf f
396 case fDom of
397 DomainFunction _ _ fr _ -> return $ DomainSet def def fr
398 _ -> failDoc "domainOf, OpDefined, not a function"
399
400 instance DomainOf x => DomainOf (OpDiv x) where
401 domainOf (OpDiv x y) = do
402 xDom :: Dom <- domainOf x
403 yDom :: Dom <- domainOf y
404 (iPat, i) <- quantifiedVar
405 (jPat, j) <- quantifiedVar
406 let vals = [essence| [ &i / &j
407 | &iPat : &xDom
408 , &jPat : &yDom
409 ] |]
410 let low = [essence| min(&vals) |]
411 let upp = [essence| max(&vals) |]
412 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
413
414 instance DomainOf (OpDontCare x) where
415 domainOf _ = return DomainBool
416
417 instance DomainOf (OpDotLeq x) where
418 domainOf _ = return DomainBool
419
420 instance DomainOf (OpDotLt x) where
421 domainOf _ = return DomainBool
422
423 instance DomainOf (OpEq x) where
424 domainOf _ = return DomainBool
425
426 instance (Pretty x, TypeOf x) => DomainOf (OpFactorial x) where
427 domainOf op = mkDomainAny ("OpFactorial:" <++> pretty op) <$> typeOf op
428
429 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpFlatten x) where
430 domainOf (OpFlatten (Just 1) x) = domainOf x >>= innerDomainOf
431 domainOf op = mkDomainAny ("OpFlatten:" <++> pretty op) <$> typeOf op
432
433 instance (Pretty x, TypeOf x) => DomainOf (OpFreq x) where
434 domainOf op = mkDomainAny ("OpFreq:" <++> pretty op) <$> typeOf op
435
436 instance DomainOf (OpGeq x) where
437 domainOf _ = return DomainBool
438
439 instance DomainOf (OpGt x) where
440 domainOf _ = return DomainBool
441
442 instance (Pretty x, TypeOf x) => DomainOf (OpHist x) where
443 domainOf op = mkDomainAny ("OpHist:" <++> pretty op) <$> typeOf op
444
445 instance DomainOf (OpIff x) where
446 domainOf _ = return DomainBool
447
448 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpImage x) where
449 domainOf (OpImage f _) = do
450 fDomain <- domainOf f
451 case fDomain of
452 DomainFunction _ _ _ to -> return to
453 DomainSequence _ _ to -> return to
454 DomainPermutation _ _ ov -> return ov
455 _ -> failDoc "domainOf, OpImage, not a function, sequence or permutation"
456
457 instance (Pretty x, TypeOf x) => DomainOf (OpImageSet x) where
458 domainOf op = mkDomainAny ("OpImageSet:" <++> pretty op) <$> typeOf op
459
460 instance DomainOf (OpImply x) where
461 domainOf _ = return DomainBool
462
463 instance DomainOf (OpIn x) where
464 domainOf _ = return DomainBool
465
466 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x) => DomainOf (OpElementId x) where
467 domainOf (OpElementId m i) = do
468 iType <- typeOf i
469 case iType of
470 TypeBool{} -> return ()
471 TypeInt{} -> return ()
472 TypeMatrix{} -> return ()
473 _ -> failDoc "domainOf, OpElementId, not a bool or int index"
474 mDom <- domainOf m
475 case mDom of
476 DomainMatrix _ inner -> return inner
477 _ -> failDoc "domainOf, OpElementId, not a matrix or tuple"
478
479 indexDomainsOf p@(OpElementId m i) = do
480 iType <- typeOf i
481 case iType of
482 TypeBool{} -> return ()
483 TypeInt{} -> return ()
484 TypeMatrix{} -> return ()
485 _ -> failDoc "domainOf, OpElementId, not a bool or int index"
486 is <- indexDomainsOf m
487 case is of
488 [] -> failDoc ("indexDomainsOf{OpElementId}, not a matrix domain:" <++> pretty p)
489 (_:is') -> return is'
490
491 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x) => DomainOf (OpIndexing x) where
492 domainOf (OpIndexing m i) = do
493 iType <- typeOf i
494 case iType of
495 TypeBool{} -> return ()
496 TypeInt{} -> return ()
497 TypeMatrix{} -> return ()
498 _ -> failDoc "domainOf, OpIndexing, not a bool or int index"
499 mDom <- domainOf m
500 case mDom of
501 DomainMatrix _ inner -> return inner
502 DomainTuple inners -> do
503 iInt <- intOut "domainOf OpIndexing" i
504 return $ atNote "domainOf" inners (fromInteger (iInt-1))
505 _ -> failDoc "domainOf, OpIndexing, not a matrix or tuple"
506
507 indexDomainsOf p@(OpIndexing m i) = do
508 iType <- typeOf i
509 case iType of
510 TypeBool{} -> return ()
511 TypeInt{} -> return ()
512 TypeMatrix{} -> return ()
513 _ -> failDoc "domainOf, OpIndexing, not a bool or int index"
514 is <- indexDomainsOf m
515 case is of
516 [] -> failDoc ("indexDomainsOf{OpIndexing}, not a matrix domain:" <++> pretty p)
517 (_:is') -> return is'
518
519 instance (Pretty x, TypeOf x) => DomainOf (OpIntersect x) where
520 domainOf op = mkDomainAny ("OpIntersect:" <++> pretty op) <$> typeOf op
521
522 instance DomainOf (OpInverse x) where
523 domainOf _ = return DomainBool
524
525 instance DomainOf (OpLeq x) where
526 domainOf _ = return DomainBool
527
528 instance DomainOf (OpLexLeq x) where
529 domainOf _ = return DomainBool
530
531 instance DomainOf (OpLexLt x) where
532 domainOf _ = return DomainBool
533
534 instance DomainOf (OpLt x) where
535 domainOf _ = return DomainBool
536
537 instance DomainOf (OpMakeTable x) where
538 domainOf _ = return DomainBool
539
540 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x, Domain () x :< x) => DomainOf (OpMax x) where
541 domainOf (OpMax x)
542 | Just xs <- listOut x
543 , not (null xs) = do
544 doms <- mapM domainOf xs
545 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
546 let low = [essence| max(&lows) |]
547 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
548 let upp = [essence| max(&upps) |]
549 case doms of
550 [] -> bug "domainOf OpMax"
551 (d:_) -> do
552 TypeInt t <- typeOfDomain d
553 return (DomainInt t [RangeBounded low upp] :: Dom)
554 domainOf op = mkDomainAny ("OpMax:" <++> pretty op) <$> typeOf op
555
556 instance (Pretty x, TypeOf x, ExpressionLike x, DomainOf x, Domain () x :< x) => DomainOf (OpMin x) where
557 domainOf (OpMin x)
558 | Just xs <- listOut x
559 , not (null xs) = do
560 doms <- mapM domainOf xs
561 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
562 let low = [essence| min(&lows) |]
563 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
564 let upp = [essence| min(&upps) |]
565 case doms of
566 [] -> bug "domainOf OpMin"
567 (d:_) -> do
568 TypeInt t <- typeOfDomain d
569 return (DomainInt t [RangeBounded low upp] :: Dom)
570 domainOf op = mkDomainAny ("OpMin:" <++> pretty op) <$> typeOf op
571
572 instance DomainOf x => DomainOf (OpMinus x) where
573 domainOf (OpMinus x y) = do
574 xDom :: Dom <- domainOf x
575 yDom :: Dom <- domainOf y
576
577 xDom_Min <- minOfDomain xDom
578 xDom_Max <- maxOfDomain xDom
579 yDom_Min <- minOfDomain yDom
580 yDom_Max <- maxOfDomain yDom
581
582 let low = [essence| &xDom_Min - &yDom_Max |]
583 let upp = [essence| &xDom_Max - &yDom_Min |]
584
585 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
586
587 instance (Pretty x, TypeOf x) => DomainOf (OpMod x) where
588 domainOf op = mkDomainAny ("OpMod:" <++> pretty op) <$> typeOf op
589
590 instance (Pretty x, TypeOf x) => DomainOf (OpNegate x) where
591 domainOf op = mkDomainAny ("OpNegate:" <++> pretty op) <$> typeOf op
592
593 instance DomainOf (OpNeq x) where
594 domainOf _ = return DomainBool
595
596 instance DomainOf (OpNot x) where
597 domainOf _ = return DomainBool
598
599 instance DomainOf (OpOr x) where
600 domainOf _ = return DomainBool
601
602 instance DomainOf (OpXor x) where
603 domainOf _ = return DomainBool
604
605 instance (Pretty x, TypeOf x) => DomainOf (OpParticipants x) where
606 domainOf op = mkDomainAny ("OpParticipants:" <++> pretty op) <$> typeOf op
607
608 instance DomainOf x => DomainOf (OpParts x) where
609 domainOf (OpParts p) = do
610 dom <- domainOf p
611 case dom of
612 DomainPartition _ _ inner -> return $ DomainSet def def $ DomainSet def def inner
613 _ -> failDoc "domainOf, OpParts, not a partition"
614
615 instance (Pretty x, TypeOf x) => DomainOf (OpParty x) where
616 domainOf op = mkDomainAny ("OpParty:" <++> pretty op) <$> typeOf op
617
618 instance (Pretty x, TypeOf x) => DomainOf (OpPermInverse x) where
619 domainOf op = mkDomainAny ("OpPermInverse:" <++> pretty op) <$> typeOf op
620
621 instance (Pretty x, TypeOf x) => DomainOf (OpCompose x) where
622 domainOf op = mkDomainAny ("OpCompose:" <++> pretty op) <$> typeOf op
623
624 instance (Pretty x, TypeOf x) => DomainOf (OpPow x) where
625 domainOf op = mkDomainAny ("OpPow:" <++> pretty op) <$> typeOf op
626
627 instance (Pretty x, TypeOf x) => DomainOf (OpPowerSet x) where
628 domainOf op = mkDomainAny ("OpPowerSet:" <++> pretty op) <$> typeOf op
629
630 instance (Pretty x, TypeOf x) => DomainOf (OpPreImage x) where
631 domainOf op = mkDomainAny ("OpPreImage:" <++> pretty op) <$> typeOf op
632
633 instance DomainOf x => DomainOf (OpPred x) where
634 domainOf (OpPred x) = domainOf x -- TODO: improve
635
636 instance (ExpressionLike x, DomainOf x) => DomainOf (OpProduct x) where
637 domainOf (OpProduct x)
638 | Just xs <- listOut x
639 , not (null xs) = do
640 (iPat, i) <- quantifiedVar
641 doms <- mapM domainOf xs
642 -- maximum absolute value in each domain
643 let upps = fromList [ [essence| max([ |&i| | &iPat : &d ]) |]
644 | d <- doms ]
645 -- a (too lax) upper bound is multiplying all those together
646 let upp = [essence| product(&upps) |]
647 -- a (too lax) lower bound is -upp
648 let low = [essence| -1 * &upp |]
649 return $ DomainInt TagInt [RangeBounded low upp]
650 domainOf _ = return $ DomainInt TagInt [RangeBounded 1 1]
651
652 instance DomainOf x => DomainOf (OpRange x) where
653 domainOf (OpRange f) = do
654 fDom <- domainOf f
655 case fDom of
656 DomainFunction _ _ _ to -> return $ DomainSet def def to
657 _ -> failDoc "domainOf, OpRange, not a function"
658
659 instance (Pretty x, TypeOf x) => DomainOf (OpRelationProj x) where
660 domainOf op = mkDomainAny ("OpRelationProj:" <++> pretty op) <$> typeOf op
661
662 instance (DomainOf x, Dom :< x) => DomainOf (OpRestrict x) where
663 domainOf (OpRestrict f x) = do
664 d <- project x
665 fDom <- domainOf f
666 case fDom of
667 DomainFunction fRepr a _ to -> return (DomainFunction fRepr a d to)
668 _ -> failDoc "domainOf, OpRestrict, not a function"
669
670 instance (Pretty x, DomainOf x) => DomainOf (OpSlicing x) where
671 domainOf (OpSlicing x _ _) = domainOf x
672 indexDomainsOf (OpSlicing x _ _) = indexDomainsOf x
673
674 instance DomainOf (OpSubsequence x) where
675 domainOf _ = failDoc "domainOf{OpSubsequence}"
676
677 instance (Pretty x, TypeOf x) => DomainOf (OpSubset x) where
678 domainOf op = mkDomainAny ("OpSubset:" <++> pretty op) <$> typeOf op
679
680 instance (Pretty x, TypeOf x) => DomainOf (OpSubsetEq x) where
681 domainOf op = mkDomainAny ("OpSubsetEq:" <++> pretty op) <$> typeOf op
682
683 instance DomainOf (OpSubstring x) where
684 domainOf _ = failDoc "domainOf{OpSubstring}"
685
686 instance DomainOf x => DomainOf (OpSucc x) where
687 domainOf (OpSucc x) = domainOf x -- TODO: improve
688
689 instance (ExpressionLike x, DomainOf x) => DomainOf (OpSum x) where
690 domainOf (OpSum x)
691 | Just xs <- listOut x
692 , not (null xs) = do
693 doms <- mapM domainOf xs
694 let lows = fromList [ [essence| min(`&d`) |] | d <- doms ]
695 let low = [essence| sum(&lows) |]
696 let upps = fromList [ [essence| max(`&d`) |] | d <- doms ]
697 let upp = [essence| sum(&upps) |]
698 return (DomainInt TagInt [RangeBounded low upp] :: Dom)
699 domainOf _ = return $ DomainInt TagInt [RangeBounded 0 0]
700
701
702 instance DomainOf (OpSupset x) where
703 domainOf _ = return DomainBool
704
705 instance DomainOf (OpSupsetEq x) where
706 domainOf _ = return DomainBool
707
708 instance DomainOf (OpTable x) where
709 domainOf _ = return DomainBool
710
711 instance DomainOf (OpAtLeast x) where
712 domainOf _ = return DomainBool
713
714 instance DomainOf (OpAtMost x) where
715 domainOf _ = return DomainBool
716
717 instance DomainOf (OpGCC x) where
718 domainOf _ = return DomainBool
719
720 instance DomainOf (OpTildeLeq x) where
721 domainOf _ = return DomainBool
722
723 instance DomainOf (OpTildeLt x) where
724 domainOf _ = return DomainBool
725
726 instance DomainOf (OpToInt x) where
727 domainOf _ = return $ DomainInt TagInt [RangeBounded 0 1]
728
729 instance (Pretty x, TypeOf x) => DomainOf (OpToMSet x) where
730 domainOf op = mkDomainAny ("OpToMSet:" <++> pretty op) <$> typeOf op
731
732 instance (Pretty x, TypeOf x) => DomainOf (OpToRelation x) where
733 domainOf op = mkDomainAny ("OpToRelation:" <++> pretty op) <$> typeOf op
734
735 instance (Pretty x, TypeOf x, DomainOf x) => DomainOf (OpToSet x) where
736 domainOf (OpToSet _ x) = do
737 domX <- domainOf x
738 innerDomX <- innerDomainOf domX
739 return $ DomainSet () def innerDomX
740
741 instance DomainOf (OpTogether x) where
742 domainOf _ = return DomainBool
743
744 instance (Pretty x, TypeOf x) => DomainOf (OpTransform x) where
745 domainOf op = mkDomainAny ("OpTransform:" <++> pretty op) <$> typeOf op
746
747 instance DomainOf (OpTrue x) where
748 domainOf _ = return DomainBool
749
750 instance (Pretty x, TypeOf x, Domain () x :< x) => DomainOf (OpTwoBars x) where
751 domainOf op = mkDomainAny ("OpTwoBars:" <++> pretty op) <$> typeOf op
752
753 instance (Pretty x, TypeOf x) => DomainOf (OpUnion x) where
754 domainOf op = mkDomainAny ("OpUnion:" <++> pretty op) <$> typeOf op
755
756 instance DomainOf (OpPermutationOrderAfterRepresentation x) where
757 domainOf _ = return DomainBool
758
759 instance DomainOf (OpPermutationOrder x) where
760 domainOf _ = return DomainBool
761
762
763 instance DomainOf (OpApplySymmetries x) where
764 domainOf _ = return DomainBool