never executed always true always false
    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Representations.MSet.ExplicitWithRepetition ( msetExplicitWithRepetition ) where
    4 
    5 -- conjure
    6 import Conjure.Prelude
    7 import Conjure.Language
    8 import Conjure.Language.DomainSizeOf
    9 import Conjure.Language.Expression.DomainSizeOf ()
   10 import Conjure.Language.ZeroVal ( zeroVal, EnumerateDomain )
   11 import Conjure.Representations.Internal
   12 import Conjure.Representations.Common
   13 
   14 
   15 msetExplicitWithRepetition :: forall m . (MonadFailDoc m, NameGen m, EnumerateDomain m) => Representation m
   16 msetExplicitWithRepetition = Representation chck downD structuralCons downC up symmetryOrdering
   17 
   18     where
   19 
   20         chck :: TypeOf_ReprCheck m
   21         chck f (DomainMSet _ attrs innerDomain) =
   22             map (DomainMSet MSet_ExplicitWithRepetition attrs) <$> f innerDomain
   23         chck _ _ = return []
   24 
   25         nameFlag   = mkOutName (Just "Flag")
   26         nameValues = mkOutName (Just "Values")
   27 
   28         getMaxSize attrs innerDomain = case attrs of
   29             MSetAttr (SizeAttr_Size x) _ -> return x
   30             MSetAttr (SizeAttr_MaxSize x) _ -> return x
   31             MSetAttr (SizeAttr_MinMaxSize _ x) _ -> return x
   32             MSetAttr _ (OccurAttr_MaxOccur x) -> do y <- domainSizeOf innerDomain ; return (x * y)
   33             MSetAttr _ (OccurAttr_MinMaxOccur _ x) -> do y <- domainSizeOf innerDomain ; return (x * y)
   34             _ -> failDoc ("getMaxSize, mset not supported. attributes:" <+> pretty attrs)
   35 
   36         getMinOccur attrs = case attrs of
   37             MSetAttr _ (OccurAttr_MinOccur x) -> Just x
   38             MSetAttr _ (OccurAttr_MinMaxOccur x _) -> Just x
   39             _ -> Nothing
   40 
   41         getMaxOccur attrs = case attrs of
   42             MSetAttr _ (OccurAttr_MaxOccur x) -> return x
   43             MSetAttr _ (OccurAttr_MinMaxOccur _ x) -> return x
   44             _ -> failDoc ("getMaxOccur, mset not supported. attributes:" <+> pretty attrs)
   45 
   46         downD :: TypeOf_DownD m
   47         downD (name, domain@(DomainMSet _ attrs innerDomain)) = do
   48             (indexDomain, flagDomain) <-
   49                 case attrs of
   50                     MSetAttr (SizeAttr_Size size) _ -> do
   51                         let indexDomain = mkDomainIntB 1 size
   52                         let flagDomain  = defRepr $ DomainInt TagInt [RangeSingle size]
   53                         return (indexDomain, flagDomain)
   54                     _ -> do
   55                         maxSize <- getMaxSize attrs innerDomain
   56                         let indexDomain =           mkDomainIntB 1 maxSize
   57                         let flagDomain  = defRepr $ mkDomainIntB 0 maxSize
   58                         return (indexDomain, flagDomain)
   59             return $ Just
   60                 [ ( nameFlag domain name
   61                   , flagDomain
   62                   )
   63                 , ( nameValues domain name
   64                   , DomainMatrix indexDomain innerDomain
   65                   )
   66                 ]
   67         downD _ = na "{downD} ExplicitVarSizeWithRepetition"
   68 
   69         structuralCons :: TypeOf_Structural m
   70         structuralCons f downX1 (DomainMSet MSet_ExplicitWithRepetition attrs@(MSetAttr sizeAttrs _) innerDomain) = do
   71             maxSize <- getMaxSize attrs innerDomain
   72             let maxIndex = maxSize
   73             let
   74                 orderingUpToFlag flag values = do
   75                     (iPat, i) <- quantifiedVar
   76                     return $ return $ -- list
   77                         [essence|
   78                             forAll &iPat : int(1..&maxIndex-1) , &i+1 <= &flag . &values[&i] .<= &values[&i+1]
   79                         |]
   80 
   81                 dontCareAfterFlag flag values = do
   82                     (iPat, i) <- quantifiedVar
   83                     return $ return $ -- list
   84                         [essence|
   85                             forAll &iPat : int(1..&maxIndex) , &i > &flag . dontCare(&values[&i])
   86                         |]
   87 
   88                 minOccurrenceCons mset = do
   89                     (iPat, i) <- quantifiedVar
   90                     return
   91                         [ [essence|
   92                             forAll &iPat : &innerDomain .
   93                                 freq(&mset, &i) >= &minOccur
   94                                   |]
   95                         | Just minOccur <- [getMinOccur attrs]
   96                         ]
   97 
   98                 maxOccurrenceCons mset flag values = do
   99                     (iPat, i) <- quantifiedVar
  100                     return
  101                         [ [essence|
  102                             forAll &iPat : int(1..&maxIndex) , &i <= &flag .
  103                                 freq(&mset, &values[&i]) <= &maxOccur_
  104                                   |]
  105                         | Just maxOccur_ <- [getMaxOccur attrs]
  106                         ]
  107 
  108                 innerStructuralCons flag values = do
  109                     (iPat, i) <- quantifiedVarOverDomain [essenceDomain| int(1..&maxIndex) |]
  110                     let activeZone b = [essence| forAll &iPat : int(1..&maxIndex) , &i <= &flag . &b |]
  111 
  112                     -- preparing structural constraints for the inner guys
  113                     innerStructuralConsGen <- f innerDomain
  114 
  115                     let inLoop = [essence| &values[&i] |]
  116                     outs <- innerStructuralConsGen inLoop
  117                     return (map activeZone outs)
  118 
  119             return $ \ mset -> do
  120                 refs <- downX1 mset
  121                 case refs of
  122                     [flag, values] ->
  123                         concat <$> sequence
  124                             [ orderingUpToFlag  flag values
  125                             , dontCareAfterFlag flag values
  126                             , minOccurrenceCons mset
  127                             , maxOccurrenceCons mset flag values
  128                             , return (mkSizeCons sizeAttrs flag)
  129                             , innerStructuralCons flag values
  130                             ]
  131                     _ -> na "{structuralCons} ExplicitVarSizeWithRepetition"
  132 
  133         structuralCons _ _ _ = na "{structuralCons} ExplicitVarSizeWithRepetition"
  134 
  135         downC :: TypeOf_DownC m
  136         downC ( name
  137               , domain@(DomainMSet _ attrs innerDomain)
  138               , viewConstantMSet -> Just constants
  139               ) = case attrs of
  140                     MSetAttr (SizeAttr_Size size) _ -> do
  141                         let indexDomain = mkDomainIntB 1 size
  142                         let flagDomain  = DomainInt TagInt [RangeSingle size]
  143 
  144                         return $ Just
  145                             [ ( nameFlag domain name
  146                               , defRepr flagDomain
  147                               , ConstantInt TagInt (genericLength constants)
  148                               )
  149                             , ( nameValues domain name
  150                               , DomainMatrix indexDomain innerDomain
  151                               , ConstantAbstract $ AbsLitMatrix indexDomain constants
  152                               )
  153                             ]
  154 
  155                     _ -> do
  156                         maxSize    <- getMaxSize attrs innerDomain
  157                         maxSizeInt <-
  158                             case maxSize of
  159                                 ConstantInt _ x -> return x
  160                                 _ -> failDoc $ vcat
  161                                         [ "Expecting an integer for the maxSize attribute."
  162                                         , "But got:" <+> pretty maxSize
  163                                         , "When working on:" <+> pretty name
  164                                         , "With domain:" <+> pretty domain
  165                                         ]
  166                         let indexDomain = mkDomainIntB 1 maxSize
  167                         let flagDomain  = mkDomainIntB 0 maxSize
  168 
  169                         z <- zeroVal innerDomain
  170                         let zeroes = replicate (fromInteger (maxSizeInt - genericLength constants)) z
  171 
  172                         return $ Just
  173                             [ ( nameFlag domain name
  174                               , defRepr flagDomain
  175                               , ConstantInt TagInt (genericLength constants)
  176                               )
  177                             , ( nameValues domain name
  178                               , DomainMatrix indexDomain innerDomain
  179                               , ConstantAbstract $ AbsLitMatrix indexDomain (constants ++ zeroes)
  180                               )
  181                             ]
  182 
  183         downC _ = na "{downC} ExplicitVarSizeWithRepetition"
  184 
  185         up :: TypeOf_Up m
  186         up ctxt (name, domain) =
  187             case (lookup (nameFlag domain name) ctxt, lookup (nameValues domain name) ctxt) of
  188                 (Just flag, Just constantMatrix) ->
  189                     case viewConstantInt flag of
  190                         -- TODO: check if indices match
  191                         Just flagInt ->
  192                             case viewConstantMatrix constantMatrix of
  193                                 Just (_, vals) ->
  194                                     return (name, ConstantAbstract $ AbsLitMSet
  195                                                     (genericTake flagInt vals) )
  196                                 _ -> failDoc $ vcat
  197                                         [ "Expecting a matrix literal for:" <+> pretty (nameValues domain name)
  198                                         , "But got:" <+> pretty constantMatrix
  199                                         , "When working on:" <+> pretty name
  200                                         , "With domain:" <+> pretty domain
  201                                         ]
  202                         _ -> failDoc $ vcat
  203                                 [ "Expecting an integer literal for:" <+> pretty (nameFlag domain name)
  204                                 , "But got:" <+> pretty flag
  205                                 , "When working on:" <+> pretty name
  206                                 , "With domain:" <+> pretty domain
  207                                 ]
  208                 (Nothing, _) -> failDoc $ vcat $
  209                     [ "(in MSet ExplicitVarSizeWithRepetition up 1)"
  210                     , "No value for:" <+> pretty (nameFlag domain name)
  211                     , "When working on:" <+> pretty name
  212                     , "With domain:" <+> pretty domain
  213                     ] ++
  214                     ("Bindings in context:" : prettyContext ctxt)
  215                 (_, Nothing) -> failDoc $ vcat $
  216                     [ "(in MSet ExplicitVarSizeWithRepetition up 2)"
  217                     , "No value for:" <+> pretty (nameValues domain name)
  218                     , "When working on:" <+> pretty name
  219                     , "With domain:" <+> pretty domain
  220                     ] ++
  221                     ("Bindings in context:" : prettyContext ctxt)
  222 
  223         symmetryOrdering :: TypeOf_SymmetryOrdering m
  224         symmetryOrdering innerSO downX1 inp domain = do
  225             [marker, values] <- downX1 inp
  226             Just [_, (_, DomainMatrix index inner)] <- downD ("SO", domain)
  227             (iPat, i) <- quantifiedVar
  228             soValues <- innerSO downX1 [essence| &values[&i] |] inner
  229             return
  230                 [essence|
  231                     ( &marker
  232                     , [ &soValues
  233                       | &iPat : &index
  234                       ]
  235                     )
  236                 |]
  237