never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2
3 module Conjure.Representations.Relation.RelationAsMatrix ( relationAsMatrix ) where
4
5 -- conjure
6 import Conjure.Prelude
7 import Conjure.Bug
8 import Conjure.Language
9 import Conjure.Representations.Internal
10 import Conjure.Representations.Common
11 import Conjure.Representations.Function.Function1D ( domainValues )
12
13
14 relationAsMatrix :: forall m . (MonadFailDoc m, NameGen m) => Representation m
15 relationAsMatrix = Representation chck downD structuralCons downC up symmetryOrdering
16
17 where
18
19 chck :: TypeOf_ReprCheck m
20 chck f (DomainRelation _ attrs innerDomains) | all domainCanIndexMatrix innerDomains =
21 map (DomainRelation Relation_AsMatrix attrs) . sequence <$> mapM f innerDomains
22 chck _ _ = return []
23
24 outName :: Domain HasRepresentation x -> Name -> Name
25 outName = mkOutName Nothing
26
27 downD :: TypeOf_DownD m
28 downD (name, domain@(DomainRelation Relation_AsMatrix _ innerDomains))
29 | all domainCanIndexMatrix innerDomains = do
30 let unroll is j = foldr DomainMatrix j is
31 return $ Just
32 [ ( outName domain name
33 , unroll (map forgetRepr innerDomains) DomainBool
34 ) ]
35 downD (name, domain) = na $ vcat [ "{downD} RelationAsMatrix"
36 , "name:" <+> pretty name
37 , "domain:" <+> pretty domain
38 ]
39
40 structuralCons :: TypeOf_Structural m
41 structuralCons _ downX1
42 (DomainRelation Relation_AsMatrix (RelationAttr sizeAttr binRelAttr) innerDomains)
43 | all domainCanIndexMatrix innerDomains = do
44 let cardinality m = do
45 let unroll _ [] = failDoc "RelationAsMatrix.cardinality.unroll []"
46 unroll n [dom] = do
47 (iPat, i) <- quantifiedVar
48 return [essence| sum &iPat : &dom . toInt(&n[&i]) |]
49 unroll n (dom : rest) = do
50 (iPat, i) <- quantifiedVar
51 r <- unroll [essence| &n[&i] |] rest
52 return [essence| sum &iPat : &dom . &r |]
53 unroll m innerDomains
54 return $ \ rel -> do
55 refs <- downX1 rel
56 case refs of
57 [m] -> do
58 binRelCons <- if binRelAttr == def then return [] else
59 case innerDomains of
60 [innerDomain1, innerDomain2]
61 | forgetRepr innerDomain1 == forgetRepr innerDomain2 ->
62 mkBinRelCons binRelAttr innerDomain1 rel
63 | otherwise ->
64 bug $ vcat [ "Binary relation between different domains. (RelationAsMatrix)"
65 , "innerDomain1:" <+> pretty innerDomain1
66 , "innerDomain2:" <+> pretty innerDomain2
67 ]
68 _ -> bug "Non-binary relation."
69 concat <$> sequence
70 [ mkSizeCons sizeAttr <$> cardinality m
71 , return binRelCons
72 ]
73 _ -> na "{structuralCons} RelationAsMatrix"
74 structuralCons _ _ _ = na "{structuralCons} RelationAsMatrix"
75
76 downC :: TypeOf_DownC m
77 downC ( name
78 , domain@(DomainRelation Relation_AsMatrix _ innerDomains)
79 , viewConstantRelation -> Just vals
80 ) | all domainCanIndexMatrix innerDomains = do
81 let
82 check :: [Constant] -> Bool
83 check indices = indices `elem` vals
84
85 let
86 unrollD :: [Domain () Constant] -> Domain r Constant -> Domain r Constant
87 unrollD is j = foldr DomainMatrix j is
88
89 let
90 unrollC :: MonadFail m
91 => [Domain () Constant]
92 -> [Constant] -- indices
93 -> m Constant
94 unrollC [i] prevIndices = do
95 domVals <- domainValues i
96 return $ ConstantAbstract $ AbsLitMatrix i
97 [ ConstantBool $ check $ prevIndices ++ [val]
98 | val <- domVals ]
99 unrollC (i:is) prevIndices = do
100 domVals <- domainValues i
101 matrixVals <- forM domVals $ \ val ->
102 unrollC is (prevIndices ++ [val])
103 return $ ConstantAbstract $ AbsLitMatrix i matrixVals
104 unrollC is prevIndices = failDoc $ vcat [ "RelationAsMatrix.up.unrollC"
105 , " is :" <+> vcat (map pretty is)
106 , " prevIndices:" <+> pretty (show prevIndices)
107 ]
108
109 outConstant <- unrollC (map forgetRepr innerDomains) []
110
111 return $ Just
112 [ ( outName domain name
113 , unrollD (map forgetRepr innerDomains) DomainBool
114 , outConstant
115 ) ]
116
117 downC (name, domain, constant) = na $ vcat [ "{downC} RelationAsMatrix"
118 , "name:" <+> pretty name
119 , "domain:" <+> pretty domain
120 , "constant:" <+> pretty constant
121 ]
122
123 up :: TypeOf_Up m
124 up ctxt (name, domain@(DomainRelation Relation_AsMatrix _ innerDomains)) =
125
126 case lookup (outName domain name) ctxt of
127 Nothing -> failDoc $ vcat $
128 [ "(in RelationAsMatrix up)"
129 , "No value for:" <+> pretty (outName domain name)
130 , "When working on:" <+> pretty name
131 , "With domain:" <+> pretty domain
132 ] ++
133 ("Bindings in context:" : prettyContext ctxt)
134 Just constant -> do
135 let
136 allIndices :: (MonadFailDoc m, Pretty r) => [Domain r Constant] -> m [[Constant]]
137 allIndices = fmap sequence . mapM domainValues
138
139 index :: MonadFailDoc m => Constant -> [Constant] -> m Constant
140 index m [] = return m
141 index (ConstantAbstract (AbsLitMatrix indexDomain vals)) (i:is) = do
142 froms <- domainValues indexDomain
143 case lookup i (zip froms vals) of
144 Nothing -> failDoc "Value not found. RelationAsMatrix.up.index"
145 Just v -> index v is
146 index m is = failDoc ("RelationAsMatrix.up.index" <+> pretty m <+> pretty (show is))
147
148 indices <- allIndices innerDomains
149 vals <- forM indices $ \ these -> do
150 indexed <- index constant these
151 case viewConstantBool indexed of
152 Just False -> return Nothing
153 Just True -> return (Just these)
154 _ -> failDoc $ vcat
155 [ "Expecting a boolean literal, but got:" <++> pretty indexed
156 , "When working on:" <+> pretty name
157 , "With domain:" <+> pretty domain
158 ]
159
160 return ( name
161 , ConstantAbstract $ AbsLitRelation $ catMaybes vals
162 )
163 up _ (name, domain) = na $ vcat [ "{up} RelationAsMatrix"
164 , "name:" <+> pretty name
165 , "domain:" <+> pretty domain
166 ]
167
168 symmetryOrdering :: TypeOf_SymmetryOrdering m
169 symmetryOrdering innerSO downX1 inp domain = do
170 [inner] <- downX1 inp
171 Just [(_, innerDomain)] <- downD ("SO", domain)
172 innerSO downX1 inner innerDomain