Difference between revisions of "Euler problems/91 to 100"
m 

(5 intermediate revisions by 4 users not shown)  
Line 57:  Line 57:  
import Data.List 
import Data.List 

import Control.Monad 
import Control.Monad 

+  import Data.Ord (comparing) 

solve [] [x] = [x] 
solve [] [x] = [x] 

Line 81:  Line 82:  
otherwise=n1 
otherwise=n1 

−  cmp 
+  cmp = comparing results 
main = 
main = 

Line 220:  Line 221:  
loop :: [Grid] > [Grid] 
loop :: [Grid] > [Grid] 

−  loop [] = [] 

⚫  
⚫  
solve :: Grid > Grid 
solve :: Grid > Grid 

Line 238:  Line 238:  
filter ((/='G') . head) . 
filter ((/='G') . head) . 

lines $ contents 
lines $ contents 

−  let rgrids=map ( 
+  let rgrids=map (concatMap words) grids 
writeFile "p96.log"$show$ sum $ map (top3 . solve) $ rgrids 
writeFile "p96.log"$show$ sum $ map (top3 . solve) $ rgrids 

problem_96 =main 
problem_96 =main 

Line 260:  Line 260:  
import Data.List 
import Data.List 

import Data.Maybe 
import Data.Maybe 

+  import Data.Function (on) 

 Replace each letter of a word, or digit of a number, with 
 Replace each letter of a word, or digit of a number, with 

Line 270:  Line 271:  
 Check for equality on the first component of a tuple 
 Check for equality on the first component of a tuple 

fstEq :: Eq a => (a, b) > (a, b) > Bool 
fstEq :: Eq a => (a, b) > (a, b) > Bool 

−  fstEq 
+  fstEq = (==) `on` fst 
 The histogram of a small list 
 The histogram of a small list 

Line 312:  Line 313:  
 Sort on length of first element, from longest to shortest 
 Sort on length of first element, from longest to shortest 

longFirst :: [[a]] > [[a]] > Ordering 
longFirst :: [[a]] > [[a]] > Ordering 

−  longFirst 
+  longFirst = flip compareLen `on` fst 
 Is y longer than x? 
 Is y longer than x? 

Line 320:  Line 321:  
 Compare the lengths of lists, with shortcircuiting 
 Compare the lengths of lists, with shortcircuiting 

compareLen :: [a] > [a] > Ordering 
compareLen :: [a] > [a] > Ordering 

−  compareLen (_:xs) 
+  compareLen (_:xs) (_:ys) = compareLen xs ys 
−  +  compareLen (_:_) [] = GT 

−  compareLen 
+  compareLen [] [] = EQ 
−  compareLen 
+  compareLen [] (_:_) = LT 
</haskell> 
</haskell> 

(Cf. [[shortcircuiting]]) 
(Cf. [[shortcircuiting]]) 

Line 333:  Line 334:  
<haskell> 
<haskell> 

import Data.List 
import Data.List 

−  lognum 
+  lognum (b,e) = e * log b 
−  logfun x=lognum 
+  logfun x = lognum . read $ "(" ++ x ++ ")" 
−  problem_99 
+  problem_99 = snd . maximum . flip zip [1..] . map logfun . lines 
−  +  main = readFile "base_exp.txt" >>= print . problem_99 

−  zip [1..] $map logfun $lines file 

−  main=do 

−  f<readFile "base_exp.txt" 

−  print$problem_99 f 

</haskell> 
</haskell> 

Latest revision as of 20:08, 21 February 2010
Contents
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
]
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
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
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
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
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
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
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)
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
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