never executed always true always false
1 module Conjure.Language.EvaluateOp ( EvaluateOp(..) ) where
2
3 import Conjure.Prelude
4 import Conjure.Bug
5 import Conjure.Util.Permutation
6 import Conjure.Language
7 import Conjure.Process.Enumerate ( EnumerateDomain, enumerateInConstant )
8 import Conjure.Compute.DomainOf ( domainOf )
9 import Conjure.Language.DomainSizeOf ( domainSizeOf )
10 import Conjure.Process.AttributeAsConstraints ( mkAttributeToConstraint )
11 import {-# SOURCE #-} Conjure.Language.Instantiate ( instantiateExpression )
12 import {-# SOURCE #-} Conjure.Process.ValidateConstantForDomain ( validateConstantForDomain )
13
14 import qualified Data.Semigroup as SG
15
16 -- | Assume: the input is already normalised.
17 -- Make sure the output is normalised.
18 class EvaluateOp op where
19 evaluateOp ::
20 MonadFailDoc m =>
21 NameGen m =>
22 EnumerateDomain m =>
23 (?typeCheckerMode :: TypeCheckerMode) =>
24 op Constant -> m Constant
25
26 instance EvaluateOp OpActive where
27 evaluateOp (OpActive (viewConstantVariant -> Just (_, n1, _)) n2) = return $ fromBool $ n1 == n2
28 evaluateOp op = na $ "evaluateOp{OpActive}:" <++> pretty (show op)
29
30 instance EvaluateOp OpAllDiff where
31 evaluateOp (OpAllDiff (viewConstantMatrix -> Just (_, vals))) =
32 return $ ConstantBool $ length vals == length (sortNub vals)
33 evaluateOp op = na $ "evaluateOp{OpAllDiff}:" <++> pretty (show op)
34
35 instance EvaluateOp OpAllDiffExcept where
36 evaluateOp (OpAllDiffExcept (viewConstantMatrix -> Just (_, vals)) i@(viewConstantInt -> Just n)) = do
37 TypeInt t <- typeOf i
38 let vals' = filter (ConstantInt t n/=) vals
39 return $ ConstantBool $ length vals' == length (sortNub vals')
40 evaluateOp op = na $ "evaluateOp{OpAllDiffExcept}:" <++> pretty (show op)
41
42 instance EvaluateOp OpAnd where
43 evaluateOp (OpAnd x) = ConstantBool . and <$> boolsOut x
44
45 instance EvaluateOp OpApart where
46 evaluateOp (OpApart _ ConstantUndefined{}) = return (fromBool False)
47 evaluateOp (OpApart (viewConstantSet -> Just ys) (viewConstantPartition -> Just xss)) =
48 return $ ConstantBool $ and
49 [ -- the items in `ys` do not appear together in the partition
50 not $ or [ and [ y `elem` xs | y <- ys ]
51 | xs <- xss
52 ]
53 -- the items in `ys` appear somewhere in the partition
54 , and [ y `elem` concat xss | y <- ys ]
55 ]
56 evaluateOp op = na $ "evaluateOp{OpApart}:" <++> pretty (show op)
57
58 instance EvaluateOp OpAttributeAsConstraint where
59 evaluateOp (OpAttributeAsConstraint x attrName attrVal) = do
60 dom <- domainOf x
61 constraint <- mkAttributeToConstraint dom attrName (fmap Constant attrVal) (Constant x)
62 evaluated <- instantiateExpression [] constraint
63 return evaluated
64
65 instance EvaluateOp OpCatchUndef where
66 evaluateOp (OpCatchUndef ConstantUndefined{} d) = return d
67 evaluateOp (OpCatchUndef x _) = return x
68
69 instance EvaluateOp OpDefined where
70 evaluateOp p | any isUndef (childrenBi p) = do
71 ty <- typeOf p
72 return $ mkUndef ty $ "Has undefined children:" <+> pretty p
73 evaluateOp (OpDefined (viewConstantFunction -> Just xs)) =
74 return $ ConstantAbstract $ AbsLitSet $ sortNub $ map fst xs
75 evaluateOp op = na $ "evaluateOp{OpDefined}:" <++> pretty (show op)
76
77 instance EvaluateOp OpDiv where
78 evaluateOp p | any isUndef (childrenBi p) =
79 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
80 evaluateOp p@(OpDiv x y)
81 | y /= 0 = ConstantInt TagInt <$> (div <$> intOut "div x" x <*> intOut "div y" y)
82 | otherwise = return $ mkUndef (TypeInt TagInt) $ "division by zero:" <+> pretty p
83
84 instance EvaluateOp OpDontCare where
85 evaluateOp op = na $ "evaluateOp{OpDontcare}:" <++> pretty (show op)
86
87 instance EvaluateOp OpDotLeq where
88 evaluateOp (OpDotLeq x y) = return $ ConstantBool $ x <= y
89
90 instance EvaluateOp OpDotLt where
91 evaluateOp (OpDotLt x y) = return $ ConstantBool $ x < y
92
93 instance EvaluateOp OpEq where
94 evaluateOp (OpEq ConstantUndefined{} _) = return $ fromBool False
95 evaluateOp (OpEq _ ConstantUndefined{}) = return $ fromBool False
96 evaluateOp (OpEq (TypedConstant x _) y) = evaluateOp (OpEq x y)
97 evaluateOp (OpEq x (TypedConstant y _)) = evaluateOp (OpEq x y)
98 evaluateOp (OpEq x y) = return $ ConstantBool $ x == y
99
100 instance EvaluateOp OpCompose where
101 evaluateOp (OpCompose (viewConstantPermutation -> Just gss)
102 (viewConstantPermutation -> Just hss)) = do
103 case (fromCycles gss, fromCycles hss) of
104 (Right g, Right h) ->
105 return $ ConstantAbstract $ AbsLitPermutation $ toCycles $ g SG.<> h
106 (Left e, _) -> failDoc $ "evaluateOp{OpCompose}" <++> pretty (show e)
107 (_, Left e) -> failDoc $ "evaluateOp{OpCompose}" <++> pretty (show e)
108 evaluateOp op = na $ "evaluateOp{OpCompose}:" <++> pretty (show op)
109
110
111 instance EvaluateOp OpFactorial where
112 evaluateOp p | any isUndef (childrenBi p) =
113 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
114 evaluateOp (OpFactorial x) = ConstantInt TagInt . product . enumFromTo 1 <$> intOut "factorial" x
115
116 instance EvaluateOp OpFlatten where
117 evaluateOp (OpFlatten Nothing m) = do
118 let flat (viewConstantMatrix -> Just (_, xs)) = concatMap flat xs
119 flat c = [c]
120 let flattened = flat m
121 return (ConstantAbstract $ AbsLitMatrix
122 (DomainInt TagInt [RangeBounded 1 (fromInt (genericLength flattened))])
123 flattened)
124 evaluateOp (OpFlatten (Just n) m) = do
125 let flat lvl c | lvl < 0 = return [c]
126 flat lvl (viewConstantMatrix -> Just (_, xs)) = concatMapM (flat (lvl-1)) xs
127 flat _ _ = failDoc $ "Cannot flatten" <+> pretty n <+> "levels."
128 flattened <- flat n m
129 return (ConstantAbstract $ AbsLitMatrix
130 (DomainInt TagInt [RangeBounded 1 (fromInt (genericLength flattened))])
131 flattened)
132
133 instance EvaluateOp OpFreq where
134 evaluateOp (OpFreq (viewConstantMSet -> Just cs) c) = return $ (ConstantInt TagInt) $ sum [ 1 | i <- cs, c == i ]
135 evaluateOp (OpFreq (viewConstantMatrix -> Just (_, cs)) c) = return $ (ConstantInt TagInt) $ sum [ 1 | i <- cs, c == i ]
136 evaluateOp op = na $ "evaluateOp{OpFreq}:" <++> pretty (show op)
137
138 instance EvaluateOp OpGeq where
139 evaluateOp (OpGeq x y) = return $ ConstantBool $ x >= y
140
141 instance EvaluateOp OpGt where
142 evaluateOp (OpGt x y) = return $ ConstantBool $ x > y
143
144 instance EvaluateOp OpHist where
145 evaluateOp (OpHist (viewConstantMSet -> Just cs)) = return $ ConstantAbstract $ AbsLitMatrix
146 (DomainInt TagInt [RangeBounded 1 (fromInt $ genericLength $ histogram cs)])
147 [ ConstantAbstract $ AbsLitTuple [e, ConstantInt TagInt n] | (e, n) <- histogram cs ]
148 evaluateOp (OpHist (viewConstantMatrix -> Just (_, cs))) = return $ ConstantAbstract $ AbsLitMatrix
149 (DomainInt TagInt [RangeBounded 1 (fromInt $ genericLength $ histogram cs)])
150 [ ConstantAbstract $ AbsLitTuple [e, ConstantInt TagInt n] | (e, n) <- histogram cs ]
151 evaluateOp op = na $ "evaluateOp{OpHist}:" <++> pretty (show op)
152
153 instance EvaluateOp OpIff where
154 evaluateOp (OpIff (ConstantBool x) (ConstantBool y)) = return $ ConstantBool $ x == y
155 evaluateOp _ = na "evaluateOp{OpIff}"
156
157 instance EvaluateOp OpImage where
158 evaluateOp (OpImage f@(viewConstantFunction -> Just xs) a) =
159 case [ y | (x,y) <- xs, a == x ] of
160 [y] -> return y
161 [] -> do
162 TypeFunction _ tyTo <- typeOf f
163 return $ mkUndef tyTo $ vcat
164 [ "Function is not defined at this point:" <+> pretty a
165 , "Function value:" <+> pretty f
166 ]
167 _ -> do
168 TypeFunction _ tyTo <- typeOf f
169 return $ mkUndef tyTo $ vcat
170 [ "Function is multiply defined at this point:" <+> pretty a
171 , "Function value:" <+> pretty f
172 ]
173 evaluateOp (OpImage f@(viewConstantSequence -> Just xs) a) =
174 case [ y | (x,y) <- zip allNats xs, a == fromInt x ] of
175 [y] -> return y
176 [] -> do
177 TypeSequence tyTo <- typeOf f
178 return $ mkUndef tyTo $ vcat
179 [ "Sequence is not defined at this point:" <+> pretty a
180 , "Sequence value:" <+> pretty f
181 ]
182 _ -> do
183 TypeSequence tyTo <- typeOf f
184 return $ mkUndef tyTo $ vcat
185 [ "Sequence is multiply defined at this point:" <+> pretty a
186 , "Sequence value:" <+> pretty f
187 ]
188 evaluateOp (OpImage f@(viewConstantPermutation -> Just _) a) = do
189 permVals <- enumerateInConstant f
190 case [ y | ConstantAbstract (AbsLitTuple [x,y]) <- permVals, a == x ] of
191 [y] -> return y
192 [] -> return a -- permutations map things to themselves by default
193 _ -> do
194 TypePermutation tyTo <- typeOf f
195 return $ mkUndef tyTo $ vcat
196 [ "Permutation is multiply defined at this point:" <+> pretty a
197 , "Permutation value:" <+> pretty f
198 ]
199 evaluateOp op = na $ "evaluateOp{OpImage}:" <++> pretty (show op)
200
201 instance EvaluateOp OpImageSet where
202 evaluateOp (OpImageSet f@(viewConstantFunction -> Just xs) a) = do
203 TypeFunction _ tyTo <- typeOf f
204 case [ y | (x,y) <- xs, a == x ] of
205 [y] -> return $ ConstantAbstract $ AbsLitSet [y]
206 _ -> return $ TypedConstant (ConstantAbstract $ AbsLitSet []) (TypeSet tyTo)
207 evaluateOp (OpImageSet f@(viewConstantSequence -> Just xs) a) = do
208 TypeSequence tyTo <- typeOf f
209 case [ y | (x,y) <- zip allNats xs, a == fromInt x ] of
210 [y] -> return $ ConstantAbstract $ AbsLitSet [y]
211 _ -> return $ TypedConstant (ConstantAbstract $ AbsLitSet []) (TypeSet tyTo)
212 evaluateOp op = na $ "evaluateOp{OpImageSet}:" <++> pretty (show op)
213
214 instance EvaluateOp OpImply where
215 evaluateOp (OpImply x y) = ConstantBool <$> ((<=) <$> boolOut x <*> boolOut y)
216
217 instance EvaluateOp OpIn where
218 evaluateOp (OpIn c (viewConstantSet -> Just cs)) = return $ ConstantBool $ elem c cs
219 evaluateOp (OpIn c (viewConstantMSet -> Just cs)) = return $ ConstantBool $ elem c cs
220 evaluateOp (OpIn c (viewConstantFunction -> Just cs)) =
221 return $ ConstantBool $ elem c $ map (\ (i,j) -> ConstantAbstract $ AbsLitTuple [i,j] ) cs
222 evaluateOp op@(OpIn (viewConstantTuple -> Just [a,b]) (viewConstantPermutation -> Just xss)) =
223 case fromCycles xss of
224 Right p -> do
225 let f = toFunction p
226 return $ ConstantBool $ f a == b
227 _ -> na $ "evaluateOp{OpIn}:" <++> pretty (show op)
228 evaluateOp (OpIn c (viewConstantRelation -> Just cs)) =
229 return $ ConstantBool $ elem c $ map (ConstantAbstract . AbsLitTuple) cs
230 evaluateOp op = na $ "evaluateOp{OpIn}:" <++> pretty (show op)
231
232 instance EvaluateOp OpIndexing where
233 evaluateOp p@(OpIndexing m i) | isUndef i = do
234 ty <- typeOf m
235 tyTo <- case ty of TypeMatrix _ tyTo -> return tyTo
236 TypeList tyTo -> return tyTo
237 _ -> failDoc "evaluateOp{OpIndexing}"
238 return $ mkUndef tyTo $ "Has undefined children (index):" <+> pretty p
239 evaluateOp (OpIndexing m@(viewConstantMatrix -> Just (DomainInt _ index, vals)) (ConstantInt _ x)) = do
240 ty <- typeOf m
241 tyTo <- case ty of TypeMatrix _ tyTo -> return tyTo
242 TypeList tyTo -> return tyTo
243 _ -> bug "evaluateOp{OpIndexing}"
244 indexVals <- valuesInIntDomain index
245 case [ v | (i, v) <- zip indexVals vals, i == x ] of
246 [v] -> return v
247 [] -> return $ mkUndef tyTo $ vcat
248 [ "Matrix is not defined at this point:" <+> pretty x
249 , "Matrix value:" <+> pretty m
250 ]
251 _ -> return $ mkUndef tyTo $ vcat
252 [ "Matrix is multiply defined at this point:" <+> pretty x
253 , "Matrix value:" <+> pretty m
254 ]
255 evaluateOp (OpIndexing (viewConstantTuple -> Just vals) (ConstantInt _ x)) =
256 return (at vals (fromInteger (x-1)))
257 evaluateOp rec@(OpIndexing (viewConstantRecord -> Just vals) (ConstantField name _)) =
258 case lookup name vals of
259 Nothing -> failDoc $ vcat
260 [ "Record doesn't have a member with this name:" <+> pretty name
261 , "Record:" <+> pretty rec
262 ]
263 Just val -> return val
264 evaluateOp var@(OpIndexing (viewConstantVariant -> Just (_, name', x)) (ConstantField name ty)) =
265 if name == name'
266 then return x
267 else return $ mkUndef ty $ vcat
268 [ "Variant isn't set to a member with this name:" <+> pretty name
269 , "Variant:" <+> pretty var
270 ]
271 evaluateOp op = na $ "evaluateOp{OpIndexing}:" <++> pretty (show op)
272
273 instance EvaluateOp OpElementId where
274 evaluateOp p@(OpElementId m i) | isUndef i = do
275 ty <- typeOf m
276 tyTo <- case ty of TypeMatrix _ tyTo -> return tyTo
277 TypeList tyTo -> return tyTo
278 _ -> failDoc "evaluateOp{OpElementId}"
279 return $ mkUndef tyTo $ "Has undefined children (index):" <+> pretty p
280 evaluateOp (OpElementId m@(viewConstantMatrix -> Just (DomainInt _ index, vals)) xExpr@(ConstantInt _ x)) = do
281 ty <- typeOf m
282 tyTo <- case ty of TypeMatrix _ tyTo -> return tyTo
283 TypeList tyTo -> return tyTo
284 _ -> bug "evaluateOp{OpElementId}"
285 indexVals <- valuesInIntDomain index
286 case [ v | (i, v) <- zip indexVals vals, i == x ] of
287 [v] -> return v
288 [] -> return xExpr
289 _ -> return $ mkUndef tyTo $ vcat
290 [ "Matrix is multiply defined at this point:" <+> pretty x
291 , "Matrix value:" <+> pretty m
292 ]
293 evaluateOp op = na $ "evaluateOp{OpElementId}:" <++> pretty (show op)
294
295 instance EvaluateOp OpIntersect where
296 evaluateOp p | any isUndef (childrenBi p) = do
297 ty <- typeOf p
298 return $ mkUndef ty $ "Has undefined children:" <+> pretty p
299 evaluateOp p@(OpIntersect (viewConstantSet -> Just as) (viewConstantSet -> Just bs)) = do
300 ty <- typeOf p
301 let outs = sortNub [ i | i <- as, i `elem` bs]
302 return $ TypedConstant (ConstantAbstract $ AbsLitSet outs) ty
303 evaluateOp p@(OpIntersect (viewConstantMSet -> Just as) (viewConstantMSet -> Just bs)) = do
304 ty <- typeOf p
305 let asHist = histogram as
306 bsHist = histogram bs
307 allElems = sortNub (as++bs)
308 outs =
309 [ replicate (fromInteger (min countA countB)) e
310 | e <- allElems
311 , let countA = fromMaybe 0 (e `lookup` asHist)
312 , let countB = fromMaybe 0 (e `lookup` bsHist)
313 ]
314 return $ TypedConstant (ConstantAbstract $ AbsLitMSet $ concat outs) ty
315 evaluateOp p@(OpIntersect (viewConstantFunction -> Just as) (viewConstantFunction -> Just bs)) = do
316 ty <- typeOf p
317 let outs = sortNub [ i | i <- as, i `elem` bs]
318 return $ TypedConstant (ConstantAbstract $ AbsLitFunction outs) ty
319 evaluateOp p@(OpIntersect (viewConstantRelation -> Just as) (viewConstantRelation -> Just bs)) = do
320 ty <- typeOf p
321 let outs = sortNub [ i | i <- as, i `elem` bs]
322 return $ TypedConstant (ConstantAbstract $ AbsLitRelation outs) ty
323 evaluateOp op = na $ "evaluateOp{OpIntersect}:" <++> pretty (show op)
324
325 instance EvaluateOp OpInverse where
326 evaluateOp (OpInverse (viewConstantFunction -> Just xs) (viewConstantFunction -> Just ys)) =
327 return $ ConstantBool $ and $ concat [ [ (j,i) `elem` ys | (i,j) <- xs ]
328 , [ (j,i) `elem` xs | (i,j) <- ys ]
329 ]
330 evaluateOp op@(OpInverse (viewConstantPermutation -> Just xss) (viewConstantPermutation -> Just yss)) =
331 case (fromCycles xss, fromCycles yss) of
332 (Right px, Right py) -> return $ ConstantBool $ px == inverse py
333 _ -> na $ "evaluateOp{OpInverse}:" <++> pretty (show op)
334 evaluateOp op = na $ "evaluateOp{OpInverse}:" <++> pretty (show op)
335
336 instance EvaluateOp OpLeq where
337 evaluateOp (OpLeq x y) = return $ ConstantBool $ x <= y
338
339 instance EvaluateOp OpLexLeq where
340 evaluateOp (OpLexLeq (viewConstantMatrix -> Just (_, xs)) (viewConstantMatrix -> Just (_, ys))) =
341 return $ ConstantBool $ xs <= ys
342 evaluateOp op = na $ "evaluateOp{OpLexLeq}:" <++> pretty (show op)
343
344 instance EvaluateOp OpLexLt where
345 evaluateOp (OpLexLt (viewConstantMatrix -> Just (_, xs)) (viewConstantMatrix -> Just (_, ys))) =
346 return $ ConstantBool $ xs < ys
347 evaluateOp op = na $ "evaluateOp{OpLexLt}:" <++> pretty (show op)
348
349 instance EvaluateOp OpLt where
350 evaluateOp (OpLt x y) = return $ ConstantBool $ x < y
351
352 instance EvaluateOp OpMakeTable where
353 evaluateOp op = na $ "evaluateOp{OpMakeTable}:" <++> pretty (show op)
354
355 instance EvaluateOp OpMax where
356 evaluateOp p | any isUndef (childrenBi p) =
357 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
358 evaluateOp p@(OpMax x)
359 | Just xs <- listOut x
360 , any isUndef xs =
361 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
362 evaluateOp (OpMax (DomainInConstant DomainBool)) = return (ConstantBool True)
363 evaluateOp (OpMax (DomainInConstant (DomainInt t rs))) = do
364 is <- rangesInts rs
365 return $ if null is
366 then mkUndef (TypeInt TagInt) "Empty collection in max"
367 else ConstantInt t (maximum is)
368 evaluateOp (OpMax coll@(viewConstantMatrix -> Just (_, xs))) =
369 case xs of
370 [] -> do
371 tyInner <- typeOf coll >>= innerTypeOf
372 return $ mkUndef tyInner "Empty collection in max"
373 (x:_) -> do
374 tyInner <- typeOf x
375 case tyInner of
376 TypeInt t -> do
377 is <- concatMapM (intsOut "OpMax 1") xs
378 return $ ConstantInt t (maximum is)
379 _ -> na "evaluateOp{OpMax}"
380 evaluateOp (OpMax coll@(viewConstantSet -> Just xs)) = do
381 case xs of
382 [] -> do
383 tyInner <- typeOf coll >>= innerTypeOf
384 return $ mkUndef tyInner "Empty collection in max"
385 (x:_) -> do
386 tyInner <- typeOf x
387 case tyInner of
388 TypeInt t -> do
389 is <- concatMapM (intsOut "OpMax 1") xs
390 return $ ConstantInt t (maximum is)
391 _ -> na "evaluateOp{OpMax}"
392 evaluateOp (OpMax coll@(viewConstantMSet -> Just xs)) = do
393 case xs of
394 [] -> do
395 tyInner <- typeOf coll >>= innerTypeOf
396 return $ mkUndef tyInner "Empty collection in max"
397 (x:_) -> do
398 tyInner <- typeOf x
399 case tyInner of
400 TypeInt t -> do
401 is <- concatMapM (intsOut "OpMax 1") xs
402 return $ ConstantInt t (maximum is)
403 _ -> na "evaluateOp{OpMax}"
404 evaluateOp _ = na "evaluateOp{OpMax}"
405
406 instance EvaluateOp OpMin where
407 evaluateOp p | any isUndef (childrenBi p) =
408 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
409 evaluateOp p@(OpMin x)
410 | Just xs <- listOut x
411 , any isUndef xs =
412 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
413 evaluateOp (OpMin (DomainInConstant DomainBool)) = return (ConstantBool False)
414 evaluateOp (OpMin (DomainInConstant (DomainInt t rs))) = do
415 is <- rangesInts rs
416 return $ if null is
417 then mkUndef (TypeInt TagInt) "Empty collection in min"
418 else ConstantInt t (minimum is)
419 evaluateOp (OpMin coll@(viewConstantMatrix -> Just (_, xs))) = do
420 case xs of
421 [] -> do
422 tyInner <- typeOf coll >>= innerTypeOf
423 return $ mkUndef tyInner "Empty collection in min"
424 (x:_) -> do
425 tyInner <- typeOf x
426 case tyInner of
427 TypeInt t -> do
428 is <- concatMapM (intsOut "OpMin 1") xs
429 return $ ConstantInt t (minimum is)
430 _ -> na "evaluateOp{OpMin}"
431 evaluateOp (OpMin coll@(viewConstantSet -> Just xs)) = do
432 case xs of
433 [] -> do
434 tyInner <- typeOf coll >>= innerTypeOf
435 return $ mkUndef tyInner "Empty collection in min"
436 (x:_) -> do
437 tyInner <- typeOf x
438 case tyInner of
439 TypeInt t -> do
440 is <- concatMapM (intsOut "OpMin 1") xs
441 return $ ConstantInt t (minimum is)
442 _ -> na "evaluateOp{OpMin}"
443 evaluateOp (OpMin coll@(viewConstantMSet -> Just xs)) = do
444 case xs of
445 [] -> do
446 tyInner <- typeOf coll >>= innerTypeOf
447 return $ mkUndef tyInner "Empty collection in min"
448 (x:_) -> do
449 tyInner <- typeOf x
450 case tyInner of
451 TypeInt t -> do
452 is <- concatMapM (intsOut "OpMin 1") xs
453 return $ ConstantInt t (minimum is)
454 _ -> na "evaluateOp{OpMin}"
455 evaluateOp op = na $ "evaluateOp{OpMin}" <+> pretty (show op)
456
457 instance EvaluateOp OpMinus where
458 evaluateOp p | any isUndef (childrenBi p) = do
459 ty <- typeOf p
460 return $ mkUndef ty $ "Has undefined children:" <+> pretty p
461 evaluateOp (OpMinus (ConstantInt t a) (ConstantInt _ b))
462 = return $ ConstantInt t (a - b)
463 evaluateOp (OpMinus (viewConstantSet -> Just as) (viewConstantSet -> Just bs)) = do
464 let outs =
465 [ a
466 | a <- as
467 , a `notElem` bs
468 ]
469 return $ ConstantAbstract $ AbsLitSet outs
470 evaluateOp (OpMinus (viewConstantMSet -> Just as) (viewConstantMSet -> Just bs)) = do
471 let asHist = histogram as
472 bsHist = histogram bs
473 allElems = sortNub (as++bs)
474 outs =
475 [ replicate (fromInteger (countA - countB)) e
476 | e <- allElems
477 , let countA = fromMaybe 0 (e `lookup` asHist)
478 , let countB = fromMaybe 0 (e `lookup` bsHist)
479 ]
480 return $ ConstantAbstract $ AbsLitMSet $ concat outs
481 evaluateOp (OpMinus (viewConstantFunction -> Just as) (viewConstantFunction -> Just bs)) = do
482 let outs =
483 [ a
484 | a <- as
485 , a `notElem` bs
486 ]
487 return $ ConstantAbstract $ AbsLitFunction outs
488 evaluateOp (OpMinus (viewConstantRelation -> Just as) (viewConstantRelation -> Just bs)) = do
489 let outs =
490 [ a
491 | a <- as
492 , a `notElem` bs
493 ]
494 return $ ConstantAbstract $ AbsLitRelation outs
495 evaluateOp op = na $ "evaluateOp{OpMinus}:" <++> pretty (show op)
496
497 instance EvaluateOp OpMod where
498 evaluateOp p | any isUndef (childrenBi p) =
499 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
500 evaluateOp p@(OpMod x y)
501 | y /= 0 = ConstantInt TagInt <$> (mod <$> intOut "mod x" x <*> intOut "mod y" y)
502 | otherwise = return $ mkUndef (TypeInt TagInt) $ "modulo zero:" <+> pretty p
503
504 instance EvaluateOp OpNegate where
505 evaluateOp p | any isUndef (childrenBi p) =
506 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
507 evaluateOp (OpNegate x) = ConstantInt TagInt . negate <$> intOut "OpNegate" x
508
509 instance EvaluateOp OpNeq where
510 evaluateOp (OpNeq ConstantUndefined{} _) = return $ fromBool False
511 evaluateOp (OpNeq _ ConstantUndefined{}) = return $ fromBool False
512 evaluateOp (OpNeq x y) = do
513 out <- evaluateOp (OpEq x y)
514 evaluateOp (OpNot out)
515
516 instance EvaluateOp OpNot where
517 evaluateOp (OpNot x) = ConstantBool . not <$> boolOut x
518
519 instance EvaluateOp OpOr where
520 evaluateOp (OpOr x) = ConstantBool . or <$> boolsOut x
521
522 instance EvaluateOp OpParticipants where
523 evaluateOp (OpParticipants (viewConstantPartition -> Just xss)) =
524 return $ ConstantAbstract $ AbsLitSet $ sort $ concat xss
525 evaluateOp op = na $ "evaluateOp{OpParticipants}:" <++> pretty (show op)
526
527 instance EvaluateOp OpParts where
528 evaluateOp (OpParts (viewConstantPartition -> Just xs)) =
529 return $ ConstantAbstract $ AbsLitSet $ map (ConstantAbstract . AbsLitSet) xs
530 evaluateOp op = na $ "evaluateOp{OpParts}:" <++> pretty (show op)
531
532 instance EvaluateOp OpParty where
533 evaluateOp op@(OpParty x p@(viewConstantPartition -> Just xss)) = do
534 TypePartition tyInner <- typeOf p
535 let
536 outSet = [ xs
537 | xs <- xss
538 , x `elem` xs
539 ]
540 case outSet of
541 [s] -> return $ ConstantAbstract (AbsLitSet s)
542 [] -> return $ TypedConstant (ConstantAbstract (AbsLitSet [])) (TypeSet tyInner)
543 _ -> return $ mkUndef (TypeSet tyInner) $ "Element found in multiple parts of the partition:"
544 <++> pretty op
545 evaluateOp op = na $ "evaluateOp{OpParty}:" <++> pretty (show op)
546
547 instance EvaluateOp OpPermInverse where
548 evaluateOp (OpPermInverse (viewConstantPermutation -> Just xss))
549 | Right perm <- fromCycles xss
550 = return $ ConstantAbstract $ AbsLitPermutation $ toCyclesCanonical $ inverse perm
551 evaluateOp op = na $ "evaluateOp{OpPermInverse}:" <++> pretty (show op)
552
553 instance EvaluateOp OpPow where
554 evaluateOp p | any isUndef (childrenBi p) =
555 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
556 evaluateOp p@(OpPow x y)
557 | y >= 0 = ConstantInt TagInt <$> ((^) <$> intOut "pow x" x <*> intOut "pow y" y)
558 | otherwise = return $ mkUndef (TypeInt TagInt) $ "negative exponent:" <+> pretty p
559
560 instance EvaluateOp OpPowerSet where
561 evaluateOp (OpPowerSet (viewConstantSet -> Just xs)) =
562 return $ ConstantAbstract $ AbsLitSet
563 [ ConstantAbstract $ AbsLitSet ys
564 | ys <- subsequences (sortBy ordTildeLt (sortNub xs)) ]
565 evaluateOp op = na $ "evaluateOp{OpPowerSet}:" <++> pretty (show op)
566
567 instance EvaluateOp OpPred where
568 evaluateOp p | any isUndef (childrenBi p) =
569 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
570 evaluateOp (OpPred (ConstantBool _)) = return (ConstantBool False) -- True --> False
571 -- False --> undef, hence False
572 evaluateOp (OpPred (ConstantInt TagInt x)) = return (ConstantInt TagInt (pred x))
573 evaluateOp (OpPred (ConstantInt (TagEnum t) x))
574 = return (ConstantInt (TagEnum t) (pred x))
575 evaluateOp op = na $ "evaluateOp{OpPred}" <+> pretty (show op)
576
577 instance EvaluateOp OpPreImage where
578 evaluateOp (OpPreImage (viewConstantFunction -> Just xs) a) =
579 return $ ConstantAbstract $ AbsLitSet [ x | (x,y) <- xs, a == y ]
580 evaluateOp (OpPreImage (viewConstantSequence -> Just xs) a) =
581 return $ ConstantAbstract $ AbsLitSet [ x | (n,y) <- zip allNats xs
582 , let x = ConstantInt TagInt n
583 , a == y ]
584 evaluateOp op = na $ "evaluateOp{OpPreImage}:" <++> pretty (show op)
585
586 instance EvaluateOp OpProduct where
587 evaluateOp p | any isUndef (childrenBi p) =
588 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
589 evaluateOp p@(OpProduct x)
590 | Just xs <- listOut x
591 , any isUndef xs =
592 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
593 evaluateOp (OpProduct x) = ConstantInt TagInt . product <$> intsOut "OpProduct" x
594
595 instance EvaluateOp OpRange where
596 evaluateOp p | any isUndef (childrenBi p) = do
597 ty <- typeOf p
598 return $ mkUndef ty $ "Has undefined children:" <+> pretty p
599 evaluateOp (OpRange (viewConstantFunction -> Just xs)) =
600 return $ ConstantAbstract $ AbsLitSet $ sortNub $ map snd xs
601 evaluateOp op = na $ "evaluateOp{OpRange}:" <++> pretty (show op)
602
603 instance EvaluateOp OpRelationProj where
604 evaluateOp (OpRelationProj (viewConstantRelation -> Just xss) mas) = do
605 let mas' = catMaybes mas
606 if length mas == length mas'
607 then -- all Just's
608 return $ ConstantBool $ mas' `elem` xss
609 else
610 return $ ConstantAbstract $ AbsLitRelation
611 [ xsProject
612 | xs <- xss
613 , let xsProject = [ x
614 | (x, Nothing) <- zip xs mas
615 ]
616 , let xsCondition = [ x == y
617 | (x, Just y ) <- zip xs mas
618 ]
619 , and xsCondition
620 ]
621 -- leave the OpImage evaluator in -- it is just easier
622 evaluateOp (OpRelationProj f@(viewConstantFunction -> Just _) [Just arg]) =
623 evaluateOp (OpImage f arg)
624 evaluateOp (OpRelationProj f@(viewConstantSequence -> Just _) [Just arg]) =
625 evaluateOp (OpImage f arg)
626 evaluateOp op = na $ "evaluateOp{OpRelationProj}:" <++> pretty (show op)
627
628 instance EvaluateOp OpRestrict where
629 evaluateOp (OpRestrict (viewConstantFunction -> Just xs) domX) = do
630 dom <- domainOut domX
631 outVals <- concatForM xs $ \case
632 x@(a, _) -> do
633 mres <- runExceptT $ validateConstantForDomain "<in memory>" a (dom :: Domain () Constant)
634 case mres of
635 Left {} -> return []
636 Right{} -> return [x]
637 return $ ConstantAbstract $ AbsLitFunction $ sortNub outVals
638 evaluateOp op = na $ "evaluateOp{OpRestrict}:" <++> pretty (show op)
639
640 instance EvaluateOp OpSlicing where
641 evaluateOp (OpSlicing (viewConstantMatrix -> Just (DomainInt n index, vals)) lb ub)
642 = do
643 indexVals <- valuesInIntDomain index
644 outVals <- fmap catMaybes $ forM (zip indexVals vals)
645 $ \ (thisIndex, thisVal) ->
646 case lb of
647 Just (ConstantInt cn lower)
648 | cn == n && lower > thisIndex -> return Nothing
649 _ -> case ub of
650 Just (ConstantInt cn upper)
651 | cn == n && upper < thisIndex -> return Nothing
652 _ -> return $ Just (thisIndex, thisVal)
653 let outDomain = DomainInt n $ map (RangeSingle . (ConstantInt n) . fst) outVals
654 return $ ConstantAbstract $ AbsLitMatrix outDomain (map snd outVals)
655 evaluateOp op = na $ "evaluateOp{OpSlicing}:" <++> pretty (show op)
656
657 instance EvaluateOp OpSubsequence where
658 evaluateOp (OpSubsequence
659 (viewConstantSequence -> Just xs)
660 (viewConstantSequence -> Just ys)) =
661 return $ fromBool $
662 or [ and (zipWith (==) xs zs)
663 | zs <- subsequences ys
664 , length zs >= length xs
665 ]
666 evaluateOp op = na $ "evaluateOp{OpSubsequence}:" <++> pretty (show op)
667
668 instance EvaluateOp OpSubset where
669 evaluateOp (OpSubset a b) = do
670 x <- evaluateOp (OpSubsetEq a b)
671 y <- evaluateOp (OpNeq a b)
672 evaluateOp (OpAnd (fromList [x,y]))
673
674 instance EvaluateOp OpSubsetEq where
675 evaluateOp (OpSubsetEq (viewConstantSet -> Just as) (viewConstantSet -> Just bs)) =
676 return $ ConstantBool $ all (`elem` bs) as
677 evaluateOp (OpSubsetEq (viewConstantMSet -> Just as) (viewConstantMSet -> Just bs)) =
678 let asHist = histogram as
679 bsHist = histogram bs
680 allElems = sortNub (as++bs)
681 in return $ ConstantBool $ and
682 [ countA <= countB
683 | e <- allElems
684 , let countA = fromMaybe 0 (e `lookup` asHist)
685 , let countB = fromMaybe 0 (e `lookup` bsHist)
686 ]
687 evaluateOp (OpSubsetEq (viewConstantFunction -> Just as) (viewConstantFunction -> Just bs)) =
688 return $ ConstantBool $ all (`elem` bs) as
689 evaluateOp (OpSubsetEq (viewConstantRelation -> Just as) (viewConstantRelation -> Just bs)) =
690 return $ ConstantBool $ all (`elem` bs) as
691 evaluateOp op = na $ "evaluateOp{OpSubsetEq}:" <++> pretty (show op)
692
693 instance EvaluateOp OpSubstring where
694 evaluateOp (OpSubstring
695 (viewConstantSequence -> Just xs)
696 (viewConstantSequence -> Just ys)) =
697 return $ fromBool $
698 or [ and (zipWith (==) xs zs)
699 | zs <- tails ys
700 , length zs >= length xs
701 ]
702 evaluateOp op = na $ "evaluateOp{OpSubstring}:" <++> pretty (show op)
703
704 instance EvaluateOp OpSucc where
705 evaluateOp p | any isUndef (childrenBi p) =
706 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
707 evaluateOp (OpSucc (ConstantBool False)) = return (ConstantBool True)
708 evaluateOp (OpSucc (ConstantBool True )) = return (ConstantBool False) -- undef
709 evaluateOp (OpSucc (ConstantInt TagInt x)) = return (ConstantInt TagInt (succ x))
710 evaluateOp (OpSucc (ConstantInt (TagEnum t) x))
711 = return (ConstantInt (TagEnum t) (succ x))
712 evaluateOp op = na $ "evaluateOp{OpSucc}" <+> pretty (show op)
713
714 instance EvaluateOp OpSum where
715 evaluateOp p | any isUndef (childrenBi p) =
716 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
717 evaluateOp p@(OpSum x)
718 | Just xs <- listOut x
719 , any isUndef xs =
720 return $ mkUndef (TypeInt TagInt) $ "Has undefined children:" <+> pretty p
721 evaluateOp (OpSum x) = ConstantInt TagInt . sum <$> intsOut "OpSum" x
722
723 instance EvaluateOp OpSupset where
724 evaluateOp (OpSupset a b) = evaluateOp (OpSubset b a)
725
726 instance EvaluateOp OpSupsetEq where
727 evaluateOp (OpSupsetEq a b) = evaluateOp (OpSubsetEq b a)
728
729 instance EvaluateOp OpTable where
730 evaluateOp (OpTable rows table) = do
731 rows' <- intsOut "OpTable-rows" rows
732 table' <- intsOut2D "OpTable-table" table
733 return $ ConstantBool $ rows' `elem` table'
734
735 instance EvaluateOp OpGCC where
736 evaluateOp op@OpGCC{} = na $ "evaluateOp{OpGCC}" <+> pretty op
737
738 instance EvaluateOp OpAtLeast where
739 evaluateOp (OpAtLeast (intsOut "" -> Just vars)
740 (intsOut "" -> Just bounds)
741 (intsOut "" -> Just vals)) = do
742 return $ ConstantBool $ and [ sum [1 | x <- vars, x == val] >= bound
743 | (bound, val) <- zip bounds vals
744 ]
745 evaluateOp op@OpAtLeast{} = na $ "evaluateOp{OpAtLeast}" <+> pretty op
746
747 instance EvaluateOp OpAtMost where
748 evaluateOp (OpAtMost (intsOut "" -> Just vars)
749 (intsOut "" -> Just bounds)
750 (intsOut "" -> Just vals)) = do
751 return $ ConstantBool $ and [ sum [1 | x <- vars, x == val] <= bound
752 | (bound, val) <- zip bounds vals
753 ]
754 evaluateOp op@OpAtMost{} = na $ "evaluateOp{OpAtMost}" <+> pretty op
755
756 instance EvaluateOp OpTildeLeq where
757 evaluateOp (OpTildeLeq x y) = do
758 flag1 <- evaluateOp (OpEq x y)
759 flag2 <- evaluateOp (OpTildeLt x y)
760 evaluateOp $ OpOr $ fromList [flag1, flag2]
761
762 instance EvaluateOp OpTildeLt where
763 evaluateOp (OpTildeLt x y) = return $ ConstantBool $ tildeLt x y
764
765 instance EvaluateOp OpTogether where
766 evaluateOp (OpTogether _ ConstantUndefined{}) = return (fromBool False)
767 evaluateOp (OpTogether (viewConstantSet -> Just ys) (viewConstantPartition -> Just xss)) =
768 return $ ConstantBool $ or
769 [ and [ y `elem` xs | y <- ys ]
770 | xs <- xss
771 ]
772 evaluateOp op = na $ "evaluateOp{OpTogether}:" <++> pretty (show op)
773
774 instance EvaluateOp OpToInt where
775 evaluateOp (OpToInt (ConstantBool False)) = return (ConstantInt TagInt 0)
776 evaluateOp (OpToInt (ConstantBool True )) = return (ConstantInt TagInt 1)
777 evaluateOp (OpToInt ConstantUndefined{}) = return (ConstantInt TagInt 0)
778 evaluateOp op = na $ "evaluateOp{OpToInt}:" <++> pretty (show op)
779
780 instance EvaluateOp OpToMSet where
781 evaluateOp (OpToMSet (viewConstantSet -> Just xs)) =
782 return $ ConstantAbstract $ AbsLitMSet xs
783 evaluateOp (OpToMSet (viewConstantMSet -> Just xs)) =
784 return $ ConstantAbstract $ AbsLitMSet xs
785 evaluateOp (OpToMSet (viewConstantFunction -> Just xs)) =
786 return $ ConstantAbstract $ AbsLitMSet [ConstantAbstract $ AbsLitTuple [a,b] | (a,b) <- xs]
787 evaluateOp (OpToMSet (viewConstantRelation -> Just xs)) =
788 return $ ConstantAbstract $ AbsLitMSet $ map (ConstantAbstract . AbsLitTuple) xs
789 evaluateOp op = na $ "evaluateOp{OpToMSet}:" <++> pretty (show op)
790
791 instance EvaluateOp OpToRelation where
792 evaluateOp (OpToRelation (viewConstantFunction -> Just xs)) =
793 return $ ConstantAbstract $ AbsLitRelation $ sortNub [ [a,b] | (a,b) <- xs ]
794 evaluateOp op = na $ "evaluateOp{OpToRelation}:" <++> pretty (show op)
795
796 instance EvaluateOp OpToSet where
797 evaluateOp (OpToSet _ (viewConstantMatrix -> Just (_, xs))) =
798 return $ ConstantAbstract $ AbsLitSet $ sortNub xs
799 evaluateOp (OpToSet _ (viewConstantSet -> Just xs)) =
800 return $ ConstantAbstract $ AbsLitSet $ sortNub xs
801 evaluateOp (OpToSet _ (viewConstantMSet -> Just xs)) =
802 return $ ConstantAbstract $ AbsLitSet $ sortNub xs
803 evaluateOp (OpToSet _ (viewConstantFunction -> Just xs)) =
804 return $ ConstantAbstract $ AbsLitSet $ sortNub [ConstantAbstract $ AbsLitTuple [a,b] | (a,b) <- xs]
805 evaluateOp (OpToSet _ (viewConstantRelation -> Just xs)) =
806 return $ ConstantAbstract $ AbsLitSet $ sortNub $ map (ConstantAbstract . AbsLitTuple) xs
807 evaluateOp (OpToSet _ (viewConstantPermutation -> Just xs)) =
808 case toFunction <$> fromCycles xs of
809 Left (PermutationError e) -> na $ "evaluateOp{OpToSet}:" <++> pretty e
810 Right fn -> return $ ConstantAbstract $ AbsLitSet $ (ConstantAbstract . AbsLitTuple) <$> ((\x -> [x, fn x]) <$> join xs)
811 evaluateOp op = na $ "evaluateOp{OpToSet}:" <++> pretty (show op)
812
813 instance EvaluateOp OpTransform where
814 evaluateOp op = na $ "evaluateOp{OpTransform}:" <++> pretty (show op)
815
816 instance EvaluateOp OpTrue where
817 evaluateOp _ = return (fromBool True)
818
819 instance EvaluateOp OpTwoBars where
820 evaluateOp (OpTwoBars x) =
821 case x of
822 -- absolute value
823 ConstantInt _ y -> return $ ConstantInt TagInt $ abs y
824
825 -- cardinality of a constant
826 (viewConstantMatrix -> Just (_, xs)) -> return $ ConstantInt TagInt $ genericLength xs
827 (viewConstantSet -> Just xs) -> return $ ConstantInt TagInt $ genericLength $ sortNub xs
828 (viewConstantMSet -> Just xs) -> return $ ConstantInt TagInt $ genericLength xs
829 (viewConstantFunction -> Just xs) -> return $ ConstantInt TagInt $ genericLength $ sortNub xs
830 (viewConstantSequence -> Just xs) -> return $ ConstantInt TagInt $ genericLength xs
831 (viewConstantRelation -> Just xs) -> return $ ConstantInt TagInt $ genericLength $ sortNub xs
832 (viewConstantPartition -> Just xs) -> return $ ConstantInt TagInt $ genericLength $ sortNub $ concat xs
833 (viewConstantPermutation -> Just xs) -> return $ ConstantInt TagInt $ genericLength $ sortNub $ concat xs
834
835 -- cardinality of a domain
836 DomainInConstant (DomainInt _ rs) -> ConstantInt TagInt . genericLength <$> rangesInts rs
837 DomainInConstant dom -> runNameGen () $ domainSizeOf dom
838 _ -> na $ "evaluateOp OpTwoBars" <+> pretty (show x)
839
840 instance EvaluateOp OpUnion where
841 evaluateOp p | any isUndef (childrenBi p) = do
842 ty <- typeOf p
843 return $ mkUndef ty $ "Has undefined children:" <+> pretty p
844 evaluateOp (OpUnion (viewConstantSet -> Just as) (viewConstantSet -> Just bs)) =
845 return $ ConstantAbstract $ AbsLitSet $ sortNub (as ++ bs)
846 evaluateOp (OpUnion (viewConstantMSet -> Just as) (viewConstantMSet -> Just bs)) =
847 let asHist = histogram as
848 bsHist = histogram bs
849 allElems = sortNub (as++bs)
850 in
851 return $ ConstantAbstract $ AbsLitMSet $ concat
852 [ replicate (fromInteger (max countA countB)) e
853 | e <- allElems
854 , let countA = fromMaybe 0 (e `lookup` asHist)
855 , let countB = fromMaybe 0 (e `lookup` bsHist)
856 ]
857 -- TODO: what if the same thing is mapped to two different values? undefined behaviour?
858 evaluateOp (OpUnion (viewConstantFunction -> Just as) (viewConstantFunction -> Just bs)) =
859 return $ ConstantAbstract $ AbsLitFunction $ sortNub (as ++ bs)
860 evaluateOp (OpUnion (viewConstantRelation -> Just as) (viewConstantRelation -> Just bs)) =
861 return $ ConstantAbstract $ AbsLitRelation $ sortNub (as ++ bs)
862 evaluateOp op = na $ "evaluateOp{OpUnion}:" <++> pretty (show op)
863
864 instance EvaluateOp OpXor where
865 evaluateOp (OpXor x) = ConstantBool . xor <$> boolsOut x
866 where xor xs = odd (length [ () | True <- xs ])
867
868 instance EvaluateOp OpQuickPermutationOrder where
869 evaluateOp op = na $ "evaluateOp{OpQuickPermutationOrder}:" <++> pretty (show op)
870
871 boolsOut :: MonadFailDoc m => Constant -> m [Bool]
872 boolsOut (viewConstantMatrix -> Just (_, cs)) = concatMapM boolsOut cs
873 boolsOut b = return <$> boolOut b
874
875 intsOut :: MonadFailDoc m => Doc -> Constant -> m [Integer]
876 intsOut doc (viewConstantMatrix -> Just (_, cs)) = concatMapM (intsOut doc) cs
877 intsOut doc (viewConstantSet -> Just cs) = concatMapM (intsOut doc) cs
878 intsOut doc (viewConstantMSet -> Just cs) = concatMapM (intsOut doc) cs
879 intsOut doc b = return <$> intOut ("intsOut" <+> doc) b
880
881 intsOut2D :: MonadFailDoc m => Doc -> Constant -> m [[Integer]]
882 intsOut2D doc (viewConstantMatrix -> Just (_, cs)) = mapM (intsOut doc) cs
883 intsOut2D doc (viewConstantSet -> Just cs) = mapM (intsOut doc) cs
884 intsOut2D doc (viewConstantMSet -> Just cs) = mapM (intsOut doc) cs
885 intsOut2D doc _ = failDoc ("intsOut2D" <+> doc)
886
887 tildeLt :: Constant -> Constant -> Bool
888 tildeLt = tilLt
889 where
890 freq :: Eq a => a -> [a] -> Int
891 freq i xs = sum [ 1 | j <- xs , i == j ]
892
893 tupleE (i,j) = ConstantAbstract $ AbsLitTuple [i,j]
894
895 tilLt :: Constant -> Constant -> Bool
896 tilLt (ConstantBool a) (ConstantBool b) = a < b
897 tilLt (ConstantInt TagInt a) (ConstantInt TagInt b) = a < b
898 tilLt (ConstantInt (TagEnum an) a) (ConstantInt (TagEnum bn) b)
899 | an == bn = a < b
900 tilLt (viewConstantTuple -> Just [])
901 (viewConstantTuple -> Just []) = False
902 tilLt (viewConstantTuple -> Just (a:as))
903 (viewConstantTuple -> Just (b:bs)) =
904 if tilLt a b
905 then True
906 else a == b &&
907 tilLt (ConstantAbstract $ AbsLitTuple as)
908 (ConstantAbstract $ AbsLitTuple bs)
909 tilLt (viewConstantSet -> Just as)
910 (viewConstantSet -> Just bs) =
911 or [ and [ freq i as < freq i bs
912 , and [ if tilLt j i
913 then freq j as == freq j bs
914 else True
915 | j <- cs
916 ]
917 ]
918 | let cs = sortNub (as ++ bs)
919 , i <- cs
920 ]
921 tilLt (viewConstantMSet -> Just as)
922 (viewConstantMSet -> Just bs) =
923 or [ and [ freq i as < freq i bs
924 , and [ if tilLt j i
925 then freq j as == freq j bs
926 else True
927 | j <- cs
928 ]
929 ]
930 | let cs = as ++ bs
931 , i <- cs
932 ]
933 tilLt (viewConstantFunction -> Just as')
934 (viewConstantFunction -> Just bs') =
935 or [ and [ freq i as < freq i bs
936 , and [ if tilLt j i
937 then freq j as == freq j bs
938 else True
939 | j <- cs
940 ]
941 ]
942 | let as = map tupleE as'
943 , let bs = map tupleE bs'
944 , let cs = as ++ bs
945 , i <- cs
946 ]
947 tilLt (viewConstantRelation -> Just as')
948 (viewConstantRelation -> Just bs') =
949 or [ and [ freq i as < freq i bs
950 , and [ if tilLt j i
951 then freq j as == freq j bs
952 else True
953 | j <- cs
954 ]
955 ]
956 | let as = map (ConstantAbstract . AbsLitTuple) as'
957 , let bs = map (ConstantAbstract . AbsLitTuple) bs'
958 , let cs = as ++ bs
959 , i <- cs
960 ]
961 tilLt (viewConstantPartition -> Just as')
962 (viewConstantPartition -> Just bs') =
963 or [ and [ freq i as < freq i bs
964 , and [ if tilLt j i
965 then freq j as == freq j bs
966 else True
967 | j <- cs
968 ]
969 ]
970 | let as = map (ConstantAbstract . AbsLitSet) as'
971 , let bs = map (ConstantAbstract . AbsLitSet) bs'
972 , let cs = as ++ bs
973 , i <- cs
974 ]
975 tilLt a b = a < b
976
977 ordTildeLt :: Constant -> Constant -> Ordering
978 ordTildeLt x y =
979 case (tildeLt x y, tildeLt y x) of
980 (True, _) -> LT
981 (_, True) -> GT
982 _ -> EQ
983
984
985 instance EvaluateOp Op where
986 evaluateOp (MkOpActive x) = evaluateOp x
987 evaluateOp (MkOpCompose x) = evaluateOp x
988 evaluateOp (MkOpAllDiff x) = evaluateOp x
989 evaluateOp (MkOpAllDiffExcept x) = evaluateOp x
990 evaluateOp (MkOpAnd x) = evaluateOp x
991 evaluateOp (MkOpApart x) = evaluateOp x
992 evaluateOp (MkOpAtLeast x) = evaluateOp x
993 evaluateOp (MkOpAtMost x) = evaluateOp x
994 evaluateOp (MkOpAttributeAsConstraint x) = evaluateOp x
995 evaluateOp (MkOpCatchUndef x) = evaluateOp x
996 evaluateOp (MkOpDefined x) = evaluateOp x
997 evaluateOp (MkOpDiv x) = evaluateOp x
998 evaluateOp (MkOpDontCare x) = evaluateOp x
999 evaluateOp (MkOpDotLeq x) = evaluateOp x
1000 evaluateOp (MkOpDotLt x) = evaluateOp x
1001 evaluateOp (MkOpEq x) = evaluateOp x
1002 evaluateOp (MkOpElementId x) = evaluateOp x
1003 evaluateOp (MkOpFactorial x) = evaluateOp x
1004 evaluateOp (MkOpFlatten x) = evaluateOp x
1005 evaluateOp (MkOpFreq x) = evaluateOp x
1006 evaluateOp (MkOpGCC x) = evaluateOp x
1007 evaluateOp (MkOpGeq x) = evaluateOp x
1008 evaluateOp (MkOpGt x) = evaluateOp x
1009 evaluateOp (MkOpHist x) = evaluateOp x
1010 evaluateOp (MkOpIff x) = evaluateOp x
1011 evaluateOp (MkOpImage x) = evaluateOp x
1012 evaluateOp (MkOpImageSet x) = evaluateOp x
1013 evaluateOp (MkOpImply x) = evaluateOp x
1014 evaluateOp (MkOpIn x) = evaluateOp x
1015 evaluateOp (MkOpIndexing x) = evaluateOp x
1016 evaluateOp (MkOpIntersect x) = evaluateOp x
1017 evaluateOp (MkOpInverse x) = evaluateOp x
1018 evaluateOp (MkOpLeq x) = evaluateOp x
1019 evaluateOp (MkOpLexLeq x) = evaluateOp x
1020 evaluateOp (MkOpLexLt x) = evaluateOp x
1021 evaluateOp (MkOpLt x) = evaluateOp x
1022 evaluateOp (MkOpMakeTable x) = evaluateOp x
1023 evaluateOp (MkOpMax x) = evaluateOp x
1024 evaluateOp (MkOpMin x) = evaluateOp x
1025 evaluateOp (MkOpMinus x) = evaluateOp x
1026 evaluateOp (MkOpMod x) = evaluateOp x
1027 evaluateOp (MkOpNegate x) = evaluateOp x
1028 evaluateOp (MkOpNeq x) = evaluateOp x
1029 evaluateOp (MkOpNot x) = evaluateOp x
1030 evaluateOp (MkOpOr x) = evaluateOp x
1031 evaluateOp (MkOpParticipants x) = evaluateOp x
1032 evaluateOp (MkOpParts x) = evaluateOp x
1033 evaluateOp (MkOpParty x) = evaluateOp x
1034 evaluateOp (MkOpPermInverse x) = evaluateOp x
1035 evaluateOp (MkOpPow x) = evaluateOp x
1036 evaluateOp (MkOpPowerSet x) = evaluateOp x
1037 evaluateOp (MkOpPred x) = evaluateOp x
1038 evaluateOp (MkOpPreImage x) = evaluateOp x
1039 evaluateOp (MkOpProduct x) = evaluateOp x
1040 evaluateOp (MkOpRange x) = evaluateOp x
1041 evaluateOp (MkOpRelationProj x) = evaluateOp x
1042 evaluateOp (MkOpRestrict x) = evaluateOp x
1043 evaluateOp (MkOpSlicing x) = evaluateOp x
1044 evaluateOp (MkOpSubsequence x) = evaluateOp x
1045 evaluateOp (MkOpSubset x) = evaluateOp x
1046 evaluateOp (MkOpSubsetEq x) = evaluateOp x
1047 evaluateOp (MkOpSubstring x) = evaluateOp x
1048 evaluateOp (MkOpSucc x) = evaluateOp x
1049 evaluateOp (MkOpSum x) = evaluateOp x
1050 evaluateOp (MkOpSupset x) = evaluateOp x
1051 evaluateOp (MkOpSupsetEq x) = evaluateOp x
1052 evaluateOp (MkOpTable x) = evaluateOp x
1053 evaluateOp (MkOpTildeLeq x) = evaluateOp x
1054 evaluateOp (MkOpTildeLt x) = evaluateOp x
1055 evaluateOp (MkOpTogether x) = evaluateOp x
1056 evaluateOp (MkOpToInt x) = evaluateOp x
1057 evaluateOp (MkOpToMSet x) = evaluateOp x
1058 evaluateOp (MkOpToRelation x) = evaluateOp x
1059 evaluateOp (MkOpToSet x) = evaluateOp x
1060 evaluateOp (MkOpTransform x) = evaluateOp x
1061 evaluateOp (MkOpTrue x) = evaluateOp x
1062 evaluateOp (MkOpTwoBars x) = evaluateOp x
1063 evaluateOp (MkOpUnion x) = evaluateOp x
1064 evaluateOp (MkOpXor x) = evaluateOp x
1065 evaluateOp (MkOpQuickPermutationOrder x) = evaluateOp x