Difference between revisions of "Euler problems/91 to 100"
Jump to navigation
Jump to search
Marypoppins (talk | contribs) |
|||
Line 1: | Line 1: | ||
+ | Do them on your own! |
||
− | == [http://projecteuler.net/index.php?section=problems&id=91 Problem 91] == |
||
− | Find the number of right angle triangles in the quadrant. |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | 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 (n-y1) yi, |
||
− | let xc = quot x1 xi |
||
− | ] |
||
− | </haskell> |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=92 Problem 92] == |
||
− | Investigating a square digits number chain with a surprising property. |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | import Data.Array |
||
− | import Data.Char |
||
− | import Data.List |
||
− | makeIncreas 1 minnum = [[a]|a<-[minnum..9]] |
||
− | makeIncreas digits minnum = [a:b|a<-[minnum ..9],b<-makeIncreas (digits-1) 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 |
||
− | </haskell> |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=93 Problem 93] == |
||
− | Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers. |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | import Data.List |
||
− | import Control.Monad |
||
− | |||
− | 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,a-b] ++ (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=n-1 |
||
− | |||
− | cmp a b = results a `compare` results b |
||
− | |||
− | 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 |
||
− | </haskell> |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=94 Problem 94] == |
||
− | Investigating almost equilateral triangles with integral sides and area. |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | 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 (n-1) x |
||
− | where |
||
− | mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1] |
||
− | --find it looks like (5-5-6) |
||
− | f556 =takeWhile (<10^9) |
||
− | [n2|i<-[1..], |
||
− | let [_,m,_]=pow i$findmin 12, |
||
− | let n=div (m-1) 6, |
||
− | let n1=4*n+1, -- sides |
||
− | let n2=3*n1+1 -- perimeter |
||
− | ] |
||
− | --find it looks like (5-6-6) |
||
− | f665 =takeWhile (<10^9) |
||
− | [n2|i<-[1..], |
||
− | let [_,m,_]=pow i$findmin 3, |
||
− | mod (m-2) 3==0, |
||
− | let n=div (m-2) 3, |
||
− | let n1=2*n, |
||
− | let n2=3*n1+2 |
||
− | ] |
||
− | problem_94=sum f556+sum f665-2 |
||
− | </haskell> |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=95 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 imperitive-style hack. In fact, no memoization |
||
− | at all is required. |
||
− | |||
− | <haskell> |
||
− | 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 |
||
− | </haskell> |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=96 Problem 96] == |
||
− | Devise an algorithm for solving Su Doku puzzles. |
||
− | |||
− | See numerous solutions on the [[Sudoku]] page. |
||
− | <haskell> |
||
− | 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 [] = [] |
||
− | loop xs = concat . map extrapolate $ xs |
||
− | |||
− | 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 (concat.map words) grids |
||
− | writeFile "p96.log"$show$ sum $ map (top3 . solve) $ rgrids |
||
− | problem_96 =main |
||
− | </haskell> |
||
− | == [http://projecteuler.net/index.php?section=problems&id=97 Problem 97] == |
||
− | Find the last ten digits of the non-Mersenne prime: 28433 × 2<sup>7830457</sup> + 1. |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | problem_97 = |
||
− | flip mod limit $ 28433 * powMod limit 2 7830457 + 1 |
||
− | where |
||
− | limit=10^10 |
||
− | </haskell> |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=98 Problem 98] == |
||
− | Investigating words, and their anagrams, which can represent square numbers. |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | import Data.List |
||
− | import Data.Maybe |
||
− | |||
− | -- 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 x y = (fst x) == (fst y) |
||
− | |||
− | -- 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 (x:_) (y:_) = compareLen y x |
||
− | |||
− | -- Is y longer than x? |
||
− | longerThan :: [a] -> [a] -> Bool |
||
− | longerThan x y = compareLen x y == LT |
||
− | |||
− | -- Compare the lengths of lists, with short-circuiting |
||
− | compareLen :: [a] -> [a] -> Ordering |
||
− | compareLen (_:xs) y = case y of (_:ys) -> compareLen xs ys |
||
− | _ -> GT |
||
− | compareLen _ [] = EQ |
||
− | compareLen _ _ = LT |
||
− | </haskell> |
||
− | (Cf. [[short-circuiting]]) |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=99 Problem 99] == |
||
− | Which base/exponent pair in the file has the greatest numerical value? |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | import Data.List |
||
− | lognum [_,a, b]=b*log a |
||
− | logfun x=lognum$((0:).read) $"["++x++"]" |
||
− | problem_99 file = |
||
− | head$map fst $ sortBy (\(_,a) (_,b) -> compare b a) $ |
||
− | zip [1..] $map logfun $lines file |
||
− | main=do |
||
− | f<-readFile "base_exp.txt" |
||
− | print$problem_99 f |
||
− | </haskell> |
||
− | |||
− | == [http://projecteuler.net/index.php?section=problems&id=100 Problem 100] == |
||
− | Finding the number of blue discs for which there is 50% chance of taking two blue. |
||
− | |||
− | Solution: |
||
− | <haskell> |
||
− | 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 |
||
− | </haskell> |
Revision as of 21:45, 29 January 2008
Do them on your own!