Project Euler Problem 031

import Data.Array.ST
import Data.Array
import Data.IORef
import qualified Data.Map as M
import Control.Monad
import Control.Monad.ST
import System.IO.Unsafe
-- 重要問題なので多数の解き方で
crcy :: [Int]
crcy = [200,100,50,20,10,5,2,1] --この順にしとくと、最後1円なので必ず払える。順序重要
ans1 :: Integer
ans1 = sol1 crcy 200 --普通の再帰
ans2 :: Integer
ans2 = sol2 crcy 200 --倍数を取り除く再帰
ans3 :: Int
ans3 = length $ btfl crcy !! 200 --無限リストによる解
ans4 :: Int
ans4 = sol4 (reverse crcy) 200 --STArray in STモナド版
ans5 :: Int
ans5 = sol5 (reverse crcy) 200 --STArray版 ans4とまったく同じで少しすっきり
ans6 :: Int
ans6 = sol6 (reverse crcy) 200 --STArray版。読みやすくしただけ。ナップサック問題も解ける
ans7 :: Integer
ans7 = sol7 crcy 200 --母関数を使った解法。
ans8 :: Integer
ans8 = sol8 crcy 200 --トップダウンメモ化。sol2をそのまま機械的に書き換えただけ
-- 73682
main :: IO ()
main = print ans2

--普通の解き方。払う方、と払わない方、の両方を再帰で試す
sol1 :: (Num a, Num a1, Ord a1) => [a1] -> a1 -> a
sol1 c m = imp c m where
  imp [c] m = 1 --1pにたどり着いたので必ず1通り払える
  imp cc 0 = 1 --払いきった
  imp cc@(c:cs) m =
    case m-c>=0 of --このコインで払えるなら
      True -> imp cc (m-c) --このコインを使った払い方
              +
              imp cs m --このコインを使わず次のコインへ
      False -> imp cs m --次のコインへ

--より高速な解き方。一度に倍数をすべて処理することで組み合わせ処理を実現
sol2 :: (Enum a1, Num a, Num a1, Ord a1) => [a1] -> a1 -> a
sol2 c m = imp c m where
  imp [c] m = 1 --1円にたどり着いた
  imp c 0 = 1  --払いきった
  imp (c:cs) m = sum [imp cs (m-v) | v<-[0,c..m],m-v>=0] --重複しないように、c円の倍数をすべて除く

--haskell wikiにある芸術的なコード。全組み合わせを記述した無限リストを生成してるのに早い
btfl :: [Int] -> [[[Int]]]
btfl = foldl impl ([[]]:repeat[]) where
  impl without p =
    let (underp,upperEqualP) = splitAt p without in
    let combiList = underp ++ zipWith (++) (map (map (p:)) combiList) upperEqualP in
    combiList
-- DPを移植
sol4 :: [Int] -> Int -> Int
sol4 c n = (!n) $ runST $
           do{ a <- (newListArray (0,n) (1:repeat 0)) :: ST s (STArray s Int Int);
               forM_ c $ (\coins ->
                           forM_ [coins..n] (\i ->
                                              do{ v <- readArray a (i-coins);
                                                  u <- readArray a i;
                                                  writeArray a i (u+v);}));
               a' <- unsafeFreeze a;
               return (a'::Array Int Int);}
sol5 :: [Int] -> Int -> Int
sol5 c n = (!n) $ runSTArray $           
           do{ a <- (newListArray (0,n) (1:repeat 0)) :: ST s (STArray s Int Int);
               forM_ c $ (\coins ->
                           forM_ [coins..n] (\i ->
                                              do{ v <- readArray a (i-coins);
                                                  u <- readArray a i;
                                                  writeArray a i (u+v);}));
               return a}
sol6 :: [Int] -> Int -> Int
sol6 c n = (!n) $ runSTArray $           
           do{ a <- (newListArray (0,n) (1:repeat 0)) :: ST s (STArray s Int Int);
               sequence_ [ do{ v <- readArray a (i-coins);
                               u <- readArray a i;
                               writeArray a i (u+v);} | coins<-c,i<-[coins..n]];
               return a}
-- 母関数を使った解き方
sol7 :: (Enum a, Num a) => [Int] -> Int -> a
sol7 crcy n = ans!!n where
  coingen = map xn crcy --各コインに対応する母関数のリスト
  mulP (x:xs) b = zipWith (+) (map(*x)b) $ 0:mulP xs b --母関数の積
  paifold n xs = imp n xs (1:[0,0..]) where --母関数の無限積
    imp 0 xx acc = acc
    imp n [] acc = acc
    imp n (x:xs) acc = imp (n-1) xs (mulP acc x)
  xn 0 = 1:[0,0..] --1/(1-x^n)に相当する母関数
  xn n = cycle(1:replicate (n-1) 0)
  ans = paifold n coingen

-- sol2を、トップダウンにメモ化したもの。このmemo化関数はトップダウン汎用で使える
sol8 :: (Enum t, Num a, Num t, Ord t) => [t] -> t -> a
sol8 crcy n = memer imp (crcy,n)where  
  imp _ ([_],_) = 1 --1円にたどり着いた
  imp _ (_,0) = 1  --払いきった
  imp f ((c:cs),m) = sum [f (cs,(m-v)) | v<-[0,c..m],m-v>=0] --重複しないように、c円の倍数をすべて除く
  memer :: Ord k => ((k -> a) -> k -> a) -> k -> a
  memer f = uio $ do{mpr <- newIORef M.empty;return $ memfix mpr f} where
    uio = unsafePerformIO
    memfix mpr f = let g = f (impl mpr g) in g
    impl mpr f a =
      uio $ do{
        mp <- readIORef mpr;
        case M.lookup a mp of
          Just x -> return x
          Nothing -> writeIORef mpr newmp>> return ans where
            ans = f a
            newmp = M.insert a ans mp
        }