Euler problems/91 to 100
(Added link to Sudoku wiki page for Problem 96.)
(Removing category tags. See Talk:Euler_problems)
Revision as of 12:13, 30 September 2007
Find the number of right angle triangles in the quadrant.
reduce x y = (quot x d, quot y d) where d = gcd x y problem_91 n = 3*n*n + 2* sum others where others = do x1 <- [1..n] y1 <- [1..n] let (yi,xi) = reduce x1 y1 let yc = quot (n-y1) yi let xc = quot x1 xi return (min xc yc)
Investigating a square digits number chain with a surprising property.
problem_92 = undefined
Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers.
problem_93 = undefined
Investigating almost equilateral triangles with integral sides and area.
problem_94 = undefined
Find the smallest member of the longest amicable chain with no element exceeding one million.
Solution which avoid visiting a number more than one time :
import Data.Array.Unboxed import qualified Data.IntSet as S import Data.List takeUntil _  =  takeUntil pred (x:xs) = x : if pred x then takeUntil pred xs else  chain n s = lgo [n] $ properDivisorsSum ! n where lgo xs x | x > 1000000 || S.notMember x s = (xs,) | x `elem` xs = (xs,x : takeUntil (/= x) xs) | otherwise = lgo (x:xs) $ properDivisorsSum ! x properDivisorsSum :: UArray Int Int properDivisorsSum = accumArray (+) 1 (0,1000000) $ (0,-1):[(k,factor)| factor<-[2..1000000 `div` 2] , k<-[2*factor,2*factor+factor..1000000] ] base = S.fromList [1..1000000] problem_95 = fst $ until (S.null . snd) f ((0,0),base) where f (p@(n,m), s) = (p', s') where setMin = head $ S.toAscList s (explored, chn) = chain setMin s len = length chn p' = if len > m then (minimum chn, len) else p s' = foldl' (flip S.delete) s explored
Here is a more straightforward solution, without optimization. Yet it solves the problem in a few seconds when compiled with GHC 6.6.1 with the -O2 flag. I like to let the compiler do the optimization, without cluttering my code.
This solution avoids using unboxed arrays, which many consider to be somewhat of an imperitive-style hack. In fact, no memoization at all is required.
import Data.List (foldl1', group) -- The sum of all proper divisors of n. d n = product [(p * product g - 1) `div` (p - 1) | g <- group $ primeFactors n, let p = head g ] - n primeFactors = pf primes where pf ps@(p:ps') n | p * p > n = [n] | r == 0 = p : pf ps q | otherwise = pf ps' n where (q, r) = n `divMod` p primes = 2 : filter (null . tail . primeFactors) [3,5..] -- The longest chain of numbers is (n, k), where -- n is the smallest number in the chain, and k is the length -- of the chain. We limit the search to chains whose -- smallest number is no more than m and, optionally, whose -- largest number is no more than m'. longestChain m m' = (n, k) where (n, Just k) = foldl1' cmpChain [(n, findChain n) | n <- [2..m]] findChain n = f  n $ d n f s n n' | n' == n = Just $ 1 + length s | n' < n = Nothing | maybe False (< n') m' = Nothing | n' `elem` s = Nothing | otherwise = f (n' : s) n $ d n' cmpChain p@(n, k) q@(n', k') | (k, negate n) < (k', negate n') = q | otherwise = p problem_95_v2 = longestChain 1000000 (Just 1000000)
Devise an algorithm for solving Su Doku puzzles.
See numerous solutions on the Sudoku page.
Find the last ten digits of the non-Mersenne prime: 28433 × 27830457 + 1.
problem_97 = (28433 * 2^7830457 + 1) `mod` (10^10)
Investigating words, and their anagrams, which can represent square numbers.
problem_98 = undefined
Which base/exponent pair in the file has the greatest numerical value?
problem_99 = undefined
10 Problem 100
Finding the number of blue discs for which there is 50% chance of taking two blue.
problem_100 = undefined