1 2 -- ==========================================================-- 3 -- === Constructor functions ===-- 4 -- === Constructors.hs ===-- 5 -- ==========================================================-- 6 7 module Constructors where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 import DomainExpr 12 import AbstractVals2 13 import SuccsAndPreds2 14 import AbstractMisc 15 import Inverse 16 import Apply 17 18 -- ==========================================================-- 19 -- 20 coMakeConstructorInstance :: Bool -> -- True == use mindless inverse 21 [ConstrElem] -> -- tells about constructor args 22 DExpr -> -- simplest instance expression 23 DSubst -> -- domain of use 24 Route 25 26 coMakeConstructorInstance mi cargs simplest_init usage 27 = let 28 ---------------------------------------------------------------- 29 -- Find out whether the constructor has zero arity, and -- 30 -- prepare a relevant domain expression for it. -- 31 ---------------------------------------------------------------- 32 33 (doCAFkludge, simplest) 34 = case simplest_init of 35 dx@(DXFunc _ _) -> (False, dx) 36 dx_CAF -> (True, DXFunc [] dx_CAF) 37 38 ---------------------------------------------------------------- 39 -- Find out if it is a recursive type. -- 40 ---------------------------------------------------------------- 41 42 recursive 43 = case simplest of 44 DXFunc _ (DXLift1 _) -> False 45 DXFunc _ (DXLift2 _) -> True 46 anythingElse -> panic "coMakeConstructorInstance:recursive" 47 48 actual 49 = dxApplyDSubst usage simplest 50 51 (actualSources, actualTarget) 52 = case actual of Func dss dt -> (dss, dt) 53 54 ---------------------------------------------------------------- 55 -- -- 56 ---------------------------------------------------------------- 57 58 (target_domain_products, points_below_structure_point) 59 = case (recursive, actualTarget) of 60 (True, Lift2 dts) -> (dts, [Stop2, Up2]) 61 (True, Lift1 [Two]) -> (panic "cMCI(1)", [Stop1, Up1 [Zero]]) 62 (False, Lift1 dts) -> (dts, [Stop1]) 63 (False, Two) -> (panic "cMCI(2)", [Zero]) 64 65 all_product_points 66 = myCartesianProduct (map amAllRoutes target_domain_products) 67 68 points_not_below_structure_point 69 = case (recursive, actualTarget) of 70 (True, Lift2 dts) -> map UpUp2 all_product_points 71 (True, Lift1 [Two]) -> [Up1 [One]] 72 (False, Lift1 dts) -> map Up1 all_product_points 73 (False, Two) -> [One] 74 75 tagTable 76 = [(p, arg_bottoms) 77 | p <- points_below_structure_point] ++ 78 [(p, [MkFrel (map (magic p) cargs)]) 79 | p <- points_not_below_structure_point] 80 81 arg_bottoms 82 = [MkFrel (map avBottomR actualSources)] 83 84 ---------------------------------------------------------------- 85 -- -- 86 ---------------------------------------------------------------- 87 88 magic p ConstrRec = p 89 magic p (ConstrVar n) = xpts p ## n 90 91 xpts p 92 | recursive = case p of UpUp2 rs -> rs 93 | otherwise = case p of Up1 rs -> rs 94 95 ---------------------------------------------------------------- 96 -- -- 97 ---------------------------------------------------------------- 98 99 in 100 if doCAFkludge 101 then apPapConst (coCGen_aux mi tagTable actual) 102 else Rep (coCGen_aux mi tagTable actual) 103 104 105 -- ==========================================================-- 106 -- 107 coCGen_aux :: Bool -> 108 AList Route [FrontierElem] -> -- the tag/value table 109 Domain -> -- domain of the function to be made 110 Rep 111 112 coCGen_aux mi tt (Func dss Two) 113 = let f1 = sort (utSureLookup tt "coCGen_aux(1)" One) 114 f0 = spMax0FromMin1 dss f1 115 ar = case head (f1 ++ f0) of MkFrel fels -> length fels 116 in RepTwo (Min1Max0 ar f1 f0) 117 118 coCGen_aux mi tt (Func dss (Lift1 dts)) 119 = let lf_f1 = sort (utSureLookup tt "coCGen_aux(2)" (Up1 (map avBottomR dts))) 120 lf_f0 = spMax0FromMin1 dss lf_f1 121 lf_ar = length dss 122 newtt = [(rs, fels) | (Up1 rs, fels) <- tt] 123 in 124 Rep1 (Min1Max0 lf_ar lf_f1 lf_f0) 125 (coCGen_aux_cross mi newtt dss dts) 126 127 coCGen_aux mi tt (Func dss (Lift2 dts)) 128 = let lf_f1 = sort (utSureLookup tt "coCGen_aux(2)" Up2) 129 lf_f0 = spMax0FromMin1 dss lf_f1 130 mf_f1 = sort (utSureLookup tt "coCGen_aux(3)" (UpUp2 (map avBottomR dts))) 131 mf_f0 = spMax0FromMin1 dss mf_f1 132 lf_ar = length dss 133 newtt = [(rs, fels) | (UpUp2 rs, fels) <- tt] 134 in 135 Rep2 (Min1Max0 lf_ar lf_f1 lf_f0) 136 (Min1Max0 lf_ar mf_f1 mf_f0) 137 (coCGen_aux_cross mi newtt dss dts) 138 139 coCGen_aux mi tt (Func dss gDomain@(Func dss2 dt)) 140 = let newtt = map makenewtt (amAllRoutes dt) 141 makenewtt x 142 = (x, 143 avMinfrel [MkFrel (xs++ys) 144 | (g, min_args_to_get_g) <- tt, 145 MkFrel xs <- min_args_to_get_g, 146 MkFrel ys <- inMinInverse mi gDomain g x] ) 147 -- *** don't know if the avMinfrel is really necessary *** -- 148 in coCGen_aux mi newtt (Func (dss++dss2) dt) 149 150 151 -- ==========================================================-- 152 -- 153 coCGen_aux_cross :: Bool -> 154 AList [Route] [FrontierElem] -> 155 [Domain] -> 156 [Domain] -> 157 [Rep] 158 159 coCGen_aux_cross mi tt dss dts 160 = let numberOfDimensions 161 = length dts 162 doOneDimension n 163 = coCGen_aux mi (fixtt n) (Func dss (dts ## n)) 164 --- ** DENORMALISATION ** --- 165 fixtt n 166 = let thisDimPoints 167 = taddall [] tt 168 169 taddall acc [] 170 = acc 171 taddall acc ((rs,fel):rest) 172 = taddall (tadd (rs ## n) fel acc) rest 173 174 tadd :: Route -> 175 [FrontierElem] -> 176 AList Route [[FrontierElem]] -> 177 AList Route [[FrontierElem]] 178 tadd r fel [] 179 = [(r, [fel])] 180 tadd r fel (this@(rr, fels):rest) 181 | r == rr = (rr, fel:fels):rest 182 | otherwise = this : tadd r fel rest 183 184 fixedtt 185 = map2nd 186 (foldr avLUBmin1frontier [MkFrel (map avTopR dss)]) 187 thisDimPoints 188 in 189 fixedtt 190 in 191 map doOneDimension (0 `myIntsFromTo` (numberOfDimensions-1)) 192 193 194 195 196 -- ==========================================================-- 197 -- === end Constructors.hs ===-- 198 -- ==========================================================--