Newer
Older
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@.
-}
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
instance (Functor f) => Functor (ReduceT f) where
fmap f = \case
Done i -> Done (f i)
mi :<| ri -> fmap (fmap f) mi :<| fmap f ri
instance (Functor f) => Applicative (ReduceT f) where
pure = Done
(<*>) = ap
instance (Functor f) => Monad (ReduceT f) where
ma >>= fa = case ma of
Done i -> fa i
mi :<| ri -> ((>>= fa) <$> mi) :<| (ri >>= fa)
-- | Change the underlying monad using a natural transformation.
liftR :: (Functor f) => (forall a. f a -> g a) -> ReduceT f i -> ReduceT g i
liftR nat = \case
Done i -> Done i
lhs :<| rhs -> nat (liftR nat <$> lhs) :<| liftR nat rhs
-- | Extract the input from the reducer.
extract :: ReduceT f i -> i
extract = \case
Done i -> i
_ :<| rhs -> extract rhs
-- | Reduce an input using a monad.
reduce :: (MonadPlus m) => (i -> m ()) -> ReduceT m i -> m i
reduce fn rt = case rt of
Done i -> fn i $> i
lhs :<| rhs -> do
(lhs >>= reduce fn) `mplus` reduce fn rhs
infixr 3 <|
-- Combinators
(<|) :: (Applicative f) => ReduceT f i -> ReduceT f i -> ReduceT f i
f <| b = pure f :<| b
-- | Split the world on a fact. False it does not happen, and True it does happen.
given :: (Applicative f) => ReduceT f Bool
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
@
-}
lawReduceId :: (Eq i) => Reducer m i -> i -> Bool
lawReduceId red i = extract (red i) == i
rList :: (Applicative m) => Reducer m [a]
rList = \case
[] -> Done []
a : as -> rList as <| (a :) <$> rList as
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{- | 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)