A* Collapse Monad (see https://www.reddit.com/r/haskell/comments/1gu476s/the_collapse_monad/lxsyge6/)

Collapse.hs

{-# LANGUAGE LambdaCase #-}

module Collapse where

-- base
import Data.Functor ((<&>))
import Data.Functor.Classes (Show1)
import Data.Foldable (toList)
import Control.Monad (ap)

-- containers
import Data.IntMap.Strict qualified as I


-- The 'Collapse' monad can be written as the free monad of the signature
-- functor 'Sup' with the handler 'collapse'; the non-determinism of 'sup'
-- is /algebraic/.
--
-- This implies 'Collapse' can be implemented efficiently via delimited
-- control primops.

data Sup s = Sup Int s s
  deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

sup :: Int -> Free Sup a -> Free Sup a -> Free Sup a
sup i l r = Op (Sup i l r)

collapse :: Free Sup a -> Free Sup a
collapse act = iter alg (const . pure <$> act) I.empty
 where
  alg :: Sup (I.IntMap Bool -> Free Sup a) -> I.IntMap Bool -> Free Sup a
  alg (Sup i l r) m = case I.lookup i m of
    Nothing    -> sup i (l (I.insert i False m))
                        (r (I.insert i True  m))
    Just False -> l m
    Just True  -> r m

flatten :: Free Sup a -> [a]
flatten = toList


-----------------------------
-- free:Control.Monad.Free --
-----------------------------

data Free f a = Pure a | Op (f (Free f a))
  deriving (Functor, Foldable, Traversable)

deriving instance (Show1 f, Show a) => Show (Free f a)

instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap

instance Functor f => Monad (Free f) where
  Pure x >>= g = g x
  Op fmx >>= g = Op (fmx <&> (>>= g))

iter :: Functor f => (f a -> a) -> Free f a -> a
iter alg = \case
  Pure x -> x
  Op fmx -> alg (fmx <&> iter alg)