Skip to content
Snippets Groups Projects
RTree.hs 4.86 KiB
Newer Older
  • Learn to ignore specific revisions
  • chrg's avatar
    chrg committed
    {-# LANGUAGE BlockArguments #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE DerivingVia #-}
    {-# LANGUAGE FlexibleContexts #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE FlexibleInstances #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE KindSignatures #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE LambdaCase #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE MultiParamTypeClasses #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE RankNTypes #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE ScopedTypeVariables #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE UndecidableInstances #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE ViewPatterns #-}
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    {- |
    Module: Control.RTree
    -}
    
    chrg's avatar
    chrg committed
    module Control.RTree (
      -- # RTree
      RTree (..),
      extract,
      reduce,
      -- # IRTree
      IRTree,
      iextract,
      ireduce,
      ireduceExp,
      IRTreeT (..),
      iextractT,
      ireduceT,
      ireduceExpT,
      ReState (..),
      -- # Valuation
      Valuation,
    ) where
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    import Control.Applicative
    import Control.Monad.Reader
    
    chrg's avatar
    chrg committed
    import Control.Monad.State.Strict
    
    chrg's avatar
    chrg committed
    import Data.Functor.Identity
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    import Control.Monad.Reduce
    
    chrg's avatar
    chrg committed
    import qualified Data.Valuation as Val
    
    type Valuation = Val.Valuation
    
    chrg's avatar
    chrg committed
    type Truth = Val.Truth
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    data RTree l i
    
    chrg's avatar
    chrg committed
      = SplitWith (Maybe (Truth l)) (RTree l i) !(RTree l i)
    
    chrg's avatar
    chrg committed
      | Done i
    
    chrg's avatar
    chrg committed
      deriving (Functor)
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    extract :: (Ord l) => Valuation l -> RTree l i -> i
    extract v = \case
    
    chrg's avatar
    chrg committed
      SplitWith ml lhs rhs -> case ml >>= Val.condition v of
        Just v' -> extract v' rhs
        _ -> extract v lhs
    
    chrg's avatar
    chrg committed
      Done i -> i
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    instance Applicative (RTree l) where
    
    chrg's avatar
    chrg committed
      pure = Done
      (<*>) = ap
    
    
    chrg's avatar
    chrg committed
    instance Monad (RTree l) where
    
    chrg's avatar
    chrg committed
      ma >>= f = case ma of
        Done i -> f i
    
    chrg's avatar
    chrg committed
        SplitWith ml lhs rhs -> SplitWith ml (lhs >>= f) (rhs >>= f)
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    instance MonadReduce l (RTree l) where
    
    chrg's avatar
    chrg committed
      splitWith = SplitWith
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    reduce
      :: forall m l i
       . (Alternative m, Ord l)
    
    chrg's avatar
    chrg committed
      => (i -> m ())
    
    chrg's avatar
    chrg committed
      -> Valuation l
      -> RTree l i
      -> m i
    
    chrg's avatar
    chrg committed
    reduce p = checkgo
    
    chrg's avatar
    chrg committed
     where
    
    chrg's avatar
    chrg committed
      checkgo v r = p (extract v r) *> go v r
    
    chrg's avatar
    chrg committed
      go v = \case
        Done i -> pure i
    
    chrg's avatar
    chrg committed
        SplitWith (Just l) lhs rhs -> case Val.truthValue v (Val.label l) of
          Just t
            | t == Val.truth l -> checkgo v rhs
            | otherwise -> checkgo v lhs
          Nothing -> checkgo (Val.withTruth v $ Val.not l) lhs <|> go (Val.withTruth v l) rhs
    
    chrg's avatar
    chrg committed
        SplitWith Nothing lhs rhs -> (checkgo v lhs <|> go v rhs)
    {-# INLINE reduce #-}
    
    data ReState l = ReState
      { choices :: [Bool]
      , valuation :: !(Valuation l)
      }
    
    type IRTree l = IRTreeT l Identity
    
    newtype IRTreeT l m i = IRTreeT {runIRTreeT :: StateT (ReState l) m i}
      deriving (Functor, Applicative, Monad) via (StateT (ReState l) m)
      deriving (MonadTrans) via (StateT (ReState l))
    
    instance (Monad m, Ord l) => MonadReduce l (IRTreeT l m) where
      checkWith =
        IRTreeT . StateT . \case
          Nothing -> \case
            ReState (uncons -> (a, as)) v ->
              pure (a, ReState as v)
          Just l -> \case
    
    chrg's avatar
    chrg committed
            ReState as v@((`Val.truthValue` Val.label l) -> Just x) ->
    
    chrg's avatar
    chrg committed
              pure (x, ReState as v)
            ReState (uncons -> (a, as)) v ->
    
    chrg's avatar
    chrg committed
              pure (a, ReState as (Val.withTruth v (if a then l else Val.not l)))
    
    chrg's avatar
    chrg committed
       where
        uncons [] = (True, [])
        uncons (a : as) = (a, as)
      {-# INLINE checkWith #-}
    
    iextract :: (Ord l) => Valuation l -> IRTree l a -> a
    iextract v t = runIdentity $ iextractT v t
    {-# INLINE iextract #-}
    
    iextractT :: (Ord l, Monad m) => Valuation l -> IRTreeT l m i -> m i
    iextractT v (IRTreeT m) = evalStateT m (ReState [] v)
    {-# INLINE iextractT #-}
    
    ireduce
    
    chrg's avatar
    chrg committed
      :: forall m l i
    
    chrg's avatar
    chrg committed
       . (Monad m, Ord l)
    
    chrg's avatar
    chrg committed
      => (Valuation l -> i -> m Bool)
    
    chrg's avatar
    chrg committed
      -> Valuation l
    
    chrg's avatar
    chrg committed
      -> IRTree l i
      -> m i
    
    chrg's avatar
    chrg committed
    ireduce = ireduceT (pure . runIdentity)
    {-# INLINE ireduce #-}
    
    -- | Interpreted reduction with an m base monad
    ireduceT
      :: forall t m l i
       . (Monad m, Monad t, Ord l)
      => (forall a. m a -> t a)
      -- ^ a lift of monad m into t (normally @id@ or @lift@)
    
    chrg's avatar
    chrg committed
      -> (Valuation l -> i -> t Bool)
    
    chrg's avatar
    chrg committed
      -> Valuation l
      -> IRTreeT l m i
      -> t i
    ireduceT lift_ p v (IRTreeT m) = go []
    
    chrg's avatar
    chrg committed
     where
    
    chrg's avatar
    chrg committed
      go pth =
    
    chrg's avatar
    chrg committed
        lift_ (runStateT m (ReState pth v)) >>= \case
    
    chrg's avatar
    chrg committed
          (i, ReState [] v') -> do
            t <- p v' i
    
    chrg's avatar
    chrg committed
            -- if the predicate is true, we can reduce to the false branch.
            go (pth <> [not t])
          (i, _) -> pure i
    {-# INLINE ireduceT #-}
    
    ireduceExp
      :: forall m l i
       . (Monad m, Ord l)
    
    chrg's avatar
    chrg committed
      => (Valuation l -> i -> m Bool)
    
    chrg's avatar
    chrg committed
      -> Valuation l
      -> IRTree l i
      -> m i
    ireduceExp = ireduceExpT (pure . runIdentity)
    {-# INLINE ireduceExp #-}
    
    -- | Interpreted reduction with an m base monad, and running in expoential mode.
    ireduceExpT
      :: forall t m l i
       . (Monad m, Monad t, Ord l)
      => (forall a. m a -> t a)
      -- ^ a lift of monad m into t (normally @id@ or @lift@)
    
    chrg's avatar
    chrg committed
      -> (Valuation l -> i -> t Bool)
    
    chrg's avatar
    chrg committed
      -> Valuation l
      -> IRTreeT l m i
      -> t i
    ireduceExpT lift_ p v (IRTreeT (StateT m)) = go 0 []
     where
      -- here n is the number of explorative elements
      go n pth =
        lift_ (m $ ReState pth v) >>= \case
    
    chrg's avatar
    chrg committed
          (i, ReState [] v') -> do
            p v' i >>= \case
    
    chrg's avatar
    chrg committed
              True -> do
                let n' = next n
                go n' (pth <> replicate n' False)
              False -> do
                case n of
                  0 -> go 0 (pth <> [True])
                  n' -> go n' $ take (length pth - prev n') pth
    
    chrg's avatar
    chrg committed
          (i, _) -> pure i
    
    chrg's avatar
    chrg committed
    
      next 0 = 1
      next n = n * 2
    
      prev 1 = 0
      prev n = n `quot` 2