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

From HaskellWiki
Jump to: navigation, search
(rv: vandalism)
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 04:59, 30 January 2008

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
Retrieved from "https://wiki.haskell.org/index.php?title=Euler_problems/91_to_100&oldid=18799"