never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2
3 module Conjure.Representations.Set.ExplicitVarSizeWithMarker ( setExplicitVarSizeWithMarker ) 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 setExplicitVarSizeWithMarker :: forall m . (MonadFailDoc m, NameGen m, EnumerateDomain m) => Representation m
16 setExplicitVarSizeWithMarker = Representation chck downD structuralCons downC up symmetryOrdering
17
18 where
19
20 chck :: TypeOf_ReprCheck m
21 chck _ (DomainSet _ (SetAttr SizeAttr_Size{}) _) = return []
22 chck f (DomainSet _ attrs innerDomain) = map (DomainSet Set_ExplicitVarSizeWithMarker attrs) <$> f innerDomain
23 chck _ _ = return []
24
25 nameMarker = mkOutName (Just "Marker")
26 nameValues = mkOutName (Just "Values")
27
28 getMaxSize attrs innerDomain = case attrs of
29 SizeAttr_MaxSize x -> return x
30 SizeAttr_MinMaxSize _ x -> return x
31 _ -> reTag TagInt <$> domainSizeOf innerDomain
32
33 downD :: TypeOf_DownD m
34 downD (name, domain@(DomainSet _ (SetAttr attrs) innerDomain)) = do
35 maxSize <- getMaxSize attrs innerDomain
36 let indexDomain i = mkDomainIntB (fromInt i) maxSize
37 return $ Just
38 [ ( nameMarker domain name
39 , defRepr (indexDomain 0)
40 )
41 , ( nameValues domain name
42 , DomainMatrix (indexDomain 1) innerDomain
43 )
44 ]
45 downD _ = na "{downD} ExplicitVarSizeWithMarker"
46
47 structuralCons :: TypeOf_Structural m
48 structuralCons f downX1 (DomainSet Set_ExplicitVarSizeWithMarker (SetAttr attrs) innerDomain) = do
49 maxSize <- getMaxSize attrs innerDomain
50 let
51 orderingUpToMarker marker values = do
52 (iPat, i) <- quantifiedVar
53 return $ return $ -- list
54 [essence|
55 forAll &iPat : int(1..&maxSize-1) . &i + 1 <= &marker ->
56 &values[&i] .< &values[&i+1]
57 |]
58
59 dontCareAfterMarker marker values = do
60 (iPat, i) <- quantifiedVar
61 return $ return $ -- list
62 [essence|
63 forAll &iPat : int(1..&maxSize) . &i > &marker ->
64 dontCare(&values[&i])
65 |]
66
67 innerStructuralCons marker values = do
68 let overDomain = [essenceDomain| int(1..&maxSize) |]
69 (iPat, i) <- quantifiedVarOverDomain overDomain
70 let activeZone b = [essence| forAll &iPat : &overDomain . &i <= &marker -> &b |]
71
72 -- preparing structural constraints for the inner guys
73 innerStructuralConsGen <- f innerDomain
74
75 let inLoop = [essence| &values[&i] |]
76 outs <- innerStructuralConsGen inLoop
77 return (map activeZone outs)
78
79 return $ \ set -> do
80 refs <- downX1 set
81 case refs of
82 [marker,values] ->
83 concat <$> sequence
84 [ orderingUpToMarker marker values
85 , dontCareAfterMarker marker values
86 , return (mkSizeCons attrs marker)
87 , innerStructuralCons marker values
88 ]
89 _ -> na "{structuralCons} ExplicitVarSizeWithMarker"
90
91 structuralCons _ _ _ = na "{structuralCons} ExplicitVarSizeWithMarker"
92
93 downC :: TypeOf_DownC m
94 downC ( name
95 , domain@(DomainSet _ (SetAttr attrs) innerDomain)
96 , viewConstantSet -> Just constants
97 ) = do
98 maxSize <- getMaxSize attrs innerDomain
99 let indexDomain i = mkDomainIntB (fromInt i) maxSize
100 maxSizeInt <-
101 case maxSize of
102 ConstantInt _ x -> return x
103 _ -> failDoc $ vcat
104 [ "Expecting an integer for the maxSize attribute."
105 , "But got:" <+> pretty maxSize
106 , "When working on:" <+> pretty name
107 , "With domain:" <+> pretty domain
108 ]
109 z <- zeroVal innerDomain
110 let zeroes = replicate (fromInteger (maxSizeInt - genericLength constants)) z
111 return $ Just
112 [ ( nameMarker domain name
113 , defRepr (indexDomain 0)
114 , ConstantInt TagInt (genericLength constants)
115 )
116 , ( nameValues domain name
117 , DomainMatrix (indexDomain 1) innerDomain
118 , ConstantAbstract $ AbsLitMatrix (indexDomain 1) (constants ++ zeroes)
119 )
120 ]
121 downC _ = na "{downC} ExplicitVarSizeWithMarker"
122
123 up :: TypeOf_Up m
124 up ctxt (name, domain) =
125 case (lookup (nameMarker domain name) ctxt, lookup (nameValues domain name) ctxt) of
126 (Just marker, Just constantMatrix) ->
127 case marker of
128 ConstantInt _ card ->
129 case (viewConstantMatrix constantMatrix, constantMatrix) of
130 (Just (_, vals), _) ->
131 return (name, ConstantAbstract (AbsLitSet (genericTake card vals)))
132 (_, ConstantUndefined msg ty) -> -- undefined propagates
133 return (name, ConstantUndefined ("Set-ExplicitVarSizeWithMarker " `mappend` msg) ty)
134 _ -> failDoc $ vcat
135 [ "Expecting a matrix literal for:" <+> pretty (nameValues domain name)
136 , "But got:" <+> pretty constantMatrix
137 , "When working on:" <+> pretty name
138 , "With domain:" <+> pretty domain
139 ]
140 _ -> failDoc $ vcat
141 [ "Expecting an integer literal for:" <+> pretty (nameMarker domain name)
142 , "But got:" <+> pretty marker
143 , "When working on:" <+> pretty name
144 , "With domain:" <+> pretty domain
145 ]
146 (Nothing, _) -> failDoc $ vcat $
147 [ "(in Set ExplicitVarSizeWithMarker up 1)"
148 , "No value for:" <+> pretty (nameMarker domain name)
149 , "When working on:" <+> pretty name
150 , "With domain:" <+> pretty domain
151 ] ++
152 ("Bindings in context:" : prettyContext ctxt)
153 (_, Nothing) -> failDoc $ vcat $
154 [ "(in Set ExplicitVarSizeWithMarker up 2)"
155 , "No value for:" <+> pretty (nameValues domain name)
156 , "When working on:" <+> pretty name
157 , "With domain:" <+> pretty domain
158 ] ++
159 ("Bindings in context:" : prettyContext ctxt)
160
161 symmetryOrdering :: TypeOf_SymmetryOrdering m
162 symmetryOrdering innerSO downX1 inp domain = do
163 [marker, values] <- downX1 inp
164 Just [_, (_, DomainMatrix index inner)] <- downD ("SO", domain)
165 (iPat, i) <- quantifiedVar
166 soValues <- innerSO downX1 [essence| &values[&i] |] inner
167 return
168 [essence|
169 ( &marker
170 ,[ &soValues
171 | &iPat : &index
172 ]
173 )
174 |]
175