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