From 69081d160dbf6f7d06b9cafd876e0fea423b8066 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 1 Jun 2016 01:21:03 +0200
Subject: =?UTF-8?q?NDT=20=E2=80=93=20nondeterminism=20with=20monotonous=20?=
 =?UTF-8?q?pruning?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 events/src/Events/Types/NDT.hs | 92 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 92 insertions(+)
 create mode 100644 events/src/Events/Types/NDT.hs

diff --git a/events/src/Events/Types/NDT.hs b/events/src/Events/Types/NDT.hs
new file mode 100644
index 0000000..94a84f0
--- /dev/null
+++ b/events/src/Events/Types/NDT.hs
@@ -0,0 +1,92 @@
+{-# 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.Monad
+import Control.Monad.Identity
+
+import Control.Monad.Trans
+
+import Debug.Trace
+
+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
+
+instance Show (NDT Identity a) where
+  show (NDTBind x _) = "Bind (" ++ show x ++ ") _"
+  show x = show . (\(NDTCons x) -> x) $ fmap (const ()) x
+
+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
+  fail = const empty
+  (>>=) = NDTBind
+
+instance Monad m => Monoid (NDT m a) where
+  mempty = empty
+  mappend (NDTCons x) y'@(NDTCons y) = trace "(cons <> cons)" . NDTCons . trace "[cons <> cons]" $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x
+  mappend (NDTBind x f) (NDTBind y g) = trace "(bind <> bind)" $ NDTBind (fmap Left x <> fmap Right y) (either f g)
+  mappend x@(NDTBind _ _) y = trace "(bind <>)" $ x <> NDTBind y return
+  mappend x y@(NDTBind _ _) = trace "(<> bind)" $ NDTBind x return <> y
+
+instance MonadTrans NDT where
+  lift = NDTCons . fmap Just . fmap (,empty)
+
+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)
+  
+foldNDT :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m a
+foldNDT sel = fmap snd . foldNDT' sel
+
+foldNDT' :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m (Any, a)
+-- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings
+foldNDT' sel (NDTCons mx) = do
+  mx' <- mx
+  case mx' of
+    Nothing -> return mempty
+    Just (x, mxs) -> do
+      continue <- sel x
+      case trace ("(cons "++ show continue ++ ")") continue of
+        False -> return (Any True, mempty)
+        True  -> ((Any True, x) <>) <$> foldNDT' sel mxs
+foldNDT' sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
+  x' <- x
+  case x' of
+    Nothing -> return mempty
+    Just (x'', xs) -> do -- foldNDT' sel . NDTCons $ Just . (, NDTBind xs f) . snd <$> foldNDT' sel (f x'')
+      (productive, x3) <- foldNDT' sel $ f x''
+      continue <- sel x3
+      case trace ("(bind cons " ++ show (productive, continue) ++ ")") $ continue || not (getAny productive) of
+        False -> return mempty
+        True -> ((mempty, x3) <>) <$> foldNDT' sel (NDTBind xs f)
+foldNDT' sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT' sel $ NDTBind x (f <=< g)
+
+fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
+fromFoldable = foldr cons empty
-- 
cgit v1.2.3