events.02

1 files changed, 174 insertions, 0 deletions

diff --git a/provider/posts/events/02.lhs b/provider/posts/events/02.lhs
new file mode 100644
index 0000000..9b919a7
--- /dev/null
+++ b/provider/posts/events/02.lhs
@@ -0,0 +1,174 @@
+---
+title: "A Monad Encoding Co-Total Lists Admitting Cutoff-Rules"
+published: 2016-07-29
+tags: events
+repo: https://git.yggdrasil.li/gkleen/pub/events
+base: https://git.yggdrasil.li/gkleen/pub/events/tree/events/src/Events/Types/NDT.hs?id=9bffd435230514c00177a315bf65d9c13969f7dc
+---
+
+In [the last post](01.html) I presented `Eval`{.haskell}, a monad transformer
+for constructing a finite list of `Object`{.haskell}s together with a
+`Bool`{.haskell}-Annotation (denoting whether the `Event`{.haskell} represented
+by the `Object`{.haskell} should occur or not) while having access to arbitrary
+monadic state.
+
+The Implementation presented used [`ListT`{.haskell}][] to encapsulate
+non-determinism.
+
+Consider the following (nonfunctional[^brokenExample] for the sake of readability) example:
+
+~~~ {.haskell}
+fmap filterTime . evaluate {- This is not the `evaluate` defined in Events.Eval -} $ do
+  n <- fromFoldable [1..]
+  objPayload .= [ ("date", toJSON $ (n * 7) `addDays` (fromGregorian 2016 07 29))
+                ]
+  where
+    filterTime :: [Object] -> [Object]
+    filterTime = filter $ maybe False (\t -> qDate <= t && t <= qDate') <$> view (objPayload . key "date" . asDate)
+    qDate  = fromGregorian 2016 08 01
+    qDate' = fromGregorian 2016 08 07
+~~~
+
+Due to `fromFoldable [1..]`{.haskell} this will surely never terminate yet it is obvious that the question, whether the week from 2016-08-01 to 2016-08-07 contains one of our series of events, is answerable in finite time.
+
+We would like to be able to employ constructions like the one above for the sake of convenience – it is often the case that we don´t yet know when a regularly scheduled appointment will stop taking place.
+Ensuring that our list-comprehensions always terminate is of course the halting problem – we can however employ some trickery to make rather simple constructs, like the one above, work.
+
+To do so in our concrete application we leverage the fact that, at evaluation time, we always know which `TimeRange`{.haskell} we´re interested in and can stop, given that we generate new `Event`{.haskell}s only monotonically in time, checking new `Event`{.haskell}s exactly when we encounter the first in our worldline which lies entirely after our `TimeRange`{.haskell}.
+
+> {-# LANGUAGE GADTs #-}
+> {-# LANGUAGE TupleSections #-}
+> {-# LANGUAGE ViewPatterns #-}
+> {-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
+> 
+> module Events.Types.NDT
+>   ( NDT
+>   , foldNDT
+>   , cons
+>   , fromFoldable
+>   ) where
+> 
+> import Data.Monoid
+> import Data.Foldable (foldr)
+> import Data.Maybe
+> import Data.Either
+> 
+> import Control.Applicative (Alternative)
+> import qualified Control.Applicative as Alt (Alternative(..))
+> import Control.Monad
+> import Control.Monad.Identity
+> 
+> import Control.Monad.Trans
+> 
+> data NDT m a where
+>   NDTBind :: NDT m a -> (a -> NDT m b) -> NDT m b
+>   NDTCons :: m (Maybe (a, NDT m a)) -> NDT m a
+
+`NDT m a`{.haskell} as defined above is essentially just `m [a]`{.haskell}.
+The more involved construction, reminiscent of [`Free`{.haskell}][][^usingFree] is owed to the fact that stopping to evaluate after some criterion requires that criterion be known; we´d have to save it in `NDT`{.haskell}, which is incompatible with `return`{.haskell}.
+
+What follows are some fairly straight forward and not particularly interesting instances needed essentially for making `NDT`{.haskell} into a proper monad-transformer.
+
+> instance Functor m => Functor (NDT m) where
+>   fmap f (NDTBind a g) = NDTBind a (fmap f . g)
+>   fmap f (NDTCons x) = NDTCons $ fmap f' x
+>     where
+>       f' Nothing = Nothing
+>       f' (Just (x, xs)) = Just (f x, fmap f xs)
+> 
+> instance Applicative m => Applicative (NDT m) where
+>   pure x = NDTCons . pure $ Just (x, empty)
+>   fs <*> xs = fs >>= (\f -> xs >>= pure . (f $))
+> 
+> instance Applicative m => Monad (NDT m) where
+>   return = pure
+>   (>>=) = NDTBind
+> 
+> instance Monad m => Monoid (NDT m a) where
+>   mempty = empty
+>   mappend (NDTCons x) y'@(NDTCons y) = NDTCons $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x
+>   mappend (NDTBind x f) (NDTBind y g) = NDTBind (fmap Left x <> fmap Right y) (either f g)
+>   mappend x@(NDTBind _ _) y = x <> NDTBind y return
+>   mappend x y@(NDTBind _ _) = NDTBind x return <> y
+> 
+> instance MonadTrans NDT where
+>   lift = NDTCons . fmap Just . fmap (,empty)
+> 
+> instance Monad m => Alternative (NDT m) where
+>   empty = mempty
+>   (<|>) = mappend
+> 
+> instance Monad m => MonadPlus (NDT m) where
+>   mzero = mempty
+>   mplus = mappend
+> 
+> instance MonadIO m => MonadIO (NDT m) where
+>   liftIO = lift . liftIO
+> 
+> empty :: Applicative m => NDT m a
+> empty = NDTCons $ pure Nothing
+> 
+> cons :: Applicative m => a -> NDT m a -> NDT m a
+> cons x xs = NDTCons . pure $ Just (x, xs)
+> 
+> fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
+> fromFoldable = foldr cons empty
+
+The evaluation function below implements the pruning behaviour described above:
+
+> foldNDT :: (Foldable f, Applicative f, Monoid (f a), Monad m) => (a -> m Bool) -> NDT m a -> m (f a)
+> -- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings and children
+
+Cons-cells are rather straightforward – iff the head doesn´t fulfil our criterion we ignore both it and the tail:
+
+> foldNDT sel (NDTCons mx) = do
+>   mx' <- mx
+>   case mx' of
+>     Nothing -> return mempty
+>     Just (x, mxs) -> do
+>       continue <- sel x
+>       case continue of
+>         False -> return mempty
+>         True  -> (pure x <>) <$> foldNDT sel mxs
+
+This encodes pruning children of cons-cells which don´t satisfy the criterion in our tree composed of `NDTCons`{.haskell} and `NDTBind`{.haskell}.
+
+Deferred bind operations (`NDTBind`{.haskell}) are somewhat more involved.
+To make handling them easier we first squash `NDTBind`{.haskell}s such that the only children of `NDTBind`{.haskell}s are always cons-cells.
+
+> foldNDT sel (NDTBind (NDTBind x g) f) = foldNDT sel $ NDTBind x (f <=< g)
+
+The desired pruning behaviour for `NDTBind`{.haskell}s is as follows: iff evaluating the tree produced by applying `f`{.haskell} to the head of the cons-cell does not produce a valid object we discard the tail, too[^unproductivePaths].
+
+> foldNDT sel (NDTBind (NDTCons x) f) = do
+>   x' <- x
+>   case x' of
+>     Nothing -> return mempty
+>     Just (x'', xs) -> do
+>       x3 <- foldNDT sel $ f x''
+>       xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f)
+>       return $ x3 <> xs'
+
+Using the above the following now works:
+
+~~~ {.haskell}
+(Yaml.encode <=< evaluate predicate) $ do
+  n <- lift $ NDT.fromFoldable ([1..] :: [Integer])
+  objOccurs .= (n >= 2)
+  objPayload ?= [ ("num", Yaml.Number $ fromIntegral n)
+                ]
+  where
+    predicate :: Monad m => Maybe Yaml.Object -> m Bool
+    predicate = ordPredicate $ maybe LT (`compare` 5) . view (at "num" . asDouble)
+    ordPredicate :: Applicative m => (Object -> Ordering) -> (Maybe Object -> m Bool)
+    ordPredicate _  Nothing        = pure True
+    ordPredicate f (Just (f -> o)) = pure $ o <= EQ -- View Patterns
+~~~
+
+[^brokenExample]: Neither `fromFoldable`{.haskell} nor `asDate`{.haskell} currently exist. I didn´t even bother to see whether the example typechecks.
+[^usingFree]: I am confident that `NDT`{.haskell} could be alternatively constructed using the monad-transformer version of `Free`{.haskell}: [`FreeT`{.haskell}][]
+[^unproductivePaths]: Currently this discards trees which don´t produce valid objects not because they produce invalid ones (which is our stated termination-criterion) but because they don´t produce anything at all. I´ll probably end up changing that after I find a case where that´s a problem (Care to provide one?).
+
+[`ListT`{.haskell}]: <https://hackage.haskell.org/package/list-t>
+[`Free`{.haskell}]: <https://hackage.haskell.org/package/free/docs/Control-Monad-Free.html#t:Free>
+[`FreeT`{.haskell}]: https://hackage.haskell.org/package/free/docs/Control-Monad-Trans-Free.html#t:FreeT<>