|
|
| Line 1: |
Line 1: |
| − | == [http://projecteuler.net/index.php?section=problems&id=91 Problem 91] ==
| + | Do them on your own! |
| − | 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>
| |