1 2 -- ==========================================================-- 3 -- === Find frontiers using Hunt's algorithm. ===-- 4 -- === FrontierSearch5.hs ===-- 5 -- ==========================================================-- 6 7 module FrontierGENERIC2 where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 import AbstractVals2 12 import SuccsAndPreds2 13 import AbstractEval2 14 import AbsConc3 15 import FrontierMisc2 16 import FrontierDATAFN2 17 import AbstractMisc 18 import Apply 19 20 21 -- ==========================================================-- 22 -- 23 fsMakeFrontierRep :: ACMode -> -- safe or live 24 Bool -> -- True == naive initialisation 25 HExpr Naam -> -- the tree 26 Domain -> -- domain of function to be found (abstraction) 27 [Domain] -> -- arg domains at full size 28 Route -> -- upper bound 29 Route -> -- lower bound 30 (Route, Int) -- abstraction of function 31 32 33 fsMakeFrontierRep s_or_l naive hexpr func_domain big_arg_ds 34 lower_boundR upper_boundR 35 = let 36 (is_caf, small_arg_ds) 37 = case func_domain of 38 Func [] dt -> (True, panic "fsMakeFrontierRep(1)") 39 Func dss dt -> (False, dss) 40 non_func_domain -> (True, panic "fsMakeFrontierRep(2)") 41 getRep (Rep rep) 42 = rep 43 upper_bound 44 = getRep upper_boundR 45 lower_bound 46 = getRep lower_boundR 47 bound_rep 48 = fsZULB upper_bound lower_bound 49 init_memo 50 = [] 51 caf_result 52 = aeEvalConst hexpr 53 non_data_fn_result 54 = fsFind s_or_l hexpr func_domain 55 small_arg_ds big_arg_ds bound_rep 0 [] naive 56 (data_fn_result, final_memo) 57 = fdFind s_or_l hexpr func_domain 58 small_arg_ds big_arg_ds bound_rep fdIdent naive 59 (panic "no inherited min1") init_memo 60 data_fn_evals 61 = length final_memo 62 caf_result_norm 63 = case caf_result of {Rep rep -> apPapConst rep; other -> other} 64 is_data_fn 65 = amIsDataFn func_domain 66 in 67 if is_caf 68 then (caf_result_norm, 0) 69 else 70 if is_data_fn 71 then (Rep data_fn_result, data_fn_evals) 72 else (Rep non_data_fn_result, (-1)) 73 74 75 76 -- ==========================================================-- 77 -- 78 fsFind :: ACMode -> 79 HExpr Naam -> -- tree 80 Domain -> -- domain (abstraction) of fn to be found 81 [Domain] -> -- small arg domains 82 [Domain] -> -- big arg domains 83 Rep -> -- bounding rep 84 Int -> -- something to do with the AppInfo 85 [AppInfo] -> -- the AppInfo (surprise!) 86 Bool -> -- naive start 87 Rep 88 89 fsFind 90 s_or_l 91 hexpr 92 (Func dss Two) 93 small_argds 94 big_argds 95 (RepTwo bounds) n as naive 96 = 97 RepTwo (fsFs2 s_or_l 98 hexpr 99 small_argds 100 big_argds 101 bounds 102 (as++[A2]) 103 naive ) 104 105 106 fsFind 107 s_or_l 108 hexpr 109 (Func dss (Lift1 dts)) 110 small_argds 111 big_argds 112 (Rep1 bounds_lf bounds_hfs) n as naive 113 = 114 let 115 lofact 116 = fsFs2 s_or_l 117 hexpr 118 small_argds 119 big_argds 120 bounds_lf 121 (as++[ALo1]) 122 naive 123 hifact_ds 124 = map (avUncurry dss) dts 125 lofact_arity 126 = length dss 127 hifacts 128 = myZipWith4 doOne 129 hifact_ds 130 dts 131 bounds_hfs 132 (0 `myIntsFromTo` (length dts - 1)) 133 doOne hifact_d hifact_targ_domain bounds nn 134 = fsFind s_or_l 135 hexpr 136 hifact_d 137 small_argds 138 big_argds 139 bounds 140 lofact_arity 141 (as++[AHi1 lofact_arity nn hifact_targ_domain]) 142 naive 143 in 144 Rep1 lofact hifacts 145 146 147 fsFind 148 s_or_l 149 hexpr 150 (Func dss (Lift2 dts)) 151 small_argds 152 big_argds 153 (Rep2 bounds_lf bounds_mf bounds_hfs) n as naive 154 = 155 let 156 lofact 157 = fsFs2 s_or_l 158 hexpr 159 small_argds 160 big_argds 161 bounds_lf 162 (as++[ALo2]) 163 naive 164 midfact 165 = fsFs2 s_or_l 166 hexpr 167 small_argds 168 big_argds 169 bounds_mf 170 (as++[AMid2]) 171 naive 172 hifact_ds 173 = map (avUncurry dss) dts 174 lofact_arity 175 = length dss 176 hifacts 177 = myZipWith4 doOne 178 hifact_ds 179 dts 180 bounds_hfs 181 (0 `myIntsFromTo` (length dts - 1)) 182 doOne hifact_d hifact_targ_domain bounds nn 183 = fsFind s_or_l 184 hexpr 185 hifact_d 186 small_argds 187 big_argds 188 bounds 189 lofact_arity 190 (as++[AHi2 lofact_arity nn hifact_targ_domain]) 191 naive 192 in 193 Rep2 lofact midfact hifacts 194 195 196 -- ==========================================================-- 197 -- 198 fsApp :: [AppInfo] -> 199 [HExpr Naam] -> 200 HExpr Naam -> 201 Route 202 203 fsApp [A2] xs h 204 = fsEvalConst h xs 205 206 fsApp [ALo1] xs h 207 = case fsEvalConst h xs of 208 Stop1 -> Zero 209 Up1 _ -> One 210 211 fsApp ((AHi1 n x d):as) xs h 212 = let app_res = fsEvalConst h (take n xs) 213 nth_upp_obj = case app_res of 214 Stop1 -> avBottomR d 215 Up1 rs -> rs ## x 216 in 217 fsApp as (drop n xs) (HPoint nth_upp_obj) 218 219 fsApp [ALo2] xs h 220 = case fsEvalConst h xs of 221 Stop2 -> Zero 222 Up2 -> One 223 UpUp2 _ -> One 224 225 fsApp [AMid2] xs h 226 = case fsEvalConst h xs of 227 Stop2 -> Zero 228 Up2 -> Zero 229 UpUp2 _ -> One 230 231 fsApp ((AHi2 n x d):as) xs h 232 = let app_res = fsEvalConst h (take n xs) 233 nth_upp_obj = case app_res of 234 Stop2 -> avBottomR d 235 Up2 -> avBottomR d 236 UpUp2 rs -> rs ## x 237 in 238 fsApp as (drop n xs) (HPoint nth_upp_obj) 239 240 241 -- ==========================================================-- 242 -- 243 fsEvalConst :: HExpr Naam -> 244 [HExpr Naam] -> 245 Route 246 247 fsEvalConst h@(HLam _ _) xs = aeEvalExact h xs 248 fsEvalConst h@(HPoint p) [] = p 249 fsEvalConst h@(HPoint _) xs = aeEvalConst (HVAp h xs) 250 251 252 -- ==========================================================-- 253 -- 254 fsFs2 :: ACMode -> 255 HExpr Naam -> 256 [Domain] -> -- small arg domains 257 [Domain] -> -- big arg domains 258 Frontier -> -- bounds 259 [AppInfo] -> 260 Bool -> -- True == naive startup 261 Frontier 262 263 fsFs2 264 s_or_l 265 hexpr 266 small_argds 267 big_argds 268 (Min1Max0 ar1 min1_init max0_init) 269 as 270 naive 271 = 272 let arity 273 = length small_argds 274 initial_yy 275 = if naive 276 then [MkFrel (map avTopR small_argds)] 277 else max0_init 278 initial_xx 279 = if naive 280 then [MkFrel (map avBottomR small_argds)] 281 else min1_init 282 (final_yy, final_xx) 283 = fsFs_aux s_or_l 284 hexpr 285 small_argds 286 big_argds 287 initial_yy 288 initial_xx 289 as 290 True 291 (utRandomInts 1 2) 292 in 293 Min1Max0 arity final_xx final_yy 294 295 296 297 -- ==========================================================-- 298 -- 299 fsFs_aux :: ACMode -> 300 HExpr Naam -> 301 [Domain] -> -- small arg domains 302 [Domain] -> -- real arg domains 303 [FrontierElem] -> -- yy_frontier 304 [FrontierElem] -> -- xx_frontier 305 [AppInfo] -> -- application info 306 Bool -> -- True == take from top 307 [Int] -> -- random numbers 308 ([FrontierElem], [FrontierElem]) 309 310 fsFs_aux 311 s_or_l 312 hexpr 313 small_argds 314 big_argds 315 trial_max_yy 316 trial_min_xx 317 app_info 318 fromTop 319 rands 320 = 321 let 322 edges 323 = fmSelect (head rands) trial_min_xx trial_max_yy fromTop 324 Just (MkFrel args) 325 = edges 326 args_at_proper_sizes 327 = makeBigger args small_argds big_argds 328 evald_app 329 = fsApp app_info (map HPoint args_at_proper_sizes) hexpr 330 revised_max_yy 331 = fmReviseMaxYY small_argds trial_max_yy (MkFrel args) 332 revised_min_xx 333 = fmReviseMinXX small_argds trial_min_xx (MkFrel args) 334 makeBigger rs [] [] 335 = rs 336 makeBigger (r:rs) (s:ss) (b:bs) 337 = acConc s_or_l b s r : makeBigger rs ss bs 338 in 339 if fmIsNothing edges 340 then (sort trial_max_yy, sort trial_min_xx) 341 else 342 if evald_app == One 343 then fsFs_aux s_or_l 344 hexpr 345 small_argds 346 big_argds 347 revised_max_yy 348 trial_min_xx 349 app_info 350 False 351 (tail rands) 352 else 353 if evald_app == Zero 354 then fsFs_aux s_or_l 355 hexpr 356 small_argds 357 big_argds 358 trial_max_yy 359 revised_min_xx 360 app_info 361 True 362 (tail rands) 363 else 364 panic "fsFs_aux" 365 366 367 368 -- ==========================================================-- 369 -- === end FrontierSearch5.hs ===-- 370 -- ==========================================================--