Skip to content
Snippets Groups Projects
RTree.hs 3.76 KiB
Newer Older
  • Learn to ignore specific revisions
  • chrg's avatar
    chrg committed
    {-# LANGUAGE BlockArguments #-}
    
    chrg's avatar
    chrg committed
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE RankNTypes #-}
    
    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 where
    
    
    chrg's avatar
    chrg committed
    import Control.Monad
    
    chrg's avatar
    chrg committed
    import Data.Functor
    
    chrg's avatar
    chrg committed
    import Data.Functor.Identity
    import qualified Data.List.NonEmpty as NE
    
    chrg's avatar
    chrg committed
    
    -- | The reduction tree, parameterized by a genrative functor 'f'.
    data ReduceT f i
      = Done i
      | f (ReduceT f i) :<| ReduceT f i
    
    
    chrg's avatar
    chrg committed
    type RTree i = ReduceT Identity i
    
    {- | The reduction tree is a functor, but only over order-embeddings,
    this means that i@f a <= f b@ iff @a <= b@.
    -}
    
    chrg's avatar
    chrg committed
    instance (Functor f) => Functor (ReduceT f) where
      fmap f = \case
        Done i -> Done (f i)
        mi :<| ri -> fmap (fmap f) mi :<| fmap f ri
    
    instance (Functor f) => Applicative (ReduceT f) where
      pure = Done
      (<*>) = ap
    
    instance (Functor f) => Monad (ReduceT f) where
      ma >>= fa = case ma of
        Done i -> fa i
        mi :<| ri -> ((>>= fa) <$> mi) :<| (ri >>= fa)
    
    -- | Change the underlying monad using a natural transformation.
    liftR :: (Functor f) => (forall a. f a -> g a) -> ReduceT f i -> ReduceT g i
    liftR nat = \case
      Done i -> Done i
      lhs :<| rhs -> nat (liftR nat <$> lhs) :<| liftR nat rhs
    
    -- | Extract the input from the reducer.
    extract :: ReduceT f i -> i
    extract = \case
      Done i -> i
      _ :<| rhs -> extract rhs
    
    -- | Reduce an input using a monad.
    reduce :: (MonadPlus m) => (i -> m ()) -> ReduceT m i -> m i
    reduce fn rt = case rt of
      Done i -> fn i $> i
      lhs :<| rhs -> do
        (lhs >>= reduce fn) `mplus` reduce fn rhs
    
    infixr 3 <|
    
    -- Combinators
    (<|) :: (Applicative f) => ReduceT f i -> ReduceT f i -> ReduceT f i
    f <| b = pure f :<| b
    
    -- | Split the world on a fact. False it does not happen, and True it does happen.
    given :: (Applicative f) => ReduceT f Bool
    given = pure False <| pure True
    
    -- | A reducer is something that takes an inputs and returns a reduction tree.
    type Reducer m i = i -> ReduceT m i
    
    
    chrg's avatar
    chrg committed
    {- | A reducer should extract itself
    @
     extract . red = id
    @
    -}
    
    chrg's avatar
    chrg committed
    lawReduceId :: (Eq i) => Reducer m i -> i -> Bool
    lawReduceId red i = extract (red i) == i
    
    
    chrg's avatar
    chrg committed
    -- | Reducing a list one element at a time.
    
    chrg's avatar
    chrg committed
    rList :: (Applicative m) => Reducer m [a]
    rList = \case
      [] -> Done []
      a : as -> rList as <| (a :) <$> rList as
    
    
    chrg's avatar
    chrg committed
    {- | Binary reduction on the list assumming suffixes all contain eachother:
    @[] < [c] < [b, c] < [a,b,c]@
    -}
    rSuffixList :: (Applicative m) => Reducer m [a]
    rSuffixList as = do
      res <- binarySearch (NE.reverse (NE.tails as))
      case res of
        [] -> pure []
        a : as' -> (a :) <$> rSuffixList as'
    
    {- | Given a progression of inputs that are progressively larger, pick the smallest using
    binary search.
    -}
    binarySearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
    binarySearch = \case
      a NE.:| [] -> Done a
      d -> binarySearch f <| binarySearch l
       where
        (NE.fromList -> f, NE.fromList -> l) = NE.splitAt (NE.length d `div` 2) d
    
    -- | Given a list of orderd options,  the
    linearSearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
    linearSearch = foldr1 (<|) . fmap Done
    
    -- | Given a list of orderd options,  the
    linearSearch' :: (Applicative m) => [i] -> ReduceT m (Maybe i)
    linearSearch' is = linearSearch (NE.fromList $ fmap Just is ++ [Nothing])
    
    -- | Given
    ddmin :: (Applicative m) => [i] -> ReduceT m [i]
    ddmin = \case
      [] -> pure []
      [a] -> pure [a]
      as -> go 2 as
     where
      go n lst
        | n' <= 0 = pure lst
        | otherwise = do
            r <- linearSearch' (partitions n' lst ++ composites n' lst)
            case r of
              Nothing -> go (n * 2) lst <| pure lst -- (for efficiency :D)
              Just lst' -> ddmin lst'
       where
        n' = length lst `div` n
      partitions n lst =
        case lst of
          [] -> []
          _ -> let (h, r) = splitAt n lst in h : partitions n r
      composites n lst =
        case lst of
          [] -> []
          _ -> let (h, r) = splitAt n lst in r : fmap (h ++) (composites n r)