List operations

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
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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
module Control.List where

import Control.Monad

import Data.List
import Data.Set (Set)
import qualified Data.Set as Set

import System.Random

import Data.Peano                       -- http://lpaste.net/107204

-- A set of operations not included in the standard library of Data.List

-- chops, as in mutton. We chop a list into little, tiny pieces, and then
-- eat them up, yum!

chops :: Int -> [a] -> [[a]]
chops _ [] = []
chops n list = take n list : chops n (drop n list)

-- I could have done a fold there, but ... eh.

-- *Main> chops 4 [1..12] ~> [[1,2,3,4],[5,6,7,8],[9,10,11,12]]

-- powerSet, because we all need a little powerSet-love-action now and again

{-- declarative semantics, but blows up
powerSet :: Ord a => [a] -> [[a]]
powerSet lst = lst : (Set.toList (Set.fromList (concat (ps lst))))

ps :: Ord a => [a] -> [[[a]]]
ps [] = return [[]]
ps lst@(_:_) = takeout lst >>= \(_, rest) -> ps rest >>= return . (:) rest

 --}

-- much, Much, MUCH more efficient implementation ...
powerSet :: (Enum a, Ord a) => [a] -> [[a]]
powerSet list =
   let len = length list
   in  [len, pred len .. 1] >>= flip choose list

-- *Control.List> powerSet [1,2,3] ~> [[1,2,3],[1,2],[1,3],[2,3],[1],[2],[3]]

-- constructs a list of length n ... I find I need this all the time.

peanoList :: Int -> [Peano]
peanoList = p . fromInteger . toInteger
   where p Z = []
         p q@(S n) = q : p n

-- takeout grabs an element from a list and returns it and the rest of the
-- list

takeout :: Eq a => [a] -> [(a, [a])]
takeout list@(_:_) = [ (elt, rest) | elt <- list, let rest = delete elt list ]

-- takeout is very 'State-y'

-- permute

permute :: Eq a => [a] -> [[a]]
permute [] = [[]]
{--

Explanation for permute [] = [[]] (n.b.: NOT permute [] = []) is at
http://stackoverflow.com/questions/6627721/recursive-permutation-function-always-returns-empty-list

Side note: the number of permutations for list of length n is n!
 --}

permute list@(_:_) = -- [h:t | (h, rest) <- takeout list, t <- permute rest]
   takeout list >>= \(h, rest) -> map (h :) (permute rest)

-- to compute _A_ permutation in linear time (instead of computing all
-- permutations in O(N*N!) time), we do the following:

perm :: [a] -> IO [a]
perm list@(_:_) = p' list (pred $ length list)
   where p' list 1 = return list
         p' list@(h:t) n = getStdRandom (randomR (0,n)) >>= \idx ->
            let (pre, s, post) = select idx list
            in  p' (wtail pre h ++ post) (pred n) >>= return . (s :)

-- wtail consumes an element, even if it's from the next list

wtail :: [a] -> a -> [a]
wtail [] h = []
wtail (h:t) x = t ++ [x]

-- select separates a list to (pre, selected element, post)
select :: Int -> [a] -> ([a], a, [a])
select 0 (h:t) = ([], h, t)
select n list = let (h:t) = drop n list in (take n list, h, t)

-- choose chooses choosily n elements of list giving all combinations of same

{--
choose :: (Enum a, Ord a) => Int -> [a] -> [[a]]
choose _ [] = []
choose n list@(_:_) = c' (fromInt n) (toEnum 0) [] list
   where c' Z _ accum _ = return $ reverse accum
         c' (S n) min accum seed = takeout seed >>= \(a, s) ->
              guard (a > min) >> c' n a (a : accum) s

-- let's give an efficient chooser for greater k :/
 --}
choose :: Ord a => Int -> [a] -> [[a]]
choose k list =
   let n = length list
       halfn = div n 2
   in  (if k <= halfn then buildupChoose k else removeFromChoose (n - k)) list

removeFromChoose :: Ord a => Int -> [a] -> [[a]]
removeFromChoose 0 list = return list
removeFromChoose nk list = 
   map Set.toList (Set.toList (Set.fromList 
   (map Set.fromList (takeout list >>= \(_, rest) ->
   removeFromChoose (pred nk) rest))))

buildupChoose :: Ord a => Int -> [a] -> [[a]]
buildupChoose 0 _ = return []
buildupChoose n list = 
   map Set.toList (Set.toList (Set.fromList (takeout list >>= \(elt, rest) ->
   buildupChoose (pred n) rest >>= return . Set.fromList . (:) elt)))

-- if we wish to know our commitment of nCk we can precompute its length:

lenChoose :: Integer -> Integer -> Integer
lenChoose n k = fac n `div` (fac k * fac (n-k))
   where fac x = product [1..x]

{--
-- determines that a list of lists have all unique elements
-- (this has come up more than once)

allUniqElems :: Eq a => [[a]] -> Bool
allUniqElems [] = True
allUniqElems ((e:es):lists) = 
   a' e es && a' e (join lists) && allUniqElems lists
      where a' element list = element `notElem` list

-- commented out; this implementation isn't quite right! :/

 --}

-- consList proves list has (at least one) element(s)

consList :: [a] -> Bool
consList (_:_) = True
consList _     = False

-- take the number of rows request, OR, if we cannot, then just give
-- the first row as an answer (the default value).

mbtake :: (Enum n, Num n, Eq n) => [a] -> n -> Either [a] a
mbtake (h:t) x = takeThis t (pred x) [h] -- good thing order is unimportant!
   where takeThis _     0 ans = Left ans
         takeThis []    x _   = Right h
         takeThis (h:t) x ans = takeThis t (pred x) (h:ans)
84:17: Warning: Use liftM
Found:
p' (wtail pre h ++ post) (pred n) >>= return . (s :)
Why not:
liftM (s :) (p' (wtail pre h ++ post) (pred n))
126:4: Warning: Use liftM
Found:
buildupChoose (pred n) rest >>= return . Set.fromList . (:) elt
Why not:
(liftM (Set.fromList . (:) elt) (buildupChoose (pred n) rest))