module Control.Search.Combinator.Base ( label , vlabel , glabel, gblabel , int_assign , ilabel , maxV, minV, lbV, ubV, domsizeV, lbRegretV, ubRegretV, degreeV, domSizeDegreeV, wDegreeV, domSizeWDegreeV, randomV, minD, maxD, meanD, medianD, randomD , foldVarSel, ifoldVarSel, bfoldVarSel, bifoldVarSel ) where import Control.Search.Language import Control.Search.GeneratorInfo import Control.Search.Generator import Control.Monatron.IdT data Label m = Label { treeStateL :: [(String,Type, Value -> Statement)] , leftChild_L :: [Info -> Statement] , rightChild_L :: [Info -> Statement] , addL :: Info -> m Statement , tryL :: Info -> m Statement , intArraysL :: [String] , boolArraysL :: [String] , intVarsL :: [String] } v1Label var1 selVal rel e = Label { treeStateL = [("val", Int, assign 0) ,("eq", Bool, assign true)] , leftChild_L = [ \i -> mkUpdate i "eq" (const true) , \i -> mkCopy i "val" ] , rightChild_L = [ \i -> mkUpdate i "eq" (const false) , \i -> mkCopy i "val" ] , addL = \i -> return $ IfThenElse (eq i) (Post (space i) (var i `rel` val i)) (Post (space i) (neg (var i `rel` val i))) , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX tryE_ e (resetInfo i) >>= \try -> -- XXX return $ (IfThenElse (Assigned (var i)) ret (val i <== (selVal $ var i) >>> try)) , intArraysL = [] , boolArraysL = [] , intVarsL = [var1] } where val i = tstate i @-> "val" eq i = tstate i @-> "eq" var i = IVar var1 (space i) vLabel vars selVar selVal rel e = Label { treeStateL = [("pos", Int, assign 0) ,("val", Int, assign 0) ,("eq", Bool, assign true)] , leftChild_L = [ \i -> mkUpdate i "eq" (const true) , \i -> mkCopy i "val" , \i -> mkCopy i "pos"] , rightChild_L = [ \i -> mkUpdate i "eq" (const false) , \i -> mkCopy i "val" , \i -> mkCopy i "pos"] , addL = \i -> return $ IfThenElse (eq i) (Post (space i) (var i `rel` val i)) (Post (space i) (neg (var i `rel` val i))) , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX tryE_ e (resetInfo i) >>= \try -> -- XXX return $ (selVar i vars ret (val i <== (selVal $ var i) >>> try)) , intArraysL = [vars] , boolArraysL = [] , intVarsL = [] } where val i = tstate i @-> "val" pos i = tstate i @-> "pos" eq i = tstate i @-> "eq" var i = AVarElem vars (space i) (pos i) vbLabel vars selVar selVal rel e = Label { treeStateL = [("pos", Int, assign 0) ,("val", Int, assign 0) ,("eq", Bool, assign true)] , leftChild_L = [ \i -> mkUpdate i "eq" (const true) , \i -> mkCopy i "val" , \i -> mkCopy i "pos"] , rightChild_L = [ \i -> mkUpdate i "eq" (const false) , \i -> mkCopy i "val" , \i -> mkCopy i "pos"] , addL = \i -> return $ IfThenElse (eq i) (Post (space i) (var i `rel` val i)) (Post (space i) (neg (var i `rel` val i))) , tryL = \i -> returnE e (resetInfo i) >>= \ret -> -- XXX tryE_ e (resetInfo i) >>= \try -> -- XXX return $ (selVar i vars ret (val i <== (selVal $ var i) >>> try)) , intArraysL = [] , boolArraysL = [vars] , intVarsL = [] } where val i = tstate i @-> "val" pos i = tstate i @-> "pos" eq i = tstate i @-> "eq" var i = BAVarElem vars (space i) (pos i) type ValSel = Value -> Value type VarSel = Info -> String -> Statement -> Statement -> Statement foldVarSel metric (better, zero) i vars notfound found = Fold vars (tstate i) (space i) zero metric better >>> IfThenElse (pos i @< 0) notfound found where pos i = tstate i @-> "pos" ifoldVarSel metric (better, zero) i vars notfound found = IFold vars (tstate i) (space i) zero metric better >>> IfThenElse (pos i @< 0) notfound found where pos i = tstate i @-> "pos" bfoldVarSel metric (better, zero) i vars notfound found = BFold vars (tstate i) (space i) zero metric better >>> IfThenElse (pos i @< 0) notfound found where pos i = tstate i @-> "pos" bifoldVarSel metric (better, zero) i vars notfound found = BIFold vars (tstate i) (space i) zero metric better >>> IfThenElse (pos i @< 0) notfound found where pos i = tstate i @-> "pos" -------------------------------------------------------------------------------- -- SEARCH TRANSFORMERS -------------------------------------------------------------------------------- pushLeftTop e = \i -> pushLeft e (i `onCommit` mkCopy i "space" ) pushRightTop e = \i -> pushRight e (i `onCommit` mkUpdate i "space" Clone) baseLoop label this = return $ commentEval $ current where current = Eval { structs = ([],[]) , treeState_ = map entry $ treeStateL label , initH = const $ return Skip , evalState_ = [] , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label]) , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label]) , nextSameH = \i -> return Skip , nextDiffH = \i -> return Skip , bodyH = addE this . resetInfo -- XXX , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX addL label i >>= \a -> return (a >>> try) , failH = const $ return Skip , returnH = \i -> cachedCommit i -- , continue = \_ -> return true , tryH = tr label , startTryH = tr label , tryLH = \i -> pushRightTop this (newinfo i "R") >>= \p2 -> pushLeftTop this (newinfo i "L") >>= \p4 -> return $ ( SHook "st->queue->push_back(TreeState());" >>> SHook "TreeState& nstateR = st->queue->back();" >>> p2 >>> SHook "st->queue->push_back(TreeState());" >>> SHook "TreeState& nstateL = st->queue->back();" >>> p4 ) , intArraysE = intArraysL label , boolArraysE = boolArraysL label , intVarsE = intVarsL label , deleteH = \i -> return Skip , toString = "base" , canBranch = return True , complete = const $ return true } where new_tstate = Var "nstate" tr lab i = failE this (resetInfo i) >>= \fail -> tryL lab i >>= \tryl -> return $ (SHook "Gecode::SpaceStatus status;" >>> (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl ) label :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search label get varMeasure varComp valSel rel = Search { mkeval = \this -> baseLoop (vLabel get (foldVarSel varMeasure varComp) valSel rel this) this , runsearch = runIdT } vlabel :: String -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search vlabel get valSel rel = Search { mkeval = \this -> baseLoop (v1Label get valSel rel this) this , runsearch = runIdT } ilabel :: String -> (Value -> Value) -> (Value -> Value -> Value, Value) -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search ilabel get varMeasure varComp valSel rel = Search { mkeval = \this -> baseLoop (vLabel get (ifoldVarSel varMeasure varComp) valSel rel this) this , runsearch = runIdT } int_assign :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search int_assign get varSel valSel rel = Search { mkeval = \this -> assignLoop (vLabel get varSel valSel rel this) this , runsearch = runIdT } glabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search glabel get varSel valSel rel = Search { mkeval = \this -> baseLoop (vLabel get varSel valSel rel this) this , runsearch = runIdT } gblabel :: String -> VarSel -> (Value -> Value) -> (Value -> Value -> Constraint) -> Search gblabel get varSel valSel rel = Search { mkeval = \this -> baseLoop (vbLabel get varSel valSel rel this) this , runsearch = runIdT } maxV = (Gt,IVal minBound) minV = (Lt,IVal maxBound) lbV = MinDom ubV = MaxDom domsizeV = \v -> MaxDom v - MinDom v lbRegretV = LbRegret ubRegretV = UbRegret degreeV = Degree domSizeDegreeV = \v -> domsizeV v `Div` degreeV v wDegreeV = WDegree domSizeWDegreeV= \v -> domsizeV v `Div` wDegreeV v randomV = const Random minD = MinDom maxD = MaxDom meanD = \v -> (maxD v + minD v) `Div` 2 medianD = \v -> Median v randomD = \v -> (Random `Mod` (domsizeV v)) + minD v {- assignLoop label this = return $ commentEval $ current where current = Eval { structs = ([],[]) , treeState_ = map entry $ treeStateL label , initH = const $ return Skip , evalState_ = [] , pushLeftH = error "assignLoop.tyE_" , pushRightH = error "assignLoop.tyE_" , nextSameH = \i -> return Skip , nextDiffH = \i -> return Skip , bodyH = addE this . resetInfo -- XXX , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX addL label i >>= \a -> return (a >>> try) , failH = const $ return Skip , returnH = \i -> cachedCommit i , tryH = returnE this . resetInfo , startTryH = \i -> (return $ comment "") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "") , tryLH = error "assignLoop.tryE_" , intArraysE = intArraysL label , boolArraysE = boolArraysL label , intVarsE = intVarsL label , deleteH = \i -> return Skip , toString = "assign" , canBranch = return False , complete = const $ return true } -} assignLoop label this = return $ commentEval $ current where current = Eval { structs = ([],[]) , treeState_ = map entry $ treeStateL label , initH = const $ return Skip , evalState_ = [] , pushLeftH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- leftChild_L label]) , pushRightH = \i -> cachedCommit i @>>>@ return (seqs [f i | f <- rightChild_L label]) , nextSameH = \i -> return Skip , nextDiffH = \i -> return Skip , bodyH = addE this . resetInfo -- XXX , addH = \i -> tryE this (resetInfo i) >>= \try -> -- XXX addL label i >>= \a -> return (a >>> try) , failH = const $ return Skip , returnH = \i -> cachedCommit i , tryH = tr label , startTryH = tr label , tryLH = \i -> -- pushRightTop this (newinfo i "R") >>= \p2 -> pushLeftTop this (newinfo i "L") >>= \p4 -> return $ ( -- SHook "queue->push_back(TreeState());" >>> -- SHook "TreeState& nstateR = queue->back();" >>> -- p2 >>> SHook "st->queue->push_back(TreeState());" >>> SHook "TreeState& nstateL = st->queue->back();" >>> p4 ) , intArraysE = intArraysL label , boolArraysE = boolArraysL label , intVarsE = intVarsL label , deleteH = \i -> return Skip , toString = "base" , canBranch = return True , complete = const $ return true } where new_tstate = Var "nstate" tr lab i = failE this (resetInfo i) >>= \fail -> tryL lab i >>= \tryl -> return $ ( (Var "status" <== VHook (rp 0 (space i) ++ "->status()")) >>> IfThenElse (Var "status" @== VHook "SS_FAILED") (fail >>> Delete (space i)) tryl )