1 2 -- ==========================================================-- 3 -- === Find a smaller versions of big lattices when we ===-- 4 -- === we reckon that the big lattice is too expensive ===-- 5 -- === to work in. ===-- 6 -- === SmallerLattice.hs ===-- 7 -- ==========================================================-- 8 9 10 module SmallerLattice where 11 import BaseDefs 12 import MyUtils 13 import Utils 14 import AbsConc3 15 16 import List(nub,transpose) -- 1.3 17 18 -- ==========================================================-- 19 -- 20 {- partain: moved to BaseDefs.hs: 21 22 instance (Text a, Ord a) => Num (ExceptionInt a) where 23 24 (MkExInt i1 xs1) + (MkExInt i2 xs2) 25 = MkExInt (i1 + i2) (xs1 ++ xs2) 26 27 (MkExInt i1 xs1) * (MkExInt i2 xs2) 28 = MkExInt (i1 * i2) (xs1 ++ xs2) 29 -} 30 31 -- ==========================================================-- 32 -- 33 sl_1 = MkExInt 1 [] 34 sl_2 = MkExInt 2 [] 35 36 37 -- ==========================================================-- 38 -- 39 slCard :: AList Domain Int -> Domain -> DomainInt 40 41 slCard rho Two 42 = sl_2 43 slCard rho (Lift1 ds) 44 = sl_1 + foldl (*) sl_1 (map (slCard rho) ds) 45 slCard rho (Lift2 ds) 46 = sl_2 + foldl (*) sl_1 (map (slCard rho) ds) 47 slCard rho (Func dss dt) 48 = let norm_func_domain 49 = fixWith slNorm (Func dss dt) 50 fixWith f x 51 = let y = f x in if x == y then x else fixWith f y 52 rho_lookup 53 = case utLookup rho norm_func_domain of 54 Nothing -> MkExInt 0 [norm_func_domain] 55 Just n -> MkExInt n [] 56 in 57 case norm_func_domain of 58 Func _ _ -> rho_lookup 59 non_fn_d -> slCard rho norm_func_domain 60 61 62 -- ==========================================================-- 63 -- 64 slNorm :: Domain -> Domain 65 66 slNorm Two = Two 67 68 slNorm (Lift1 [Lift1 ds]) = Lift2 (map slNorm ds) 69 slNorm (Lift2 [Lift1 ds]) = Lift1 [Lift2 (map slNorm ds)] 70 71 slNorm (Lift1 ds) = Lift1 (map slNorm ds) 72 slNorm (Lift2 ds) = Lift2 (map slNorm ds) 73 74 slNorm (Func [Two] Two) = Lift1 [Two] 75 slNorm (Func [Lift1 [Two]] Two) = Lift2 [Two] 76 slNorm (Func [Lift2 [Two]] Two) = Lift1 [Lift2 [Two]] 77 slNorm (Func [Two] (Lift1 [Two])) = Func [Two, Two] Two 78 slNorm (Func [Two] (Lift2 [Two])) = Func [Lift1 [Two]] (Lift1 [Two]) 79 80 slNorm (Func dss dt) 81 = Func (sort (map slNorm dss)) (slNorm dt) 82 83 84 -- ==========================================================-- 85 -- 86 slReduce :: Domain -> [Domain] 87 88 slReduce Two 89 = [] 90 91 slReduce (Lift1 ds) 92 = let reduced_and_original = myZipWith2 (:) ds (map slReduce ds) 93 in 94 [Lift1 ds_reduced 95 | ds_reduced <- tail (myCartesianProduct reduced_and_original)] 96 ++ 97 [Two] 98 99 slReduce (Lift2 ds) 100 = let reduced_and_original = myZipWith2 (:) ds (map slReduce ds) 101 in 102 [Lift2 ds_reduced 103 | ds_reduced <- tail (myCartesianProduct reduced_and_original)] 104 ++ 105 [Two] 106 107 slReduce (Func dss dt) 108 = let arg_domains_reduced = map slReduce dss 109 res_domain_reduced = slReduce dt 110 originals = dt : dss 111 reduced_all = res_domain_reduced : arg_domains_reduced 112 variants = tail (myCartesianProduct 113 (myZipWith2 (:) originals reduced_all)) 114 in 115 [Func dss dt | (dt:dss) <- variants] 116 ++ 117 [Two] 118 119 120 -- ==========================================================-- 121 -- 122 slMakeSequence :: AList Domain Int -> -- lattice size table 123 Int -> -- scaleup ratio 124 [[Domain]] -> -- arg domains for each fn in rec groups 125 Int -> -- lower limit 126 Int -> -- upper limit 127 Sequence 128 129 slMakeSequence table scaleup_ratio dss lowlimit highlimit 130 = let 131 -- magic the individual domains, then reverse the list 132 initially = map (reverse.map clean.slMakeOneSequence table scaleup_ratio) 133 dss 134 135 -- remove path costs 136 clean ((Lift1 ds,s),c) = (s,ds) 137 138 -- the limiting sequence length 139 limit = minimum (map length initially) 140 141 -- chop off irrelevant bits and restore original ordering 142 -- outer list: one elem per function 143 -- inner list: the sequence for a particular function 144 equalLengths :: [[OneFuncSize]] 145 equalLengths = map (reverse.take limit) initially 146 147 -- transpose, to get it round the way we need it 148 -- outer list: the sequence, one elem contains all functions at a 149 -- given size 150 equalLengthsT = transpose equalLengths 151 152 -- get the greatest sizes at every "size" 153 maxSizes = map getMaxSizes equalLengthsT 154 155 getMaxSizes oneSizeInfo = maximum (map first oneSizeInfo) 156 157 -- lower limit: throw away if all sizes below threshold, 158 -- but not to the extent of throwing them all away 159 lowDrop = min (length (takeWhile (< lowlimit) maxSizes)) 160 (limit - 1) 161 162 -- adjust limit and equalLengthsT to reflect the fact that 163 -- we've decided to ignore the first lowDrop lattice-sets 164 limit2 = limit - lowDrop 165 equalLengthsT2 = drop lowDrop equalLengthsT 166 maxSizes2 = reverse (drop lowDrop maxSizes) 167 168 -- upper limit: throw away if any size above threshold, 169 -- but not to the extent of throwing them all away 170 highDrop = min (length (takeWhile (> highlimit) maxSizes2)) 171 (limit2 - 1) 172 173 -- now we can partition the size-groups into those to use, 174 -- and those not to bother with 175 (usePart, notUsePart) = splitAt (limit2 - highDrop) equalLengthsT2 176 in 177 (usePart, notUsePart) 178 179 180 -- ==========================================================-- 181 -- 182 slMakeOneSequence :: AList Domain Int -> Int -> [Domain] -> [(DInt, Int)] 183 184 slMakeOneSequence table scaleup_ratio ds 185 = let 186 -- bind all domains into a product 187 ds_crossed = Lift1 ds 188 189 -- make all the subdomains, add the original 190 -- and zap the trailing Two domain arising from 191 -- reducing the outermost Lift1 192 all_candidates = ds_crossed : init (slReduce ds_crossed) 193 194 -- put their sizes on 195 cands_and_sizes = map (\d -> (d, slCard table d)) all_candidates 196 197 -- get all the unsizable function spaces, 198 -- and sizes 199 (unsizables, sizes) 200 = let f [] = ([],[]) 201 f ((d, MkExInt n xs):rest) 202 = let (rest_u, rest_s) = f rest 203 in (xs ++ rest_u, (d, n-1):rest_s) 204 in 205 f cands_and_sizes 206 207 -- check all domains got sized OK 208 sizes2 :: [DInt] 209 sizes2 210 = if null unsizables 211 then sizes 212 else myFail ( "\n\nNo size for:\n\n" ++ 213 (layn.map show) (nub unsizables)) 214 215 -- recover the iaboves relation 216 iaboves :: AList DInt [DInt] 217 iaboves 218 = let leq (d1,c1) (d2,c2) = d2 `acCompatible` d1 {-FIX THIS-} 219 in 220 slRecover sizes2 leq 221 222 -- flatten it out 223 iaboves_flattened :: [(DInt, DInt)] 224 iaboves_flattened 225 = concat (map ( \ (x, ys) -> [(x,y) | y <- ys] ) iaboves) 226 227 -- the local cost function 228 local_cost n1 n2 229 = let diff = ((n2 * 10) `div` n1) - scaleup_ratio 230 scaleFact = n2 `div` 10 231 in 232 scaleFact * abs diff 233 234 -- add local costs 235 iaboves_costed :: [(DInt, DInt, Int)] 236 iaboves_costed 237 = map ( \ (p@(d1,s1), q@(d2,s2)) -> (p, q, local_cost s1 s2)) 238 iaboves_flattened 239 240 -- get the start and end points 241 start, end :: DInt 242 start = last sizes2 243 end = head sizes2 244 in 245 slDijkstra iaboves_costed start end 246 247 248 249 -- ==========================================================-- 250 -- 251 slRecover :: Eq a => [a] -> (a -> a -> Bool) -> AList a [a] 252 253 slRecover latt leq 254 = let 255 iaboves s 256 = foldr minInsert [] (allabove s) 257 allabove s 258 = [t | t <- latt, s `leq` t && s /= t] 259 minInsert t s 260 = if myAny (`leq` t) s 261 then s 262 else t : [u | u <- s, not (t `leq` u)] 263 in 264 [(s, iaboves s) | s <- latt] 265 266 267 -- ==========================================================-- 268 -- 269 slDijkstra :: Eq a => [(a, a, Int)] -> a -> a -> [(a, Int)] 270 271 slDijkstra roads start end 272 = let considered = [(start,0,start)] 273 costs = slDijkstra_aux roads end considered 274 route = reverse (slDijkstra_unlink start end costs) 275 in 276 route 277 278 279 -- ==========================================================-- 280 -- 281 slDijkstra_aux :: Eq a => [(a, a, Int)] -> 282 a -> 283 [(a, Int, a)] -> 284 [(a, Int, a)] 285 286 slDijkstra_aux roads end considered 287 = let 288 first3 (a,b,c) = a 289 290 (best, bestcost, bestback) = foldl1 take_min considered 291 take_min (x1,c1,b1) (x2,c2,b2) = if c1 < c2 then (x1,c1,b1) else (x2,c2,b2) 292 bigY = [(y,c+bestcost,best) | (x,y,c) <- roads, x == best] 293 removeBest = filter ((/= best).first3) considered 294 295 upd (pl, newco, bak) [] = [(pl, newco, bak)] 296 upd (pl, newco, bak) ((pl2, oldco, oldbak):rest) 297 | pl /= pl2 = (pl2,oldco, oldbak) : upd (pl, newco, bak) rest 298 | newco >= oldco = (pl2, oldco, oldbak):rest 299 | otherwise = (pl2, newco, bak):rest 300 301 updAll olds [] = olds 302 updAll olds ((pl,newco,bak):rest) = updAll (upd (pl, newco, bak) olds) rest 303 304 considered2 = updAll removeBest bigY 305 in if null considered then panic "Dijkstra failed" else 306 if best == end then [(best, bestcost, bestback)] else 307 (best, bestcost, bestback) : slDijkstra_aux roads end considered2 308 309 310 -- ==========================================================-- 311 -- 312 slDijkstra_unlink :: Eq a => a -> a -> [(a, Int, a)] -> [(a, Int)] 313 314 slDijkstra_unlink start here costs 315 = let (cell, cost, back) = head [(ce,co,ba) | (ce,co,ba) <- costs, ce == here] 316 in 317 if start == here then [(start,0)] else 318 (cell, cost) : slDijkstra_unlink start back costs 319 320 321 -- ==========================================================-- 322 -- === end SmallerLattice.hs ===-- 323 -- ==========================================================--