Reduce.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

{- |
Module: Control.Monad.Reduce
-}
module Control.Monad.Reduce (
  MonadReduce (..),
  -- # Constructors
  (<|),
  (|>),
  splitOn,
  given,
  givenThat,
  givenWith,
  check,
  checkThat,
  -- # Combinators
  collect,
  collectNonEmpty,
  collectNonEmpty',
  -- # Algorithms
  ddmin,
  linearSearch,
  linearSearch',
  binarySearch,
  exponentialSearch,
  -- # Helpers
  onBoth,
) where

import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import qualified Data.List.NonEmpty as NE
import Data.Maybe

-- {- | A reducer should extract itself
-- @
--  extract . red = id
-- @
-- -}
-- lawReduceId :: (MonadReduce l m, Eq i) => (i -> m i) -> i -> Bool
-- lawReduceId red i = extract (red i) == i

-- | The Monad Reduce class.
class (Monad m) => MonadReduce l m | m -> l where
  -- | Split the world into the a reduced world (left) without an ellement and a world
  -- with that element (right). Optionally, labeled with l.
  splitWith :: Maybe l -> m i -> m i -> m i
  splitWith l r1 r2 =
    checkWith l >>= \case
      True -> r1
      False -> r2
  {-# INLINE splitWith #-}

  checkWith :: Maybe l -> m Bool
  checkWith l = splitWith l (pure False) (pure True)
  {-# INLINE checkWith #-}

split :: (MonadReduce l m) => m i -> m i -> m i
split = splitWith Nothing
{-# INLINE split #-}

(<|) :: (MonadReduce l m) => m i -> m i -> m i
(<|) = split
{-# INLINE (<|) #-}
infixr 3 <|

(|>) :: (MonadReduce l m) => m i -> m i -> m i
r1 |> r2 = r2 <| r1
{-# INLINE (|>) #-}
infixl 3 |>

splitOn :: (MonadReduce l m) => l -> m i -> m i -> m i
splitOn l = splitWith (Just l)
{-# INLINE splitOn #-}

-- | Split the world on a fact. False it does not happen, and True it does happen.
check :: (MonadReduce l m) => m Bool
check = checkWith Nothing
{-# INLINE check #-}

-- | Split the world on a labeled fact. False it does not happen, and True it does happen.
checkThat :: (MonadReduce l m) => l -> m Bool
checkThat l = checkWith (Just l)
{-# INLINE checkThat #-}

instance (MonadReduce l m) => MonadReduce l (MaybeT m) where
  splitWith m (MaybeT lhs) (MaybeT rhs) = MaybeT (splitWith m lhs rhs)

-- | Continues if the fact is true.
given :: (MonadReduce l m) => MaybeT m ()
given = givenWith Nothing
{-# INLINE given #-}

-- | Continues if the labeled fact is true.
givenWith :: (MonadReduce l m) => Maybe l -> MaybeT m ()
givenWith l = MaybeT $ splitWith l (pure Nothing) (pure (Just ()))
{-# INLINE givenWith #-}

-- | Continues if the labeled fact is true.
givenThat :: (MonadReduce l m) => l -> MaybeT m ()
givenThat l = givenWith (Just l)
{-# INLINE givenThat #-}

-- | Given a list of item try to remove each of them from the list.
collect :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> m [b]
collect fn = fmap catMaybes . traverse (runMaybeT . fn)
{-# INLINE collect #-}

-- | Given a list of item try to remove each of them, but keep atleast one.
collectNonEmpty' :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> MaybeT m [b]
collectNonEmpty' fn as =
  NE.toList <$> collectNonEmpty fn as
{-# INLINE collectNonEmpty' #-}

-- | Given a list of item try to remove each of them, but keep atleast one.
collectNonEmpty :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> MaybeT m (NE.NonEmpty b)
collectNonEmpty fn as = do
  as' <- lift . fmap catMaybes . traverse (runMaybeT . fn) $ as
  MaybeT . pure $ NE.nonEmpty as'
{-# INLINE collectNonEmpty #-}

{- | Given a list of ordered options, choose the first that statisfy the constraints,
returning the last element if nothing else matches.
-}
linearSearch :: (MonadReduce l m) => NE.NonEmpty i -> m i
linearSearch = foldr1 (<|) . fmap pure

{- | Given a list of ordered options, choose the first that statisfy the
constraints, potentially returning nothing.
-}
linearSearch' :: (MonadReduce l m) => [i] -> MaybeT m i
linearSearch' is = MaybeT $ linearSearch (NE.fromList (fmap Just is ++ [Nothing]))

-- | Given
ddmin :: (MonadReduce l m) => [i] -> m [i]
ddmin = \case
  [] -> pure []
  [a] -> pure [a]
  as -> go 2 as
 where
  go n lst
    | n' <= 0 = pure lst
    | otherwise = do
        r <- runMaybeT $ 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)

{- | Given a progression of inputs that are progressively larger, pick the smallest using
binary search.
-}
binarySearch :: (MonadReduce l m) => NE.NonEmpty i -> m i
binarySearch = \case
  a NE.:| [] -> pure a
  d -> binarySearch l <| binarySearch f
   where
    (NE.fromList -> f, NE.fromList -> l) = NE.splitAt (NE.length d `div` 2) d

{- | Given a progression of inputs that are progressively larger, pick the smallest using
binary search.
-}
exponentialSearch :: (MonadReduce l m) => NE.NonEmpty i -> m i
exponentialSearch = go 1
 where
  go n = \case
    d
      | n >= NE.length d -> binarySearch d
      | otherwise -> go (n * 2) l <| binarySearch f
     where
      (NE.fromList -> f, NE.fromList -> l) = NE.splitAt n d

-- | Returns either of the maybes or combines them if both have values.
onBoth :: (Monad m) => MaybeT m a -> MaybeT m a -> (a -> a -> MaybeT m a) -> MaybeT m a
onBoth mlhs mrhs fn = MaybeT do
  runMaybeT mlhs >>= \case
    Nothing -> runMaybeT mrhs
    Just l ->
      runMaybeT mrhs >>= \case
        Nothing -> pure (Just l)
        Just r -> runMaybeT (fn l r)