Personal tools

Euler problems/91 to 100

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
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>
 

Revision as of 21:45, 29 January 2008

Do them on your own!