Add ddmin

package.yaml

@@ -9,7 +9,8 @@ ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
 
 dependencies:
   - base >= 4.9 && < 5
-  - containers
+  - transformers
+  - mtl
   - language-c
 
 library:

rtree.cabal

@@ -18,6 +18,7 @@ library
   ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
   build-depends:
       base >=4.9 && <5
-    , containers
     , language-c
+    , mtl
+    , transformers
   default-language: Haskell2010

src/Control/RTree.hs

+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
 
--- |
---
--- Module: Control.RTree
+{- |
+
+Module: Control.RTree
+-}
 module Control.RTree where
 
-import Control.Monad (MonadPlus (..), ap, liftM2)
+import Control.Monad
 import Data.Functor
+import Data.Functor.Identity
+import qualified Data.List.NonEmpty as NE
 
 -- | The reduction tree, parameterized by a genrative functor 'f'.
 data ReduceT f i
   = Done i
   | f (ReduceT f i) :<| ReduceT f i
 
+type RTree i = ReduceT Identity i
+
+{- | The reduction tree is a functor, but only over order-embeddings,
+this means that i@f a <= f b@ iff @a <= b@.
+-}
 instance (Functor f) => Functor (ReduceT f) where
   fmap f = \case
     Done i -> Done (f i)
@@ -60,26 +70,69 @@ given = pure False <| pure True
 -- | A reducer is something that takes an inputs and returns a reduction tree.
 type Reducer m i = i -> ReduceT m i
 
--- | A reducer should extract itself
--- @
---  extract . red = id
--- @
+{- | A reducer should extract itself
+@
+ extract . red = id
+@
+-}
 lawReduceId :: (Eq i) => Reducer m i -> i -> Bool
 lawReduceId red i = extract (red i) == i
 
+-- | Reducing a list one element at a time.
 rList :: (Applicative m) => Reducer m [a]
 rList = \case
   [] -> Done []
   a : as -> rList as <| (a :) <$> rList as
 
-rBinaryList :: (Applicative m) => Reducer m [a]
-rBinaryList = \case
-  [] -> Done []
-  as -> Done [] <| go as
-  where
-    go = \case
-      [] -> error "unexpected"
-      [a] -> Done [a]
-      as -> go l <| liftM2 (<>) (go f) (Done [] <| go l)
-        where
-          (f, l) = splitAt (length as `div` 2) as
+{- | Binary reduction on the list assumming suffixes all contain eachother:
+@[] < [c] < [b, c] < [a,b,c]@
+-}
+rSuffixList :: (Applicative m) => Reducer m [a]
+rSuffixList as = do
+  res <- binarySearch (NE.reverse (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 :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
+binarySearch = \case
+  a NE.:| [] -> Done a
+  d -> binarySearch f <| binarySearch l
+   where
+    (NE.fromList -> f, NE.fromList -> l) = NE.splitAt (NE.length d `div` 2) d
+
+-- | Given a list of orderd options,  the
+linearSearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
+linearSearch = foldr1 (<|) . fmap Done
+
+-- | Given a list of orderd options,  the
+linearSearch' :: (Applicative m) => [i] -> ReduceT m (Maybe i)
+linearSearch' is = linearSearch (NE.fromList $ fmap Just is ++ [Nothing])
+
+-- | Given
+ddmin :: (Applicative m) => [i] -> ReduceT m [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)