never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2 {-# LANGUAGE Rank2Types #-}
3 {-# LANGUAGE RecordWildCards #-}
4 {-# LANGUAGE ViewPatterns #-}
5
6 module Conjure.Representations.Permutation.PermutationAsFunction (permutationAsFunction) where
7
8 -- conjure
9
10 import Conjure.Language
11 import Conjure.Language.DomainSizeOf
12 import Conjure.Language.Expression.DomainSizeOf ()
13 import Conjure.Prelude
14 import Conjure.Process.Enumerate
15 import Conjure.Representations.Common
16 import Conjure.Representations.Internal
17 import Conjure.Util.Permutation
18
19 permutationAsFunction ::
20 forall m.
21 (MonadFailDoc m, NameGen m, EnumerateDomain m) =>
22 (forall x. DispatchFunction m x) ->
23 Representation m
24 permutationAsFunction dispatch = Representation chck downD structuralCons downC up symmetryOrdering
25 where
26 chck :: TypeOf_ReprCheck m
27 chck f (DomainPermutation _ s innerDomain)
28 | domainCanIndexMatrix innerDomain =
29 map (DomainPermutation Permutation_AsFunction s) <$> f innerDomain
30 chck _ _ = return []
31
32 outNameF :: Domain HasRepresentation x -> Name -> Name
33 outNameF = mkOutName (Just "PermutationFunction_forwards")
34
35 outNameB :: Domain HasRepresentation x -> Name -> Name
36 outNameB = mkOutName (Just "PermutationFunction_backwards")
37
38 outDomain :: (DomainSizeOf x x, Pretty x) => Domain HasRepresentation x -> m (Domain HasRepresentation x)
39 outDomain (DomainPermutation Permutation_AsFunction _ innerDomain) = do
40 s <- domainSizeOf innerDomain
41 return
42 ( DomainFunction
43 Function_1D
44 (FunctionAttr (SizeAttr_Size s) PartialityAttr_Total JectivityAttr_Bijective)
45 innerDomain
46 innerDomain
47 )
48 outDomain domain =
49 na
50 $ vcat
51 [ "{outDomain} PermutationAsFunction",
52 "domain:" <+> pretty domain
53 ]
54
55 downD :: TypeOf_DownD m
56 downD (name, domain@(DomainPermutation Permutation_AsFunction _ innerDomain))
57 | domainCanIndexMatrix innerDomain = do
58 m <- domainSizeOf innerDomain
59 return
60 $ Just
61 [ ( outNameF domain name,
62 DomainFunction
63 Function_1D
64 (FunctionAttr (SizeAttr_Size m) PartialityAttr_Total JectivityAttr_Bijective)
65 innerDomain
66 innerDomain
67 ),
68 ( outNameB domain name,
69 DomainFunction
70 Function_1D
71 (FunctionAttr (SizeAttr_Size m) PartialityAttr_Total JectivityAttr_Bijective)
72 innerDomain
73 innerDomain
74 )
75 ]
76 downD _ = na "{downD} AsFunction"
77
78 structuralCons :: TypeOf_Structural m
79 structuralCons f downX1 inDom@(DomainPermutation _ (PermutationAttr s) innerDom) =
80 return $ \inpFun -> do
81 refs <- downX1 inpFun
82 case refs of
83 [forw, back] -> do
84 outDom <- outDomain inDom
85 innerStructuralConsGen <- f outDom
86 (iPat, i) <- quantifiedVarOverDomain (forgetRepr innerDom)
87 concat
88 <$> sequence
89 [ innerStructuralConsGen forw,
90 innerStructuralConsGen back,
91 return $ mkSizeCons s [essence| sum([ toInt(&i != image(&forw, &i)) | &iPat : &innerDom ]) |],
92 return [[essence| forAll &iPat : &innerDom . &back(&forw(&i)) = &i |]],
93 return [[essence| forAll &iPat : &innerDom . &forw(&back(&i)) = &i |]]
94 ]
95 _ ->
96 na
97 $ vcat
98 [ "{structuralCons} PermutationAsFunction",
99 pretty inDom
100 ]
101 structuralCons _ _ inDom =
102 na
103 $ vcat
104 [ "{structuralCons} PermutationAsFunction",
105 pretty inDom
106 ]
107
108 downC :: TypeOf_DownC m
109 downC
110 ( name,
111 inDom@(DomainPermutation Permutation_AsFunction _ innerDom),
112 ConstantAbstract (AbsLitPermutation vals)
113 ) = do
114 outDom <- outDomain inDom
115 enumDo <- enumerateDomain $ forgetRepr innerDom
116 case (fromCycles vals, inverse <$> fromCycles vals) of
117 (Right perm1, Right perm2) -> do
118 out1 <-
119 rDownC
120 (dispatch outDom)
121 ( outNameF inDom name,
122 outDom,
123 ConstantAbstract $ AbsLitFunction $ zip enumDo (toFunction perm1 <$> enumDo)
124 )
125 out2 <-
126 rDownC
127 (dispatch outDom)
128 ( outNameB inDom name,
129 outDom,
130 ConstantAbstract $ AbsLitFunction $ zip enumDo (toFunction perm2 <$> enumDo)
131 )
132 return $ Just (fromMaybe [] out1 ++ fromMaybe [] out2)
133 (Left (PermutationError err), _) -> failDoc $ "PermutationError: " <+> stringToDoc err
134 (_, Left (PermutationError err)) -> failDoc $ "PermutationError: " <+> stringToDoc err
135 downC (name, domain, constant) =
136 na
137 $ vcat
138 [ "{downC} PermutationAsFunction",
139 "name:" <+> pretty name,
140 "domain:" <+> pretty domain,
141 "constant:" <+> pretty constant
142 ]
143
144 up :: TypeOf_Up m
145 up
146 ctxt
147 ( name,
148 domain@(DomainPermutation Permutation_AsFunction {} _ _)
149 ) = do
150 case lookup (outNameF domain name) ctxt of
151 (Just (ConstantAbstract (AbsLitFunction f))) -> do
152 case toCyclesCanonical <$> fromRelation f of
153 Right cycles ->
154 return (name, ConstantAbstract (AbsLitPermutation cycles))
155 Left (PermutationError err) ->
156 failDoc
157 $ vcat
158 $ [ "PermutationError: " <+> stringToDoc err,
159 "No value for:" <+> pretty (outNameF domain name),
160 "When working on:" <+> pretty name,
161 "With domain:" <+> pretty domain
162 ]
163 ++ ("Bindings in context:" : prettyContext ctxt)
164 _ ->
165 failDoc
166 $ vcat
167 $ [ "No value for:" <+> pretty (outNameF domain name),
168 "When working on:" <+> pretty name,
169 "With domain:" <+> pretty domain
170 ]
171 ++ ("Bindings in context:" : prettyContext ctxt)
172 up _ (name, domain) =
173 na
174 $ vcat
175 [ "{up} PermutationAsFunction",
176 "name:" <+> pretty name,
177 "domain:" <+> pretty domain
178 ]
179
180 symmetryOrdering :: TypeOf_SymmetryOrdering m
181 symmetryOrdering innerSO downX1 inp domain = do
182 [x, y] <- downX1 inp
183 Just [(_, xDomain), (_, yDomain)] <- downD ("SO", domain)
184 xs <- innerSO downX1 x xDomain
185 ys <- innerSO downX1 y yDomain
186 return [essence| concatenate([&xs, &ys]) |]