never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Representations.Set.Occurrence ( setOccurrence ) where
    4 
    5 -- conjure
    6 import Conjure.Prelude hiding (MonadFail,fail)
    7 import Conjure.Language
    8 import Conjure.Representations.Internal
    9 import Conjure.Representations.Common
   10 
   11 import Control.Monad.Fail
   12 
   13 
   14 setOccurrence :: forall m . (MonadFailDoc m, NameGen m) => Representation m
   15 setOccurrence = Representation chck downD structuralCons downC up symmetryOrdering
   16 
   17     where
   18 
   19         -- | We can only represent Set of Int as occurrence
   20         chck :: TypeOf_ReprCheck m
   21         chck f (DomainSet _ attrs innerDomain@DomainInt{}) =
   22           map (DomainSet Set_Occurrence attrs) <$> f innerDomain
   23         chck _ _ = return []
   24 
   25         outName :: Domain HasRepresentation x -> Name -> Name
   26         outName = mkOutName Nothing
   27 
   28         -- | Matrix of Bool indexed by inner domain of set (which must be an int domain)
   29         downD :: TypeOf_DownD m
   30         downD (name, domain@(DomainSet Set_Occurrence _attrs innerDomain@DomainInt{})) = return $ Just
   31             [ ( outName domain name
   32               , DomainMatrix (forgetRepr innerDomain) DomainBool
   33               )
   34             ]
   35         downD _ = na "{downD} Occurrence"
   36 
   37         -- | Constrain number of trues in matrix to be congruent with cardinality constraint
   38         structuralCons :: TypeOf_Structural m
   39         structuralCons _ downX1 (DomainSet Set_Occurrence (SetAttr attrs) innerDomain@DomainInt{}) =
   40             return $ \ set -> do
   41                 refs <- downX1 set
   42                 case refs of
   43                     [m] -> do
   44                         (iPat, i) <- quantifiedVar
   45                         let cardinality = [essence| sum &iPat : &innerDomain . toInt(&m[&i]) |]
   46                         return (mkSizeCons attrs cardinality)
   47                     _ -> na "{structuralCons} Occurrence"
   48         structuralCons _ _ _ = na "{structuralCons} Occurrence"
   49 
   50         -- | If value is in the set then that value's index maps to a bool
   51         downC :: TypeOf_DownC m
   52         downC ( name
   53               , domain@(DomainSet Set_Occurrence _attrs innerDomain@(DomainInt t intRanges))
   54               , viewConstantSet -> Just constants
   55               ) = do
   56                 innerDomainVals <- valuesInIntDomain intRanges
   57                 return $ Just
   58                     [ ( outName domain name
   59                       , DomainMatrix (forgetRepr innerDomain) DomainBool
   60                       , ConstantAbstract $ AbsLitMatrix (forgetRepr innerDomain)
   61                           [ ConstantBool isIn
   62                           | v <- innerDomainVals
   63                           , let isIn = ConstantInt t v `elem` constants
   64                           ]
   65                       )
   66                     ]
   67         downC _ = na "{downC} Occurrence"
   68 
   69         -- | Reversal of downC - if innerDom value zips with matrix true then it's in
   70         up :: TypeOf_Up m
   71         up ctxt (name, domain@(DomainSet _ _ (DomainInt t intRanges)))=
   72             case lookup (outName domain name) ctxt of
   73                 Just constantMatrix ->
   74                     case viewConstantMatrix constantMatrix of
   75                         Just (_, vals) -> do
   76                             innerDomainVals <- valuesInIntDomain intRanges
   77                             return (name, ConstantAbstract $ AbsLitSet
   78                                             [ ConstantInt t v
   79                                             | (v,b) <- zip innerDomainVals vals
   80                                             , viewConstantBool b == Just True
   81                                             ] )
   82                         _ -> failDoc $ vcat
   83                                 [ "Expecting a matrix literal for:" <+> pretty (outName domain name)
   84                                 , "But got:" <+> pretty constantMatrix
   85                                 , "When working on:" <+> pretty name
   86                                 , "With domain:" <+> pretty domain
   87                                 ]
   88                 Nothing -> failDoc $ vcat $
   89                     [ "(in Set Occurrence up)"
   90                     , "No value for:" <+> pretty (outName domain name)
   91                     , "When working on:" <+> pretty name
   92                     , "With domain:" <+> pretty domain
   93                     ] ++
   94                     ("Bindings in context:" : prettyContext ctxt)
   95         up _ _ = na "{up} Occurrence"
   96 
   97         -- produce a [int]
   98         symmetryOrdering :: (MonadFail m) => TypeOf_SymmetryOrdering m
   99         symmetryOrdering _innerSO downX1 inp (DomainSet Set_Occurrence _attrs innerDomain) = do
  100             [m] <- downX1 inp
  101             (iPat, i) <- quantifiedVar
  102             return [essence| [ -toInt(&m[&i]) | &iPat : &innerDomain ] |]
  103         symmetryOrdering _ _ _ _ = na "{symmetryOrdering} Occurrence"