お漏らし Haskeller 矯正ギプス (1) - zipWith

_strict_zipWith.hs

-- 末尾再帰
zipWith'' :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith'' f xs0 ys0 = lgo [] xs0 ys0
  where
    lgo acc (x:xs) (y:ys) = let a = f x y in a `seq` lgo (a:acc) xs ys
    lgo acc _ _ = reverse acc

-- Thunk 潰しつつ余再起
zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' f xs0 ys0 = lgo xs0 ys0
  where
    lgo (x:xs) (y:ys) = let a = f x y in a `seq` a : lgo xs ys
    lgo _ _ = []

PE250.hs

{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wall -O2 #-}

-- 使用例

import Control.Monad(ap, join)
import Control.Monad.Instances()
import Data.List(foldl', genericLength, genericReplicate, genericSplitAt)

-- 結局 bang pattern を使うように書き直しているっていう。。。

-- 末尾再帰
zipWith'' :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith'' f xs0 ys0 = lgo [] xs0 ys0
  where
    lgo acc (x:xs) (y:ys) = let !a = f x y in lgo (a:acc) xs ys
    lgo acc _ _ = reverse acc

-- Thunk 潰しつつ余再起
zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' f xs0 ys0 = lgo xs0 ys0
  where
    lgo (x:xs) (y:ys) = let !a = f x y in a : lgo xs ys
    lgo _ _ = []

modE16 :: Integer -> Integer
modE16 = (`mod` 10000000000000000)

genericRotateLeft :: Integral i => i -> [a] -> [a]
genericRotateLeft = (uncurry (flip (++)) .) . genericSplitAt

genericRotateRight :: Integral i => i -> [a] -> [a]
genericRotateRight = join . (genericRotateLeft .) . flip ((-) . genericLength)

numSubsetsGroupedByMod :: Integer -> [Integer] -> [Integer]
numSubsetsGroupedByMod n xs = foldl' (flip f) v xs 
  where
    -- 要素正格な余再帰と末尾再帰のどちらも大差はないが、標準の zipWith だとスペースリーク発生。。。 
    f = ap (zipWith' ((modE16 .) . (+))) . genericRotateRight
    --f = ap (zipWith'' ((modE16 .) . (+))) . genericRotateRight
    v = 1 : (genericReplicate (n - 1) 0)

answer :: Integer
answer = (numSubsetsGroupedByMod 250 superset) !! 0 - 1
  where
    superset = map (join (powMod 250)) [1..250250]
    -- ↓は遅い。パフォーマンス的に専用ルーチンがいる。。。
    --superset = map ((`mod` 250) . join (^)) [1..250250]
    --superset = map ((`mod` 250) . ((^) =<< (`mod` 250))) [1..250250]

powMod :: (Integral a) => a -> a -> a -> a
powMod modulo base expo = base `pow` expo
  where
    modulate = (`mod` modulo)
    pow x y
      | odd y     = modulate $ x * (x `pow` (y - 1))
      | y == 0    = 1
      | otherwise = modulate $ (modulate (x * x)) `pow` (y `quot` 2)

main = print answer