1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
| -- | This module defines variations on a function `suffix`, which does the following:
--
-- > λ:> suffix "tails"
-- > ["ails","ils","ls","s"]
--
-- > λ:> suffix "s"
-- > []
module Suffix ( suffix
, suffixPattern
, suffixPattern2
, suffixList
, suffixFunctor
, suffixPattern3
, suffixElgot
, suffixZipper
, suffixHylo
, suffixPattern4
) where
import Control.Arrow
import Data.Functor.Foldable
{-
{-# RULES
"hylo/ana" forall f xs. hylo embed f xs = ana f xs
#-}
-}
suffixElgot :: [a] -> [[a]]
suffixElgot = elgot algebra elgotCoalgebra . drop 1
elgotCoalgebra :: [a] -> Either [[a]] (ListF [a] [a])
elgotCoalgebra [] = Right Nil
elgotCoalgebra [x] = Left [[x]]
elgotCoalgebra [x, y] = Left [[x, y], [y]]
elgotCoalgebra (x:xs) = Right (Cons (x:xs) xs)
-- | This uses a hylomorphism
suffixHylo :: [a] -> [[a]]
suffixHylo = hylo algebra coalgebra . drop 1
-- | Another one, suggested from online
suffixPattern4 :: [a] -> [[a]]
suffixPattern4 [] = []
suffixPattern4 [_] = []
suffixPattern4 (_:xs) = xs : suffixPattern xs
algebra :: ListF [a] [[a]] -> [[a]]
algebra Nil = []
algebra (Cons x xs) = x:xs
coalgebra :: [a] -> ListF [a] [a]
coalgebra [] = Nil
coalgebra (x:xs) = Cons (x:xs) xs
-- | This uses recursion schemes
suffix :: [a] -> [[a]]
suffix = para pseudoalgebra
-- | This is not technically an F-algebra in the mathematical sense
pseudoalgebra :: (Base [a]) ([a], [[a]]) -> [[a]]
pseudoalgebra Nil = mempty
pseudoalgebra (Cons _ x) = uncurry go x
where go y@(x:xs) suffixes = y:suffixes
go _ suffixes = suffixes
-- | This uses pattern matching, and reverses the result at the end.
suffixPattern :: [a] -> [[a]]
suffixPattern x = reverse $ curry (snd . go) x mempty
where go ((x:xs), suffixes) = go (xs, if not $ null xs then xs:suffixes else suffixes)
go (_, suffixes) = ([], suffixes)
-- | This uses pattern matching, and appends the lists to build it in the right order
suffixPattern2 :: [a] -> [[a]]
suffixPattern2 x = curry (snd . go) x mempty
where go ((x:xs), suffixes) = go (xs, if not $ null xs then suffixes ++ [xs] else suffixes)
go (_, suffixes) = ([], suffixes)
-- | This uses pattern matching wihtout ugliness, but it's partial. It's benchmarked
-- to show the problem isn't if-branching.
suffixPattern3 :: [a] -> [[a]]
suffixPattern3 x = curry (snd . go) x mempty
where go ([x], suffixes) = ([], suffixes)
go ((x:xs), suffixes) = go (xs, suffixes ++ [xs])
-- | This uses list comprehensions
suffixList :: [a] -> [[a]]
suffixList x = [ drop n x | n <- [1..(length x - 1)]]
-- | This uses functoriality
suffixFunctor :: [a] -> [[a]]
suffixFunctor x = fmap (flip drop x) [1..(length x -1)]
-- | This uses a zipper
suffixZipper :: [a] -> [[a]]
suffixZipper y@[x] = mempty
suffixZipper y@(x:xs) = zipWith drop [1..] $ map (const y) (init y)
suffixZipper _ = mempty
|