{-# LANGUAGE FlexibleContexts #-}



module Control.Search.Combinator.OrRepeat (orRepeat) where



import Control.Search.Language

import Control.Search.GeneratorInfo

import Control.Search.Generator

import Control.Search.MemoReader

import Control.Search.Memo

import Control.Search.Stat



import Control.Monatron.Monatron hiding (Abort, L, state, cont)

import Control.Monatron.Zipper hiding (i,r)



orRepeatLoop :: (Evalable m, ReaderM Bool m) => Stat -> Int -> Eval m -> Eval m

orRepeatLoop cond uid super' = commentEval $

    Eval 

       { 

         structs     = structs super @++@ mystructs 

       , treeState_  = treeState_ super

       , toString    = "orRepeat" ++ show uid ++ "(" ++ toString super' ++ ")"

       , initH       = \i -> initE super i @>>>@ return (parent i <== baseTstate i) @>>>@ cachedClone i (cloneBase i)

       , evalState_  = {- ("cont",Bool,const $ return true) : -} ("ref_count_orr" ++ show uid,Int,const $ return 1) : ("parent",THook "TreeState",const $ return Null) : evalState_ super

       , pushLeftH    = push pushLeft

       , pushRightH   = push pushRight

       , nextSameH    = nextSame super

       , nextDiffH    = nextDiff super 

       , bodyH = \i -> dec_ref i >>= \deref -> bodyE super (i `onAbort` deref)

       , addH        = addE super

       , failH       = \i -> failE super i @>>>@ dec_ref i

       , returnH     = \i -> let j deref = i `onCommit` deref

                             in dec_ref i >>= returnE super . j

       , tryH        = \i -> do deref <- dec_ref i

                                tryE super (i `onAbort` deref)

       , startTryH   = \i -> do deref <- dec_ref i

                                startTryE super (i `onAbort` deref)

       , tryLH       = \i -> tryE_ super i @>>>@ dec_ref i

       , intArraysE  = intArraysE super

       , boolArraysE  = boolArraysE super

       , intVarsE    = intVarsE super

       , deleteH     = error "orRepeatLoop.deleteE NOT YET IMPLEMENTED"

       , canBranch   = return True

       , complete    = complete super

--       , complete = const $ return false

       }

  where mystructs = ([],[])

        super     = evalStat cond super'

        fs1       = [(field,init) | (field,ty,init) <- evalState_ super]

        parent    = \i -> estate i @=> "parent"

        dec_ref    = \i -> let i'     = resetAbort $ resetCommit $ i `withBase` ("orr_tstate" ++ show uid)

                               ii     = resetAbort $ resetCommit $ i

                           in do flag <- ask 

                                 if flag 

                                   then local (const False) $ do

                                        stmt1 <- inits super i'

                                        stmt2 <- startTryE super i'

                                        r     <- readStat cond

                                        ini   <- inite fs1 i'

                                        -- let cc =  clone ii i'

                                        -- cc  <- cachedClone (cloneBase ii) i'

                                        cc1 <- cachedClone (i { baseTstate = parent ii} ) i'

                                        -- cc2 <- cachedClone (i' ) i'

                                        compl <- complete super ii

                                        return (dec (ref_countx ii $ "orr" ++ show uid) 

                                               >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) 

                                                     (ifthen (r i' &&& Not compl)

                                                           (   SHook ("TreeState orr_tstate" ++ show uid ++ ";")

                                                           >>> (baseTstate i' <== parent ii)

                                                           -- >>> ((baseTstate i' @-> "space") <== (parent ii @-> "space"))

                                                           -- >>> cc

							   >>> cc1

							   -- >>> cc2

                                                           >>> (ref_countx i' ("orr" ++ show uid) <== 1)

--                                                         >>> (cont i' <== true)

                                                           >>> ini >>> stmt1 >>> stmt2)

                                                     ))

                                   else  return $ dec (ref_countx ii ("orr" ++ show uid)) >>> ifthen (ref_countx ii ("orr" ++ show uid) @== 0) (comment "orRepeatLoop-dec_ref-Delete" >>> Delete (space $ cloneBase ii))

        push dir  = \i -> dir super (i `onCommit'` inc (ref_countx i $ "orr" ++ show uid))



orRepeat

  :: Stat

  -> Search

  -> Search

orRepeat cond s  = 

  case s of

    Search { mkeval = evals, runsearch = runs } ->

	  Search { mkeval =

	           \super ->

	           do { uid <- get

	              ; put (uid + 1)

	              ; s' <- evals $ mapE (L . L . mmap runL . runL) super

	              ; return $ mapE (L . mmap L . runL) $ orRepeatLoop cond uid (mapE runL s')

	              }

	         , runsearch   = runs . rReaderT True . runL

	         }