module NumericPrelude.List where
import Data.List (unfoldr, genericReplicate)
import NumericPrelude.Condition (toMaybe)
sieve, sieve', sieve'', sieve''' :: Int -> [a] -> [a]
sieve k =
unfoldr (\xs -> toMaybe (not (null xs)) (head xs, drop k xs))
sieve' k = map head . sliceVert k
sieve'' k x = map (x!!) [0,k..(length x1)]
sieve''' k = map head . takeWhile (not . null) . iterate (drop k)
sliceHoriz, sliceHoriz' :: Int -> [a] -> [[a]]
sliceHoriz n =
map (sieve n) . take n . iterate (drop 1)
sliceHoriz' n =
foldr (\x ys -> let y = last ys in takeMatch ys ((x:y):ys)) (replicate n [])
sliceVert, sliceVert' :: Int -> [a] -> [[a]]
sliceVert n =
map (take n) . takeWhile (not . null) . iterate (drop n)
sliceVert' n =
unfoldr (\x -> toMaybe (not (null x)) (splitAt n x))
takeMatch :: [b] -> [a] -> [a]
takeMatch = flip (zipWith const)
splitAtMatch :: [b] -> [a] -> ([a],[a])
splitAtMatch (_:ns) (x:xs) =
let (as,bs) = splitAtMatch ns xs
in (x:as,bs)
splitAtMatch _ [] = ([],[])
splitAtMatch [] xs = ([],xs)
replicateMatch :: [a] -> b -> [b]
replicateMatch xs y =
takeMatch xs (repeat y)
compareLength :: [a] -> [b] -> Ordering
compareLength (_:xs) (_:ys) = compareLength xs ys
compareLength [] [] = EQ
compareLength (_:_) [] = GT
compareLength [] (_:_) = LT
zipWithPad :: a
-> (a -> a -> b)
-> [a]
-> [a]
-> [b]
zipWithPad z f =
let aux l [] = map (\x -> f x z) l
aux [] l = map (\y -> f z y) l
aux (x:xs) (y:ys) = f x y : aux xs ys
in aux
zipWithOverlap :: (a -> c) -> (b -> c) -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithOverlap fa fb fab =
let aux (x:xs) (y:ys) = fab x y : aux xs ys
aux xs [] = map fa xs
aux [] ys = map fb ys
in aux
zipWithMatch
:: (a -> b -> c)
-> [a]
-> [b]
-> [c]
zipWithMatch f =
let aux (x:xs) (y:ys) = f x y : aux xs ys
aux [] [] = []
aux _ _ = error "zipWith: lists must have the same length"
in aux
zipNeighborsWith :: (a -> a -> a) -> [a] -> [a]
zipNeighborsWith f xs = zipWith f xs (drop 1 xs)
shear :: [[a]] -> [[a]]
shear xs@(_:_) =
let (y:ys,zs) = unzip (map (splitAt 1) xs)
zipConc (a:as) (b:bs) = (a++b) : zipConc as bs
zipConc [] bs = bs
zipConc as [] = as
in y : zipConc ys (shear (dropWhileRev null zs))
shear [] = []
shearTranspose :: [[a]] -> [[a]]
shearTranspose =
let
zipCons (x:xs) (y:ys) = (x:y) : zipCons xs ys
zipCons [] ys = ys
zipCons xs [] = map (:[]) xs
aux (x:xs) yss = [x] : zipCons xs yss
aux [] yss = []:yss
in foldr aux []
outerProduct :: (a -> b -> c) -> [a] -> [b] -> [[c]]
outerProduct f xs ys = map (flip map ys . f) xs
partitionMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe f =
foldr (\x ~(y,z) -> case f x of
Just x' -> (x' : y, z)
Nothing -> (y, x : z)) ([],[])
splitLast :: [a] -> ([a], a)
splitLast [] = error "splitLast: empty list"
splitLast [x] = ([], x)
splitLast (x:xs) =
let (xs', lastx) = splitLast xs in (x:xs', lastx)
propSplitLast :: Eq a => [a] -> Bool
propSplitLast xs =
splitLast xs == (init xs, last xs)
dropWhileRev :: (a -> Bool) -> [a] -> [a]
dropWhileRev p =
foldr (\x xs -> if p x && null xs then [] else x:xs) []
mapLast :: (a -> a) -> [a] -> [a]
mapLast f =
let recurse [] = []
recurse (x:[]) = f x : []
recurse (x:xs) = x : recurse xs
in recurse
padLeft :: a -> Int -> [a] -> [a]
padLeft c n xs = replicate (n length xs) c ++ xs
padRight :: a -> Int -> [a] -> [a]
padRight c n xs = xs ++ replicate (n length xs) c
reduceRepeated, reduceRepeatedSlow ::
(a -> a -> a) -> a -> a -> Integer -> a
reduceRepeated _ a0 _ 0 = a0
reduceRepeated op a0 a n =
if even n
then reduceRepeated op a0 (op a a) (div n 2)
else reduceRepeated op (op a0 a) (op a a) (div n 2)
reduceRepeatedSlow op a0 a n =
foldr op a0 (genericReplicate n a)
iterateAssoc, iterateLeaky :: (a -> a -> a) -> a -> [a]
iterateAssoc op a =
foldr (\pow xs -> pow : concatMap (\x -> [x, op x pow]) xs)
undefined (iterate (\x -> op x x) a)
iterateLeaky op x =
let merge (a:as) b = a : merge b as
merge _ _ = error "iterateLeaky: an empty list cannot occur"
sqrs = map (\y -> op y y) z
z = x : merge sqrs (map (op x) sqrs)
in z