melpon日記 - HaskellもC++もまともに扱えないへたれのページ

2011-10-05

[]foldr のすごさを体験してみた 16:32 foldr のすごさを体験してみたを含むブックマーク

Real World Haskell にはこんなコードが載ってます。

myFoldl :: (a -> b -> a) -> a -> [b] -> a
myFoldl f z xs = foldr step id xs z
  where step x g a = g (f a x)
Real World Haskell p100 4.6.8 右からの畳み込み

foldl は foldr を使って書けるという例です。

こんな風にほとんどのリスト処理は再帰を使わなくても foldr を使えば書けるらしい*1ので、どこまでできるのか確認するために Prelude にある Data.List の関数を再定義してみました。


ルールは、

  • 再定義した関数は直接的または間接的に再帰していてはならない(foldr は除く)
  • 再帰しないで作った関数を他の関数で使うのは OK
  • 再定義した関数は元の関数と同じ計算量で同じ結果を返さなければならない

という感じです。

こんな風になりました。

import Prelude hiding (
  -- List operations
  map,(++),filter,head,last,tail,init,null,length,(!!),reverse,
  ---- Reducing lists (folds)
  foldl,foldl1,{-foldr,-}foldr1,
  ------ Special folds
  and,or,any,all,sum,product,concat,concatMap,maximum,minimum,
  ---- Building lists
  ------ Scans
  scanl,scanl1,scanr,scanr1,
  ---- Infinite lists
  {-iterate,-}repeat,replicate,cycle,
  ---- Sublists
  take,drop,splitAt,takeWhile,dropWhile,span,break,
  ---- Searching lists
  elem,notElem,lookup,
  ---- Zipping and unzipping lists
  zip,zip3,zipWith,zipWith3,unzip,unzip3,
  ---- Functions on strings
  lines,words,unlines,unwords)
import Data.Maybe (fromJust)

-- List operations
map :: (a -> b) -> [a] -> [b]
map f = foldr ((:).f) []

(++) :: [a] -> [a] -> [a]
(++) = flip (foldr (:))

filter :: (a -> Bool) -> [a] -> [a]
filter p = foldr f []
  where f x xs | p x       = x:xs
               | otherwise = xs

head :: [a] -> a
head (x:_) = x

last :: [a] -> a
last = foldr1 (flip const)

tail :: [a] -> [a]
tail (_:xs) = xs

init :: [a] -> [a]
init (x:xs) = foldr f (const []) xs x
  where f x g = (:g x)

null :: [a] -> Bool
null [] = True
null _  = False

length :: [a] -> Int
length = foldr (curry ((+1).snd)) 0

(!!) :: [a] -> Int -> a
(!!) xs n | n < 0     = error "out of index"
          | otherwise = foldr f (error "out of index") xs n
            where f x g 0 = x
                  f x g n = g (n-1)

reverse :: [a] -> [a]
reverse = foldl (flip (:)) []

---- Reducing lists (folds)
foldl :: (a -> b -> a) -> a -> [b] -> a
foldl f init xs = foldr step id xs init
  where step x g a = g (f a x)

foldl1 :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs

--foldr :: (a -> b -> b) -> b -> [a] -> b

foldr1 :: (a -> a -> a) -> [a] -> a
foldr1 f (x:xs) = foldr step id xs x
  where step x g = flip f (g x)

------ Special folds
and :: [Bool] -> Bool
and = foldr (&&) False

or :: [Bool] -> Bool
or = foldr (||) False

any :: (a -> Bool) -> [a] -> Bool
any p = foldr ((||).p) False

all :: (a -> Bool) -> [a] -> Bool
all p = foldr ((&&).p) True

sum :: Num a => [a] -> a
sum = foldr (+) 0

product :: Num a => [a] -> a
product = foldr (*) 1

concat :: [[a]] -> [a]
concat = foldr (++) []

concatMap :: (a -> [b]) -> [a] -> [b]
concatMap f = foldr ((++).f) []

maximum :: Ord a => [a] -> a
maximum = foldr1 max

minimum :: Ord a => [a] -> a
minimum = foldr1 min

---- Building lists
------ Scans
scanl :: (a -> b -> a) -> a -> [b] -> [a]
scanl f x xs = foldr step (:[]) xs x
  where step x g a = a:g (f a x)

scanl1 :: (a -> a -> a) -> [a] -> [a]
scanl1 f (x:xs) = scanl f x xs

scanr :: (a -> b -> b) -> b -> [a] -> [b]
scanr f x xs = foldr step (:[]) xs x
  where step x g a = f x a:g a

scanr1 :: (a -> a -> a) -> [a] -> [a]
scanr1 f (x:xs) = foldr step (:[]) xs x
  where step x g a = f a x:g x

---- Infinite lists
--iterate :: (a -> a) -> a -> [a]

repeat :: a -> [a]
repeat = iterate id

replicate :: Int -> a -> [a]
replicate n = take n . repeat

cycle :: [a] -> [a]
cycle = concat . repeat

---- Sublists
take :: Int -> [a] -> [a]
take n xs = foldr f (const []) xs n
  where f x g 0 = []
        f x g n = x:g (n-1)

drop :: Int -> [a] -> [a]
drop n xs = foldr f (const []) xs n
  where f x g 0 = x:g 0
        f x g n = g (n-1)

splitAt :: Int -> [a] -> ([a],[a])
splitAt n xs = (take n xs,drop n xs)

takeWhile :: (a -> Bool) -> [a] -> [a]
takeWhile p = foldr f []
  where f x xs | p x       = x:xs
               | otherwise = []

dropWhile :: (a -> Bool) -> [a] -> [a]
dropWhile p xs = foldr f (const []) xs True
  where f x g True  | p x       = g True
                    | otherwise = x:g False
        f x g False             = x:g False

span :: (a -> Bool) -> [a] -> ([a],[a])
span p xs = (takeWhile p xs,dropWhile p xs)

break :: (a -> Bool) -> [a] -> ([a],[a])
break p = span (not . p)

---- Searching lists
elem :: Eq a => a -> [a] -> Bool
elem x = any (==x)

notElem :: Eq a => a -> [a] -> Bool
notElem x = not . elem x

lookup :: Eq a => a -> [(a, b)] -> Maybe b
lookup x = foldr f Nothing
  where f (a,b) mb | x==a      = Just b
                   | otherwise = mb

---- Zipping and unzipping lists
zip :: [a] -> [b] -> [(a,b)]
zip = zipWith (,)

zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
zip3 = zipWith3 (,,)

zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith f = foldr g (const [])
  where g x h []     = []
        g x h (y:ys) = f x y:h ys

zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 f = foldr g (\_ _->[])
  where g x h []     _      = []
        g x h _      []     = []
        g x h (y:ys) (z:zs) = f x y z:h ys zs

unzip :: [(a, b)] -> ([a], [b])
unzip = foldr f ([],[])
  where f (x,y) ~(xs,ys) = (x:xs,y:ys)

unzip3 :: [(a, b, c)] -> ([a], [b], [c])
unzip3 = foldr f ([],[],[])
  where f (x,y,z) ~(xs,ys,zs) = (x:xs,y:ys,z:zs)

---- Functions on strings
lines :: String -> [String]
lines str = snd $ foldr f first str '\n'
  where f c g = uncurry second (g c)
        first '\n' = ("",[])
        first c    = ([c],[])
        second str strs '\n' = ("",str:strs)
        second str strs c    = (c:str,strs)

words :: String -> [String]
words str = snd $ foldr f (g "" []) str ' '
  where f c g' = uncurry g (g' c)
        g str strs ' ' | null str  = ("",strs)
                       | otherwise = ("",str:strs)
        g str strs c               = (c:str,strs)

unlines :: [String] -> String
unlines = concatMap (++"\n")

unwords :: [String] -> String
unwords [] = []
unwords xs = foldr1 f xs
  where f x y = x++(' ':y)

foldr 以外は再帰しないとか言ってましたが、 iterate 関数は無限の入力が無いと無理なので諦めました。

あと計算量についても、微妙に無駄があったり*2とかしてうぬぬという感じですが、とりあえず無限リストに対しても無駄なサンクを作ったりすることなく同じ動作をするようには心がけました。


iterate 関数と、それを使って実装している repeat, replicate, cycle 関数、それから head といった元々リスト処理が不要な関数は foldr では書けません(書きません)でしたが、それ以外は全部 foldr あるいは foldr を間接的に利用している関数を使って書くことができました。

zip あたりとか無理じゃね?と思っていたのですが、id:uskz 先生に教えてもらいつつ何とか実装できました。foldr すごいです。


個人的には scan の実装がいい感じにできたかなと思います。

逆に words や lines はもっと改善できそうな気がするのですが、うまい方法が思いつかなかったです。

*1:こういう関数を原始帰納的関数とか言うらしい

*2:例えば dropWhile とか p x が False になった後も毎回パターンマッチしてて無駄だとか

yoshikuni-jujoyoshikuni-jujo 2015/09/01 17:39 興味深く拝見させていただきました。
参考になります。
scanr1まで読ませていただきました。
おそらくscanrとscanr1がちがうのではないかと思います。
正しくは以下のようになるのではないでしょうか。

scanr f = foldr s . (: []) where s x va@(v : _) = f x v : va
scanr1 f (x : xs) = foldr s (: []) xs x
where s x g a = let va@(v : _) = g x in f a v : va

僭越ながら指摘させていただきました。
その他、非常に参考になりました。
ありがとうございます。
こちらの思いちがいでしたら無視してください。

yoshikuni-jujoyoshikuni-jujo 2015/09/02 14:32 linesとwordsの定義ですが以下のように書くときれいかと思います。

lines = separate (== '\n')
words = separate isSpace

separate :: (a -> Bool) -> [a] -> [[a]]
separate p = foldr (\x -> if p x then ([] :) else hd (x :)) [[]]
where hd f (x : xs) = f x : xs

トラックバック - http://d.hatena.ne.jp/melpon/20111005/1317799929