Difference between revisions of "Euler problems/91 to 100"
Marypoppins (talk | contribs) |
CaleGibbard (talk | contribs) (rv: vandalism) |
||
Line 1: | Line 1: | ||
− | + | == [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 04:59, 30 January 2008
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 (n-y1) 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: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
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
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
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 (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
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.
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 [] = []
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
Problem 97
Find the last ten digits of the non-Mersenne prime: 28433 × 27830457 + 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
-- 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
(Cf. short-circuiting)
Problem 99
Which base/exponent pair in the file has the greatest numerical value?
Solution:
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
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