module LogicGrowsOnTrees.Checkpoint
(
Checkpoint(..)
, Progress(..)
, CheckpointCursor
, CheckpointDifferential(..)
, Context
, ContextStep(..)
, ExplorationTState(..)
, ExplorationState
, initialExplorationState
, InconsistentCheckpoints(..)
, checkpointFromContext
, checkpointFromCursor
, checkpointFromExplorationState
, checkpointFromReversedList
, checkpointFromSequence
, checkpointFromInitialPath
, checkpointFromUnexploredPath
, simplifyCheckpointRoot
, simplifyCheckpoint
, pathFromContext
, pathFromCursor
, pathStepFromContextStep
, pathStepFromCursorDifferential
, invertCheckpoint
, stepThroughTreeStartingFromCheckpoint
, stepThroughTreeTStartingFromCheckpoint
, exploreTreeStartingFromCheckpoint
, exploreTreeTStartingFromCheckpoint
, exploreTreeUntilFirstStartingFromCheckpoint
, exploreTreeTUntilFirstStartingFromCheckpoint
, exploreTreeUntilFoundStartingFromCheckpoint
, exploreTreeTUntilFoundStartingFromCheckpoint
) where
import Control.Exception (Exception(),throw)
import Control.Monad ((>=>))
import Control.Monad.Operational (ProgramViewT(..),viewT)
import Data.ByteString (ByteString)
import Data.Composition
import Data.Derive.Monoid
import Data.Derive.Serialize
import Data.DeriveTH
import Data.Functor.Identity (Identity,runIdentity)
import Data.Monoid ((<>),Monoid(..))
import Data.Sequence (Seq,viewr,ViewR(..))
import qualified Data.Sequence as Seq
import Data.Serialize
import Data.Typeable (Typeable)
import LogicGrowsOnTrees
import LogicGrowsOnTrees.Path
data InconsistentCheckpoints = InconsistentCheckpoints Checkpoint Checkpoint deriving (Eq,Show,Typeable)
instance Exception InconsistentCheckpoints
data Checkpoint =
CachePoint ByteString Checkpoint
| ChoicePoint Checkpoint Checkpoint
| Explored
| Unexplored
deriving (Eq,Ord,Read,Show)
$( derive makeSerialize ''Checkpoint )
simplifyCheckpointRoot :: Checkpoint → Checkpoint
simplifyCheckpointRoot (ChoicePoint Unexplored Unexplored) = Unexplored
simplifyCheckpointRoot (ChoicePoint Explored Explored) = Explored
simplifyCheckpointRoot (CachePoint _ Explored) = Explored
simplifyCheckpointRoot checkpoint = checkpoint
instance Monoid Checkpoint where
mempty = Unexplored
Explored `mappend` _ = Explored
_ `mappend` Explored = Explored
Unexplored `mappend` x = x
x `mappend` Unexplored = x
(ChoicePoint lx rx) `mappend` (ChoicePoint ly ry) =
simplifyCheckpointRoot (ChoicePoint (lx `mappend` ly) (rx `mappend` ry))
(CachePoint cx x) `mappend` (CachePoint cy y)
| cx == cy = simplifyCheckpointRoot (CachePoint cx (x `mappend` y))
mappend x y = throw (InconsistentCheckpoints x y)
data Progress α = Progress
{ progressCheckpoint :: Checkpoint
, progressResult :: α
} deriving (Eq,Show)
$( derive makeMonoid ''Progress )
$( derive makeSerialize ''Progress )
instance Functor Progress where
fmap f (Progress checkpoint result) = Progress checkpoint (f result)
type CheckpointCursor = Seq CheckpointDifferential
data CheckpointDifferential =
CachePointD ByteString
| ChoicePointD BranchChoice Checkpoint
deriving (Eq,Read,Show)
type Context m α = [ContextStep m α]
data ContextStep m α =
CacheContextStep ByteString
| LeftBranchContextStep Checkpoint (TreeT m α)
| RightBranchContextStep
instance Show (ContextStep m α) where
show (CacheContextStep c) = "CacheContextStep[" ++ show c ++ "]"
show (LeftBranchContextStep checkpoint _) = "LeftBranchContextStep(" ++ show checkpoint ++ ")"
show RightBranchContextStep = "RightRightBranchContextStep"
data ExplorationTState m α = ExplorationTState
{ explorationStateContext :: !(Context m α)
, explorationStateCheckpoint :: !Checkpoint
, explorationStateTree :: !(TreeT m α)
}
type ExplorationState = ExplorationTState Identity
initialExplorationState :: Checkpoint → TreeT m α → ExplorationTState m α
initialExplorationState = ExplorationTState mempty
checkpointFromContext :: Context m α → Checkpoint → Checkpoint
checkpointFromContext = checkpointFromReversedList $
\step → case step of
CacheContextStep cache → CachePoint cache
LeftBranchContextStep right_checkpoint _ → flip ChoicePoint right_checkpoint
RightBranchContextStep → ChoicePoint Explored
checkpointFromCursor :: CheckpointCursor → Checkpoint → Checkpoint
checkpointFromCursor = checkpointFromSequence $
\step → case step of
CachePointD cache → CachePoint cache
ChoicePointD LeftBranch right_checkpoint → flip ChoicePoint right_checkpoint
ChoicePointD RightBranch left_checkpoint → ChoicePoint left_checkpoint
checkpointFromExplorationState :: ExplorationTState m α → Checkpoint
checkpointFromExplorationState ExplorationTState{..} =
checkpointFromContext explorationStateContext explorationStateCheckpoint
checkpointFromReversedList ::
(α → (Checkpoint → Checkpoint)) →
[α] →
Checkpoint →
Checkpoint
checkpointFromReversedList _ [] = id
checkpointFromReversedList processStep (step:rest) =
checkpointFromReversedList processStep rest
.
simplifyCheckpointRoot
.
processStep step
checkpointFromSequence ::
(α → (Checkpoint → Checkpoint)) →
Seq α →
Checkpoint →
Checkpoint
checkpointFromSequence _ (viewr → EmptyR) = id
checkpointFromSequence processStep (viewr → rest :> step) =
checkpointFromSequence processStep rest
.
simplifyCheckpointRoot
.
processStep step
checkpointFromInitialPath :: Path → Checkpoint → Checkpoint
checkpointFromInitialPath = checkpointFromSequence $
\step → case step of
CacheStep c → CachePoint c
ChoiceStep LeftBranch → flip ChoicePoint Unexplored
ChoiceStep RightBranch → ChoicePoint Unexplored
checkpointFromUnexploredPath :: Path → Checkpoint
checkpointFromUnexploredPath path = checkpointFromSequence
(\step → case step of
CacheStep c → CachePoint c
ChoiceStep LeftBranch → flip ChoicePoint Explored
ChoiceStep RightBranch → ChoicePoint Explored
)
path
Unexplored
simplifyCheckpoint :: Checkpoint → Checkpoint
simplifyCheckpoint (ChoicePoint left right) = simplifyCheckpointRoot (ChoicePoint (simplifyCheckpoint left) (simplifyCheckpoint right))
simplifyCheckpoint (CachePoint cache checkpoint) = simplifyCheckpointRoot (CachePoint cache (simplifyCheckpoint checkpoint))
simplifyCheckpoint checkpoint = checkpoint
pathFromContext :: Context m α → Path
pathFromContext = Seq.fromList . map pathStepFromContextStep . reverse
pathFromCursor :: CheckpointCursor → Path
pathFromCursor = fmap pathStepFromCursorDifferential
pathStepFromContextStep :: ContextStep m α → Step
pathStepFromContextStep (CacheContextStep cache) = CacheStep cache
pathStepFromContextStep (LeftBranchContextStep _ _) = ChoiceStep LeftBranch
pathStepFromContextStep (RightBranchContextStep) = ChoiceStep RightBranch
pathStepFromCursorDifferential :: CheckpointDifferential → Step
pathStepFromCursorDifferential (CachePointD cache) = CacheStep cache
pathStepFromCursorDifferential (ChoicePointD active_branch _) = ChoiceStep active_branch
invertCheckpoint :: Checkpoint → Checkpoint
invertCheckpoint Explored = Unexplored
invertCheckpoint Unexplored = Explored
invertCheckpoint (CachePoint cache rest) =
simplifyCheckpointRoot (CachePoint cache (invertCheckpoint rest))
invertCheckpoint (ChoicePoint left right) =
simplifyCheckpointRoot (ChoicePoint (invertCheckpoint left) (invertCheckpoint right))
stepThroughTreeStartingFromCheckpoint ::
ExplorationState α →
(Maybe α,Maybe (ExplorationState α))
stepThroughTreeStartingFromCheckpoint = runIdentity . stepThroughTreeTStartingFromCheckpoint
stepThroughTreeTStartingFromCheckpoint ::
Monad m ⇒
ExplorationTState m α →
m (Maybe α,Maybe (ExplorationTState m α))
stepThroughTreeTStartingFromCheckpoint (ExplorationTState context checkpoint tree) = case checkpoint of
Explored → return (Nothing, moveUpContext)
Unexplored → getView >>= \view → case view of
Return x → return (Just x, moveUpContext)
Null :>>= _ → return (Nothing, moveUpContext)
ProcessPendingRequests :>>= k → return (Nothing, Just $ ExplorationTState context checkpoint (TreeT . k $ ()))
Cache mx :>>= k →
mx >>= return . maybe
(Nothing, moveUpContext)
(\x → (Nothing, Just $
ExplorationTState
(CacheContextStep (encode x):context)
Unexplored
(TreeT . k $ x)
))
Choice left right :>>= k → return
(Nothing, Just $
ExplorationTState
(LeftBranchContextStep Unexplored (right >>= TreeT . k):context)
Unexplored
(left >>= TreeT . k)
)
CachePoint cache rest_checkpoint → getView >>= \view → case view of
ProcessPendingRequests :>>= k → return (Nothing, Just $ ExplorationTState context checkpoint (TreeT . k $ ()))
Cache _ :>>= k → return
(Nothing, Just $
ExplorationTState
(CacheContextStep cache:context)
rest_checkpoint
(either error (TreeT . k) . decode $ cache)
)
_ → throw PastTreeIsInconsistentWithPresentTree
ChoicePoint left_checkpoint right_checkpoint → getView >>= \view → case view of
ProcessPendingRequests :>>= k → return (Nothing, Just $ ExplorationTState context checkpoint (TreeT . k $ ()))
Choice left right :>>= k → return
(Nothing, Just $
ExplorationTState
(LeftBranchContextStep right_checkpoint (right >>= TreeT . k):context)
left_checkpoint
(left >>= TreeT . k)
)
_ → throw PastTreeIsInconsistentWithPresentTree
where
getView = viewT . unwrapTreeT $ tree
moveUpContext = go context
where
go [] = Nothing
go (LeftBranchContextStep right_checkpoint right_tree:rest_context) =
Just (ExplorationTState
(RightBranchContextStep:rest_context)
right_checkpoint
right_tree
)
go (_:rest_context) = go rest_context
exploreTreeStartingFromCheckpoint ::
Monoid α ⇒
Checkpoint →
Tree α →
α
exploreTreeStartingFromCheckpoint = runIdentity .* exploreTreeTStartingFromCheckpoint
exploreTreeTStartingFromCheckpoint ::
(Monad m, Monoid α) ⇒
Checkpoint →
TreeT m α →
m α
exploreTreeTStartingFromCheckpoint = go mempty .* initialExplorationState
where
go !accum =
stepThroughTreeTStartingFromCheckpoint
>=>
\(maybe_solution,maybe_new_exploration_state) →
let new_accum = maybe id (flip mappend) maybe_solution accum
in maybe (return new_accum) (go new_accum) maybe_new_exploration_state
exploreTreeUntilFirstStartingFromCheckpoint ::
Checkpoint →
Tree α →
Maybe α
exploreTreeUntilFirstStartingFromCheckpoint = runIdentity .* exploreTreeTUntilFirstStartingFromCheckpoint
exploreTreeTUntilFirstStartingFromCheckpoint ::
Monad m ⇒
Checkpoint →
TreeT m α →
m (Maybe α)
exploreTreeTUntilFirstStartingFromCheckpoint = go .* initialExplorationState
where
go = stepThroughTreeTStartingFromCheckpoint
>=>
\(maybe_solution,maybe_new_exploration_state) →
case maybe_solution of
Just _ → return maybe_solution
Nothing → maybe (return Nothing) go maybe_new_exploration_state
exploreTreeUntilFoundStartingFromCheckpoint ::
Monoid α ⇒
(α → Bool) →
Checkpoint →
Tree α →
(α,Bool)
exploreTreeUntilFoundStartingFromCheckpoint = runIdentity .** exploreTreeTUntilFoundStartingFromCheckpoint
exploreTreeTUntilFoundStartingFromCheckpoint ::
(Monad m, Monoid α) ⇒
(α → Bool) →
Checkpoint →
TreeT m α →
m (α,Bool)
exploreTreeTUntilFoundStartingFromCheckpoint f = go mempty .* initialExplorationState
where
go accum =
stepThroughTreeTStartingFromCheckpoint
>=>
\(maybe_solution,maybe_new_exploration_state) →
case maybe_solution of
Nothing → maybe (return (accum,False)) (go accum) maybe_new_exploration_state
Just solution →
let new_accum = accum <> solution
in if f new_accum
then return (new_accum,True)
else maybe (return (new_accum,False)) (go new_accum) maybe_new_exploration_state