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 "<startTryE assign>") @>>>@ (returnE this . resetInfo) i @>>>@ (return $ comment "</startTryE succes>")
                 ,  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

                   )