RTree.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}

{- |
Module: Control.RTree
-}
module Control.RTree where

import Control.Applicative (Alternative ((<|>)))
import Data.Functor
import Data.Functor.Classes
import qualified Data.List.NonEmpty as NE

import Data.Coerce (coerce)
import "free" Control.Monad.Free

-- | The reduction tree
data RTreeF f
  = f :<| f
  | Lab String f f
  deriving (Show, Eq, Functor)

instance Show1 RTreeF where
  liftShowsPrec = undefined

newtype RTree i = RTree {rtreeFree :: Free RTreeF i}
  deriving (Show)
  deriving (Functor, Applicative, Monad) via (Free RTreeF)

instance MonadFree RTreeF RTree where
  wrap x = RTree (Free (fmap rtreeFree x))

infixr 3 <|
infixl 3 |>

(<|) :: (MonadFree RTreeF r) => r i -> r i -> r i
r1 <| r2 = wrap (r1 :<| r2)

lab :: (MonadFree RTreeF r) => String -> r i -> r i -> r i
lab l r1 r2 = wrap (Lab l r1 r2)

(|>) :: (MonadFree RTreeF r) => r i -> r i -> r i
r1 |> r2 = wrap (r2 :<| r1)

foldR :: (RTreeF a -> a) -> RTree a -> a
foldR fn = coerce $ iter fn

-- | Extract the input from the reducer.
extract :: RTree i -> i
extract = foldR \case
  (_ :<| e) -> e
  Lab _ _ e -> e

-- | Reduce an input using a monad.
reduce :: (Alternative m) => (i -> m ()) -> RTree i -> m i
reduce fn =
  ( foldR \case
      lhs :<| rhs -> lhs <|> rhs
      Lab _ lhs rhs -> lhs <|> rhs
  )
    . fmap (\i -> fn i $> i)

-- | Split the world on a fact. False it does not happen, and True it does happen.
given :: RTree Bool
given = pure False <| pure True

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

-- | Reducing a list one element at a time.
rList :: [a] -> RTree [a]
rList = \case
  [] -> pure []
  a : as -> rList as <| (a :) <$> rList as

{- | Binary reduction on the list assumming suffixes all contain eachother:
@[] < [c] < [b, c] < [a,b,c]@
-}
rSuffixList :: [a] -> RTree [a]
rSuffixList as = do
  res <- exponentialSearch (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 :: NE.NonEmpty i -> RTree 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 :: NE.NonEmpty i -> RTree 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

nonEmptyOr :: String -> [a] -> NE.NonEmpty a
nonEmptyOr msg ls = case NE.nonEmpty ls of
  Just a -> a
  Nothing -> error msg

-- | Given a list of orderd options,  the
linearSearch :: NE.NonEmpty i -> RTree i
linearSearch = foldr1 (<|) . fmap pure

-- | Given a list of orderd options,  the
linearSearch' :: [i] -> RTree (Maybe i)
linearSearch' is = linearSearch (NE.fromList $ fmap Just is ++ [Nothing])

-- | Given
ddmin :: [i] -> RTree [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)