« 2010年5月 | トップページ | 2010年7月 »

2010年6月

2010年6月23日 (水)

Project Euler : Problem 34

 問題はこちらをご覧ください。

 

 この問題は、「Problem 30」の応用編ですね。ということで同じ方法で解きました。
 まずは、「配列によるメモ化」です。

import Data.Array -- 階乗 factorial :: Integral a => a -> a factorial m = product [2 .. m] -- 整数をリストに変換 dexToList :: Integral a => a -> [a] dexToList n = iter n [] where iter n prd | n < 10 = n : prd | otherwise = iter (div n 10) (rem n 10 : prd) factSum :: Integer -> Integer factSum n = sum [factArray ! x | x <- dexToList n] where factArray = listArray (0, 9) [factorial x | x <- [0 .. 9]] problem034 :: Integer problem034 = sum [x | x <- [3 .. factorial 9 * 7], factSum x == x] main :: IO () main = print problem034

 次は、「重複組み合わせ」を使う方法です。

import Data.List import Data.Array -- 階乗 factorial :: Integral a => a -> a factorial m = product [2 .. m] -- 整数をリストに変換 dexToList :: Integral a => a -> [a] dexToList n = iter n [] where iter n prd | n < 10 = n : prd | otherwise = iter (div n 10) (rem n 10 : prd) -- 重複組み合わせ (repeated combination) -- ex : repComb [0..2] 2 => [[0,0],[0,1],[0,2],[1,1],[1,2],[2,2]] repComb :: [a] -> Int -> [[a]] repComb _ 0 = [[]] repComb xs n = loop (func ([], xs)) n where loop xss 1 = [xs | (xs, _) <- xss] loop xss n = loop (concatMap func xss) (n - 1) func (xs, ys) = [(xs ++ [z], zs) | zs@(z : _) <- tails ys] problem034 :: Int problem034 = sum $ concatMap ns [2 .. 7] where ns m = [n | xs <- repComb [0 .. 9] m, let n = calc xs, check xs n] fn = listArray (0, 9) [factorial x | x <- [0 .. 9]] calc ys = sum $ map (fn !) ys check ys n = (sort $ dexToList n) == ys main :: IO () main = print problem034

2010年6月22日 (火)

Project Euler : Problem 35 ~ 循環素数

 問題はこちらをご覧ください。

 

 基本的な解法は以前 Scheme や Ruby で解いたときと同じです。
 要素に「0, 2, 4, 5, 6, 8」を含む数は、最初が素数でも循環しているうちに必ず合成数(偶数または 5 の倍数)になってしまうので、即座に候補から除外し、それ以外の素数は、地道に循環させて素数になるかを調べています。

import Data.List (tails) -- 素数列 primes :: Integral a => [a] primes = map fromIntegral ([2, 3] ++ primes' :: [Int]) where primes' = 5 : sieve 1 sieve n = filter (`isPrime` primes') ns ++ sieve (n + 1000) where ns = [6 * x + y | x <- [n .. n + 999], y <- [1, 5]] isPrime m (x : xs) | x * x > m = True | rem m x == 0 = False | otherwise = isPrime m xs -- 素数判定 isPrime :: Integral a => a -> Bool isPrime n = (n > 1) && iter primes where iter (x : xs) | x * x > n = True | rem n x == 0 = False | otherwise = iter xs -- 整数 (十進法) -> リスト dexToList :: Integral a => a -> [a] dexToList n = iter n [] where iter n prd | n < 10 = n : prd | otherwise = iter (div n 10) (rem n 10 : prd) -- リスト -> 整数 (十進法) listToDex :: Integral a => [a] -> a listToDex ns = foldl calc 0 ns where calc x y = x * 10 + y -- 与えられた素数は循環素数か? isCircularPrime :: Int -> Bool isCircularPrime n = noEvenAnd5 xs && and [isPrime $ listToDex ys | ys <- yss] where noEvenAnd5 ys = and [y /= 5 && odd y | y <- ys] xs = dexToList n yss = tail $ take size $ map (take size) $ tails $ cycle xs where size = length xs -- 1000000 以下の循環素数 circularPrimes :: [Int] circularPrimes = as ++ filter isCircularPrime bs where (as, bs) = span (< 10) $ takeWhile (< 1000000) primes problem035 :: Int problem035 = length circularPrimes main :: IO () main = print problem035

 もう一つの方法として、重複順列を使って「1,3,7,9」しか含まない数を予め作っておいて、その数が循環素数になるかを調べてみました。

import Data.List -- 素数判定 -- isPrime :: Integral a => a -> Bool isPrime n = (n > 1) && iter primes' where iter (x : xs) | x * x > n = True | rem n x == 0 = False | otherwise = iter xs -- 擬似素数 primes' :: Integral a => [a] primes' = 2 : 3 : [x + y | x <- [6, 12 ..], y <- [-1, 1]] -- 整数をリストに変換 dexToList :: Integral a => a -> [a] dexToList n = iter n [] where iter n prd | n < 10 = n : prd | otherwise = iter (div n 10) (rem n 10 : prd) -- リストを整数に変換 listToDex :: Integral a => [a] -> a listToDex ns = foldl calc 0 ns where calc x y = x * 10 + y -- 重複順列 ( 辞書順 ) -- ex : repPermutation [1..3] 2 -- => [[1,1],[1,2],[1,3],[2,1],[2,2],[2,3],[3,1],[3,2],[3,3]] repPermutation :: [a] -> Int -> [[a]] repPermutation ns n = perm n [[]] where size = length ns - 1 perm 0 xs = xs perm c xs = perm (c - 1) $ concatMap f xs f xs = [xs ++ [ns !! i] | i <- [0 .. size]] -- 与えられたリストを整数に変換したものは循環素数か? isCircularPrime :: [Int] -> Bool isCircularPrime ns = and [isPrime $ listToDex xs | xs <- xss] where size = length ns xss = take size $ map (take size) $ tails $ cycle ns -- 1000000 以下の循環素数 circularPrimes :: [Int] circularPrimes = [2, 3, 5, 7] ++ [listToDex xs | xs <- xss, isCircularPrime xs] where xss = concatMap (repPermutation [1, 3, 7, 9]) [2 .. 6] problem035 :: Int problem035 = length circularPrimes main :: IO () main = print problem035
 こちらの方がかなり速く答えが出せました。

2010年6月20日 (日)

Project Euler : Problem 33

 問題はこちらをご覧ください。

 

 問題、そのままです。

import Ratio check :: Int -> Int -> Bool check n d -- n : 分子, d : 分母 | nr /= dq || dr == 0 = False | otherwise = n % d == nq % dr where (nq, nr) = divMod n 10 (dq, dr) = divMod d 10 problem033 :: Ratio Int problem033 = product xs where xs =[n % d | n <- [10 .. 98], d <- [n + 1 .. 99], check n d] main :: IO () main = print problem033

Project Euler : Problem 32

 問題はこちらをご覧ください。

 

 解き方は、以前の Ruby 版と同じです。
 まずは総当たりバージョン。

import Data.List -- Pandigital な String か? isPandigitalStr :: String -> Bool isPandigitalStr str = and $ zipWith (==) (sort str) "1234567890" findProduct :: [Int] -> [Int] -> [Int] findProduct as bs = [c | a <- as, b <- bs, let c = a * b, check a b c] where check a b c = c < 10000 && (isPandigitalStr $ concatMap show [a, b, c]) problem032 :: Int problem032 = sum $ nub $ xs ++ ys where xs = findProduct [1 .. 9] [1234 .. 9876] -- 1 桁と 4 桁の積 ys = findProduct [12 .. 98] [123 .. 987] -- 2 桁と 3 桁の積 main :: IO () main = print problem032

 

 次は「順列」を使って、数字が重複しないようにして「積」を求める方法。

import Data.List -- Pandigital な String か? isPandigitalStr :: String -> Bool isPandigitalStr str = and $ zipWith (==) (sort str) "1234567890" -- 順列 ( 辞書順 ) -- ex : permutation [1..3] 2 => [[1,2],[1,3],[2,1],[2,3],[3,1],[3,2]] permutation :: [a] -> Int -> [[a]] permutation ns n = perm n (length ns - 1) [(ns, [])] where perm 0 _ ts = [a | (_, a) <- ts] perm c n ts = perm (c - 1) (n - 1) $ concatMap (f n) ts f n (xs, ys) = [(as ++ bs, ys ++ [b]) | i <- [0 .. n], let (as, b : bs) = splitAt i xs] -- リストを整数に変換 listToDex :: Integral a => [a] -> a listToDex ns = foldl calc 0 ns where calc x y = x * 10 + y findProduct :: Int -> Int -> [Int] findProduct m n = [c | (a, b) <- makePair, let c = a * b, check a b c] where check a b c = c < 10000 && (isPandigitalStr $ concatMap show [a, b, c]) makePair = [(listToDex as, listToDex bs) | as <- perm1, bs <- perm2 as] perm1 = permutation [1 .. 9] m perm2 as = permutation ([1 .. 9] \\ as) n problem032 :: Int problem032 = sum $ nub $ (findProduct 1 4) ++ (findProduct 2 3) main :: IO () main = print problem032

2010年6月15日 (火)

Project Euler : Problem 31 ~ 両替問題

 問題はこちらをご覧ください。

 

 まずは、「計算機プログラムの構造と解釈」に載っていた再帰による方法の Haskell 版です。

{- SICP によれば * n 種類の硬貨を使う, 金額aの両替の場合の数は: (a) 最初の種類の硬貨以外を使う, 金額aの両替の場合の数, 足す (b) d を最初の硬貨の額面金額[denomination]として, n種類の硬貨を使う, 金額 a - d の両替の場合の数 * 再帰の終了条件 (c) a がちょうど 0 なら, 両替の場合の数は 1 (d) a が 0 より少なければ, 両替の場合の数は 0 (e) n が 0 なら, 両替の場合の数は 0 -} countChange :: Integral a => a -> [a] -> a countChange 0 _ = 1 countChange _ [] = 0 countChange total coins | total < 0 = 0 | otherwise = a + b where a = countChange total (tail coins) b = countChange (total - head coins) coins problem031 :: Int problem031 = countChange 200 [200, 100, 50, 20, 10, 5, 2, 1] main :: IO () main = print problem031

 

 自力ではいい方法を考えつかなかったので、ネットを探してみたところ、こちらのブログにいい方法が載っていました。
 そのままでは面白くないので、場合の数を出すのではなく、パターンをすべて洗い出すコードを作り、そのパターンの数を数えてみました。

type Money = Int coins :: [Money] coins = [200, 100, 50, 20, 10, 5, 2] -- 合計金額 => [[(コインの額面, 枚数), (コインの額面, 枚数)...] ...] -- ex : exchange 5 => [[(1,5)],[(1,3),(2,1)],[(1,1),(2,2)],[(5,1)]] exchange :: Money -> [[(Money, Int)]] exchange total = map finish $ foldl func [(total, [])] coins where finish (n, xs) = [(c, i) | (c, i) <- (1, n) : xs, i /= 0] func xs c = concatMap (count c) xs count c (n, xs) = [(n - c * i, (c, i) : xs) | i <- [0 .. div n c]] problem031 :: Int problem031 = length $ exchange 200 main :: IO () main = print problem031

2010年6月13日 (日)

Project Euler : Problem 30

 問題はこちらをご覧ください。

 

 この問題は、以前も書きましたが 7 桁未満の整数の範囲を調べれば答えが出せます。
 まずは brute force 版。

-- 整数をリストに変換 (radix : 基数) integralToList :: Integral a => a -> a -> [a] integralToList radix n = iter n [] where iter n prd | n < radix = n : prd | otherwise = iter (div n radix) (rem n radix : prd) problem030 :: Integer problem030 = sum $ filter check [2 .. limit] where limit = 6 * 9 ^ 5 check n = sum [x ^ 5 | x <- integralToList 10 n] == n main :: IO () main = print problem030
 さすがにちょっと時間がかかります。(約 0.9 秒ほど)

 

 毎回 5 乗を計算するのは無駄な気がしたので、配列によるメモ化も試してみました。

import Data.Array -- 整数をリストに変換 (radix : 基数) integralToList :: Integral a => a -> a -> [a] integralToList radix n = iter n [] where iter n prd | n < radix = n : prd | otherwise = iter (div n radix) (rem n radix : prd) problem030 :: Integer problem030 = sum $ filter check [2 .. limit] where limit = 6 * 9 ^ 5 n5 = listArray (0, 9) [x ^ 5 | x <- [0 .. 9]] check n = n == sum [n5 ! x | x <- integralToList 10 n] main :: IO () main = print problem030
 ちょっとだけ速くなって、約 0.45 秒ほどで答えが出ました。

 

 自分で考えついた方法はこれくらいだったのですが、もっといい方法は無いものかとインターネットを調べていたら、こちらのブログにおもしろい解法が載っていました。「重複組み合わせを使って使う数字を選んで、その5乗和の数字をソートしたら元に戻れば OK」という方法です。
 さっそく自分でもこの方法を使ったコードを書いてみました。

import Data.Array import Data.List -- 重複組み合わせ repComb :: [a] -> Int -> [[a]] repComb xs n = loop (func ([], xs)) n where loop xss 1 = [xs | (xs, _) <- xss] loop xss n = loop (concatMap func xss) (n - 1) func (xs, ys) = [(xs ++ [z], zs) | zs@(z : _) <- tails ys] -- 整数をリストに変換 (radix : 基数) integralToList :: Integral a => a -> a -> [a] integralToList radix n = iter n [] where iter n prd | n < radix = n : prd | otherwise = iter (div n radix) (rem n radix : prd) problem030 :: Int problem030 = sum $ concatMap ns [2 .. 6] where ns m = [n | xs <- repComb [0 .. 9] m, let n = calc xs, check xs n] n5 = listArray (0, 9) [x ^ 5 | x <- [0 .. 9]] calc ys = sum $ map (n5 !) ys check ys n = (sort $ integralToList 10 n) == ys main :: IO () main = print problem030
 このコードは調べる数が少ないので、約 0.04 秒で答えが出ました。前のコードの約 10 倍のスピードです。(ちなみにオリジナルのコードの約 1.5 倍)
 やっぱりアルゴリズムの選択って重要ですよね。

2010年6月 3日 (木)

Project Euler - Problem 29

 問題はこちらをご覧ください。

 

 今回は、何にも考えていません。ごめんなさい。

import Data.List problem029 :: Int problem029 = length $ nub $ [a ^ b | a <- [2 .. 100], b <- [2 .. 100]] main = print problem029

Project Euler : Problem 28

 問題はこちらをご覧ください。

 

 辺の数と四隅の数を並べると次のようになります。

辺の数 : 四隅の数 3 : 3, 5, 7, 9 5 : 13, 17, 21, 25 7 : 31, 37, 43, 49
 よく見ると、四隅の数は「辺の数 - 1」を公差とする等差数列であることが分かります。(ちなみに初項は「前の等差数列の最後の数 + 公差」になっています)
 この関係が分かれば、後は簡単です。
problem028 :: Integer problem028 = sum $ foldl func [1] [side - 1 | side <- [3, 5 .. 1001]] where func ns d = ns ++ [last ns + x * d | x <- [1 .. 4]] main = print problem028

2010年6月 1日 (火)

Project Euler : Problem 27 ~ 関数をデータとして扱う

 問題はこちらをご覧ください。

 

 愚直にやると、 3996001 通りの二次式について調べることになるので、ちょっと大変です。そこで a と b の範囲を絞っていきます。

 以下の文章では、 v = n² + an + b として話を進めます。

 まず、 b について考えます。
 b が偶数の場合、 n が 2 以上の偶数の場合に v も偶数になってしまうので、 b が偶数の場合は除外しても良さそうです。
 また、n = 0 の時、 v = b が素数になるためには、 b は素数でなければなりません。
 従って b は「1000 未満の奇素数」の範囲で考えれば良さそうです。

 次に、 a について考えます。
 n = 1 の時、v は素数なので v = 1 + a + b > 1 と考えられます。このことから a > -b という関係が分かります。また、 b は奇素数なので、 a が偶数だと、 v も偶数になってしまうので、 a は奇数でなければなりません。
 従って a は「-b より大きく、1000 未満の奇数」ということになります。

 これで調べる二次式は 121646 通りまで絞り込めました。

 実際のコードですが、今回は 2 パターン考えてみました。
 まずは、ほとんどの人考えたであろうアプローチで、実際に二次式の n に 0 から順に整数を当てはめていき、素数が何個できるかを調べる方法です。

import Data.List (maximumBy) import Data.Ord (comparing) divs :: Integral a => [a] divs = 2 : 3 : [x + y | x <- [6, 12 ..], y <- [-1, 1]] -- 素数判定 : 簡易版 isPrime :: Integral a => a -> Bool isPrime n = (n > 1) && iter divs where iter (x : xs) | x * x > n = True | rem n x == 0 = False | otherwise = iter xs primeCount :: Int -> Int -> Int primeCount a b = head $ dropWhile check [0 ..] where check n = isPrime (n * n + a * n + b) problem027 :: Int problem027 = a * b where (a, b, _) = maximumBy comp xs comp (_, _, x) (_, _, y) = compare x y xs = [(a, b, primeCount a b) | b <- bs, a <- [-b, -b + 2 .. 999]] bs = filter isPrime [3, 5 .. 1000] main = print problem027

 

 もう一つの方法は、せっかく Haskell を使っているのだから、関数をデータとして扱ってみようかと……。
 具体的には、関数 f を "f a b n = n * n + a * n + b" と定義しておき、「f に a と b を部分適用した関数」、 a 、 b をタプルにまとめたものを要素としたリスト "funcs" を準備します。
 そして、「f に a と b を部分適用した関数」に 0 から順に整数を適用していき、「f に a と b を部分適用した関数」が素数になったものだけを残していく、という操作を繰り替えして、最後にリストの要素が一つになった時点で a と b を取り出しました。

divs :: Integral a => [a] divs = 2 : 3 : [x + y | x <- [6, 12 ..], y <- [-1, 1]] -- 素数判定 : 簡易版 isPrime :: Integral a => a -> Bool isPrime n = (n > 1) && iter divs where iter (x : xs) | x * x > n = True | rem n x == 0 = False | otherwise = iter xs funcs :: [(Int -> Int, Int, Int)] funcs = [(f a b, a, b) | b <- bs, a <- [-b, -b + 2 .. 999]] where f a b n = n * n + a * n + b bs = filter isPrime [3, 5 .. 1000] problem027 :: Int problem027 = iter funcs [0 ..] where iter [(_, a, b)] _ = a * b iter xs (n : ns) = iter xs' ns where xs' = [x | x@(f, _, _) <- xs, isPrime (f n)] main = print problem027

 a と b の範囲を絞り込んだおかげで、コンパイルしたコードではどちらも約 0.1 秒で答えが出ます。
 自分としては、「関数」をデータとして扱う 2 つ目のコードが関数型言語の Haskell らしくて好きです。

« 2010年5月 | トップページ | 2010年7月 »

2016年7月
          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            
フォト

最近のトラックバック

無料ブログはココログ