Euler problems/91 to 100
From HaskellWiki
m 

(8 intermediate revisions by 6 users not shown) 
Latest revision as of 20:08, 21 February 2010
Contents 
[edit] 1 Problem 91
Find the number of right angle triangles in the quadrant.
Solution:
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 =[min xc yc x1 < [1..n], y1 < [1..n], let (yi,xi) = reduce x1 y1, let yc = quot (ny1) yi, let xc = quot x1 xi ]
[edit] 2 Problem 92
Investigating a square digits number chain with a surprising property.
Solution:
import Data.Array import Data.Char import Data.List makeIncreas 1 minnum = [[a]a<[minnum..9]] makeIncreas digits minnum = [a:ba<[minnum ..9],b<makeIncreas (digits1) a] squares :: Array Char Int squares = array ('0','9') [ (intToDigit x,x^2)  x < [0..9] ] next :: Int > Int next = sum . map (squares !) . show factorial n = if n == 0 then 1 else n * factorial (n  1) countNum xs=ys where ys=product$map (factorial.length)$group xs yield :: Int > Int yield = until (\x > x == 89  x == 1) next problem_92= sum[div p7 $countNum a a<tail$makeIncreas 7 0, let k=sum $map (^2) a, yield k==89 ] where p7=factorial 7
[edit] 3 Problem 93
Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers.
Solution:
import Data.List import Control.Monad import Data.Ord (comparing) solve [] [x] = [x] solve ns stack = pushes ++ ops where pushes = do x < ns solve (x `delete` ns) (x:stack) ops = do guard (length stack > 1) x < opResults (stack!!0) (stack!!1) solve ns (x : drop 2 stack) opResults a b = [a*b,a+b,ab] ++ (if b /= 0 then [a / b] else []) results xs = fun 1 ys where ys = nub $ sort $ map truncate $ filter (\x > x > 0 && floor x == ceiling x) $ solve xs [] fun n (x:xs) n == x =fun (n+1) xs otherwise=n1 cmp = comparing results main = appendFile "p93.log" $ show $ maximumBy cmp $ [[a,b,c,d]  a < [1..10], b < [a+1..10], c < [b+1..10], d < [c+1..10] ] problem_93 = main
[edit] 4 Problem 94
Investigating almost equilateral triangles with integral sides and area.
Solution:
import List findmin d = d:head [[n,m]m<[1..10],n<[1..10],n*n==d*m*m+1] pow 1 x=x pow n x =mult x $pow (n1) x where mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1] find it looks like (556) f556 =takeWhile (<10^9) [n2i<[1..], let [_,m,_]=pow i$findmin 12, let n=div (m1) 6, let n1=4*n+1,  sides let n2=3*n1+1  perimeter ] find it looks like (566) f665 =takeWhile (<10^9) [n2i<[1..], let [_,m,_]=pow i$findmin 3, mod (m2) 3==0, let n=div (m2) 3, let n1=2*n, let n2=3*n1+2 ] problem_94=sum f556+sum f6652
[edit] 5 Problem 95
Find the smallest member of the longest amicable chain with no element exceeding one million. 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 imperitivestyle hack. In fact, no memoization at all is required.
import Data.List (foldl1', group)  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'. chain s n n'  n' == n = s  n' < n = []  (< n') 1000000 = []  n' `elem` s = []  otherwise = chain(n' : s) n $ eulerTotient n' findChain n = length$chain [] n $ eulerTotient n longestChain = foldl1' cmpChain [(n, findChain n)  n < [12496..15000]] where cmpChain p@(n, k) q@(n', k')  (k, negate n) < (k', negate n') = q  otherwise = p problem_95 = fst $ longestChain
[edit] 6 Problem 96
Devise an algorithm for solving Su Doku puzzles.
See numerous solutions on the Sudoku page.
import Data.List import Char top3 :: Grid > Int top3 g = read . take 3 $ (g !! 0) type Grid = [String] type Row = String type Col = String type Cell = String type Pos = Int row :: Grid > Pos > Row row [] _ = [] row g p = filter (/='0') (g !! (p `div` 9)) col :: Grid > Pos > Col col [] _ = [] col g p = filter (/='0') ((transpose g) !! (p `mod` 9)) cell :: Grid > Pos > Cell cell [] _ = [] cell g p = concat rows where r = p `div` 9 `div` 3 * 3 c = p `mod` 9 `div` 3 * 3 rows = map (take 3 . drop c) . map (g !!) $ [r, r+1, r+2] groupsOf _ [] = [] groupsOf n xs = front : groupsOf n back where (front,back) = splitAt n xs extrapolate :: Grid > [Grid] extrapolate [] = [] extrapolate g = if null zeroes then []  no more zeroes, must have solved it else map mkGrid possibilities where flat = concat g numbered = zip [0..] flat zeroes = filter ((=='0') . snd) numbered p = fst . head $ zeroes possibilities = ['1'..'9'] \\ (row g p ++ col g p ++ cell g p) (front,_:back) = splitAt p flat mkGrid new = groupsOf 9 (front ++ [new] ++ back) loop :: [Grid] > [Grid] loop = concatMap extrapolate solve :: Grid > Grid solve g = head . last . takeWhile (not . null) . iterate loop $ [g] main = do contents < readFile "sudoku.txt" let grids :: [Grid] grids = groupsOf 9 . filter ((/='G') . head) . lines $ contents let rgrids=map (concatMap words) grids writeFile "p96.log"$show$ sum $ map (top3 . solve) $ rgrids problem_96 =main
[edit] 7 Problem 97
Find the last ten digits of the nonMersenne prime: 28433 × 2^{7830457} + 1.
Solution:
problem_97 = flip mod limit $ 28433 * powMod limit 2 7830457 + 1 where limit=10^10
[edit] 8 Problem 98
Investigating words, and their anagrams, which can represent square numbers.
Solution:
import Data.List import Data.Maybe import Data.Function (on)  Replace each letter of a word, or digit of a number, with  the index of where that letter or digit first appears profile :: Ord a => [a] > [Int] profile x = map (fromJust . flip lookup (indices x)) x where indices = map head . groupBy fstEq . sort . flip zip [0..]  Check for equality on the first component of a tuple fstEq :: Eq a => (a, b) > (a, b) > Bool fstEq = (==) `on` fst  The histogram of a small list hist :: Ord a => [a] > [(a, Int)] hist = let item g = (head g, length g) in map item . group . sort  The list of anagram sets for a word list. anagrams :: Ord a => [[a]] > [[[a]]] anagrams x = map (map snd) $ filter (not . null . drop 1) $ groupBy fstEq $ sort $ zip (map hist x) x  Given two finite lists that are a permutation of one  another, return the permutation function mkPermute :: Ord a => [a] > [a] > ([b] > [b]) mkPermute x y = pairsToPermute $ concat $ zipWith zip (occurs x) (occurs y) where pairsToPermute ps = flip map (map snd $ sort ps) . (!!) occurs = map (map snd) . groupBy fstEq . sort . flip zip [0..] problem_98 :: [String] > Int problem_98 ws = read $ head [y  was < sortBy longFirst $ anagrams ws,  word anagram sets w1:t < tails was, w2 < t, let permute = mkPermute w1 w2, nas < sortBy longFirst $ anagrams $ filter ((== profile w1) . profile) $ dropWhile (flip longerThan w1) $ takeWhile (not . longerThan w1) $ map show $ map (\x > x * x) [1..],  number anagram sets x:t < tails nas, y < t, permute x == y  permute y == x ] run_problem_98 :: IO Int run_problem_98 = do words_file < readFile "words.txt" let words = read $ '[' : words_file ++ "]" return $ problem_98 words  Sort on length of first element, from longest to shortest longFirst :: [[a]] > [[a]] > Ordering longFirst = flip compareLen `on` fst  Is y longer than x? longerThan :: [a] > [a] > Bool longerThan x y = compareLen x y == LT  Compare the lengths of lists, with shortcircuiting compareLen :: [a] > [a] > Ordering compareLen (_:xs) (_:ys) = compareLen xs ys compareLen (_:_) [] = GT compareLen [] [] = EQ compareLen [] (_:_) = LT
(Cf. shortcircuiting)
[edit] 9 Problem 99
Which base/exponent pair in the file has the greatest numerical value?
Solution:
import Data.List lognum (b,e) = e * log b logfun x = lognum . read $ "(" ++ x ++ ")" problem_99 = snd . maximum . flip zip [1..] . map logfun . lines main = readFile "base_exp.txt" >>= print . problem_99
[edit] 10 Problem 100
Finding the number of blue discs for which there is 50% chance of taking two blue.
Solution:
nextAB a b a+b>10^12 =[a,b] otherwise=nextAB (3*a+2*b+2) (4*a+3*b+3) problem_100=(+1)$head$nextAB 14 20