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