
-- ==========================================================--
-- === 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 ===--
-- ==========================================================--
