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

== [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^7830457 + 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>