Project Euler (Problem ID 33..34)

ID33は、消去される数をcとして、特に問題無く完了。

ID34では、rangeOfDigitにより解の探索範囲を桁で絞っただけでは、計算時間が30秒を超えてしまった(正解は得られた)。
そこで、さらに枝刈りを追加(condOfNums)し、何とか計算時間を2秒に。
しかし、汚いコードになってしまった…

ID 33..34

prog033 = lowestTerm [pnums, pdenoms]
	where
		pnums = product $ map num $ curiousFracs
		pdenoms = product $ map denom $ curiousFracs
		curiousFracs = filter isCurious $ cnds
		cnds = [[c,n,d] |
			c <- [1..9],
			n <- [1..9],
			d <- [1..9],
			n < d,
			not (c == n && n == d)]

		lowestTerm [n,d] = [div n g, div d g]
			where g = gcd n d

		num [c,n,d] = n * 10 + c
		denom [c,n,d] = c * 10 + d

		isCurious [c,n,d]
			= lowestTerm (curiousFrac [c,n,d]) == lowestTerm [n,d]

		curiousFrac [c,n,d] = [num [c,n,d], denom [c,n,d]]


frac n = product [1..n]

theNum ns = foldl (\x y -> (10 * x) + y) 0 ns

sumOfFrac [] = 0
sumOfFrac (n:ns) = frac n + sumOfFrac ns

rangeOfDigit = takeWhile condOfDigit [2..]
	where
		condOfDigit d = minNum d <= maxSumOfFrac d
		minNum d = 10^(d - 1)
		maxSumOfFrac d = d * frac 9

nums nss d
	| length (head nss) == d = nss
	| mss == [] = []
	| otherwise = nums (concatMap (genNums d) mss) d
		where
			mss = filter (condOfNums d) $ nss
			genNums d ns = [ns ++ [n] | n <- [0..9]]
			condOfNums d ns = theNum (ns0s d ns) <= sumOfFrac ns + (frac 9 * rest)
				where
					ns0s d ns = ns ++ take rest [0..]
					rest = d - length ns

anss d = filter (\ns -> theNum ns == sumOfFrac ns) $ nums [[n] | n <- [1..9]] d

prog034 = sum $ map theNum $ concatMap anss rangeOfDigit

main = putStrLn $ show $ prog034