-- ==========================================================-- -- === Find frontiers using Hunt's algorithm. ===-- -- === FrontierSearch5.hs ===-- -- ==========================================================-- module FrontierGENERIC2 where import BaseDefs import Utils import MyUtils import AbstractVals2 import SuccsAndPreds2 import AbstractEval2 import AbsConc3 import FrontierMisc2 import FrontierDATAFN2 import AbstractMisc import Apply -- ==========================================================-- -- fsMakeFrontierRep :: ACMode -> -- safe or live Bool -> -- True == naive initialisation HExpr Naam -> -- the tree Domain -> -- domain of function to be found (abstraction) [Domain] -> -- arg domains at full size Route -> -- upper bound Route -> -- lower bound (Route, Int) -- abstraction of function fsMakeFrontierRep s_or_l naive hexpr func_domain big_arg_ds lower_boundR upper_boundR = let (is_caf, small_arg_ds) = case func_domain of Func [] dt -> (True, panic "fsMakeFrontierRep(1)") Func dss dt -> (False, dss) non_func_domain -> (True, panic "fsMakeFrontierRep(2)") getRep (Rep rep) = rep upper_bound = getRep upper_boundR lower_bound = getRep lower_boundR bound_rep = fsZULB upper_bound lower_bound init_memo = [] caf_result = aeEvalConst hexpr non_data_fn_result = fsFind s_or_l hexpr func_domain small_arg_ds big_arg_ds bound_rep 0 [] naive (data_fn_result, final_memo) = fdFind s_or_l hexpr func_domain small_arg_ds big_arg_ds bound_rep fdIdent naive (panic "no inherited min1") init_memo data_fn_evals = length final_memo caf_result_norm = case caf_result of {Rep rep -> apPapConst rep; other -> other} is_data_fn = amIsDataFn func_domain in if is_caf then (caf_result_norm, 0) else if is_data_fn then (Rep data_fn_result, data_fn_evals) else (Rep non_data_fn_result, (-1)) -- ==========================================================-- -- fsFind :: ACMode -> HExpr Naam -> -- tree Domain -> -- domain (abstraction) of fn to be found [Domain] -> -- small arg domains [Domain] -> -- big arg domains Rep -> -- bounding rep Int -> -- something to do with the AppInfo [AppInfo] -> -- the AppInfo (surprise!) Bool -> -- naive start Rep fsFind s_or_l hexpr (Func dss Two) small_argds big_argds (RepTwo bounds) n as naive = RepTwo (fsFs2 s_or_l hexpr small_argds big_argds bounds (as++[A2]) naive ) fsFind s_or_l hexpr (Func dss (Lift1 dts)) small_argds big_argds (Rep1 bounds_lf bounds_hfs) n as naive = let lofact = fsFs2 s_or_l hexpr small_argds big_argds bounds_lf (as++[ALo1]) naive hifact_ds = map (avUncurry dss) dts lofact_arity = length dss hifacts = myZipWith4 doOne hifact_ds dts bounds_hfs (0 `myIntsFromTo` (length dts - 1)) doOne hifact_d hifact_targ_domain bounds nn = fsFind s_or_l hexpr hifact_d small_argds big_argds bounds lofact_arity (as++[AHi1 lofact_arity nn hifact_targ_domain]) naive in Rep1 lofact hifacts fsFind s_or_l hexpr (Func dss (Lift2 dts)) small_argds big_argds (Rep2 bounds_lf bounds_mf bounds_hfs) n as naive = let lofact = fsFs2 s_or_l hexpr small_argds big_argds bounds_lf (as++[ALo2]) naive midfact = fsFs2 s_or_l hexpr small_argds big_argds bounds_mf (as++[AMid2]) naive hifact_ds = map (avUncurry dss) dts lofact_arity = length dss hifacts = myZipWith4 doOne hifact_ds dts bounds_hfs (0 `myIntsFromTo` (length dts - 1)) doOne hifact_d hifact_targ_domain bounds nn = fsFind s_or_l hexpr hifact_d small_argds big_argds bounds lofact_arity (as++[AHi2 lofact_arity nn hifact_targ_domain]) naive in Rep2 lofact midfact hifacts -- ==========================================================-- -- fsApp :: [AppInfo] -> [HExpr Naam] -> HExpr Naam -> Route fsApp [A2] xs h = fsEvalConst h xs fsApp [ALo1] xs h = case fsEvalConst h xs of Stop1 -> Zero Up1 _ -> One fsApp ((AHi1 n x d):as) xs h = let app_res = fsEvalConst h (take n xs) nth_upp_obj = case app_res of Stop1 -> avBottomR d Up1 rs -> rs ## x in fsApp as (drop n xs) (HPoint nth_upp_obj) fsApp [ALo2] xs h = case fsEvalConst h xs of Stop2 -> Zero Up2 -> One UpUp2 _ -> One fsApp [AMid2] xs h = case fsEvalConst h xs of Stop2 -> Zero Up2 -> Zero UpUp2 _ -> One fsApp ((AHi2 n x d):as) xs h = let app_res = fsEvalConst h (take n xs) nth_upp_obj = case app_res of Stop2 -> avBottomR d Up2 -> avBottomR d UpUp2 rs -> rs ## x in fsApp as (drop n xs) (HPoint nth_upp_obj) -- ==========================================================-- -- fsEvalConst :: HExpr Naam -> [HExpr Naam] -> Route fsEvalConst h@(HLam _ _) xs = aeEvalExact h xs fsEvalConst h@(HPoint p) [] = p fsEvalConst h@(HPoint _) xs = aeEvalConst (HVAp h xs) -- ==========================================================-- -- fsFs2 :: ACMode -> HExpr Naam -> [Domain] -> -- small arg domains [Domain] -> -- big arg domains Frontier -> -- bounds [AppInfo] -> Bool -> -- True == naive startup Frontier fsFs2 s_or_l hexpr small_argds big_argds (Min1Max0 ar1 min1_init max0_init) as naive = let arity = length small_argds initial_yy = if naive then [MkFrel (map avTopR small_argds)] else max0_init initial_xx = if naive then [MkFrel (map avBottomR small_argds)] else min1_init (final_yy, final_xx) = fsFs_aux s_or_l hexpr small_argds big_argds initial_yy initial_xx as True (utRandomInts 1 2) in Min1Max0 arity final_xx final_yy -- ==========================================================-- -- fsFs_aux :: ACMode -> HExpr Naam -> [Domain] -> -- small arg domains [Domain] -> -- real arg domains [FrontierElem] -> -- yy_frontier [FrontierElem] -> -- xx_frontier [AppInfo] -> -- application info Bool -> -- True == take from top [Int] -> -- random numbers ([FrontierElem], [FrontierElem]) fsFs_aux s_or_l hexpr small_argds big_argds trial_max_yy trial_min_xx app_info fromTop rands = let edges = fmSelect (head rands) trial_min_xx trial_max_yy fromTop Just (MkFrel args) = edges args_at_proper_sizes = makeBigger args small_argds big_argds evald_app = fsApp app_info (map HPoint args_at_proper_sizes) hexpr revised_max_yy = fmReviseMaxYY small_argds trial_max_yy (MkFrel args) revised_min_xx = fmReviseMinXX small_argds trial_min_xx (MkFrel args) makeBigger rs [] [] = rs makeBigger (r:rs) (s:ss) (b:bs) = acConc s_or_l b s r : makeBigger rs ss bs in if fmIsNothing edges then (sort trial_max_yy, sort trial_min_xx) else if evald_app == One then fsFs_aux s_or_l hexpr small_argds big_argds revised_max_yy trial_min_xx app_info False (tail rands) else if evald_app == Zero then fsFs_aux s_or_l hexpr small_argds big_argds trial_max_yy revised_min_xx app_info True (tail rands) else panic "fsFs_aux" -- ==========================================================-- -- === end FrontierSearch5.hs ===-- -- ==========================================================--