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

Line 243: | Line 243: | ||

Solution: |
Solution: |
||

<haskell> |
<haskell> |
||

− | problem_99 = undefined |
||

+ | import Data.List |
||

+ | lognum [a, b]=b*log a |
||

+ | split :: String -> String -> [String] |
||

+ | split tok splitme = unfoldr (sp1 tok) splitme |
||

+ | where sp1 _ "" = Nothing |
||

+ | sp1 t s = case find (t `isSuffixOf`) (inits s) of |
||

+ | Nothing -> Just (s, "") |
||

+ | Just p -> Just (take ((length p) - (length t)) p, |
||

+ | drop (length p) s) |
||

+ | fun x=lognum$map ((+0).read) $split "," x |
||

+ | problem_99 file = head$map fst $ sortBy (\(_,a) (_,b) -> compare b a) $ zip [1..] $map fun $lines file |
||

+ | |||

</haskell> |
</haskell> |
||

## Revision as of 12:09, 4 December 2007

## 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 = do
x1 <- [1..n]
y1 <- [1..n]
let (yi,xi) = reduce x1 y1
let yc = quot (n-y1) yi
let xc = quot x1 xi
return (min xc yc)
```

## Problem 92

Investigating a square digits number chain with a surprising property.

Solution:

```
import Data.List
import Data.Char
pow2=[a*a|a<-[0..9]]
sum_pow 1=0
sum_pow 89=1
sum_pow x= sum_pow(sum [pow2 !! y |y<-digits x])
digits n
{- change 123 to [3,2,1]
-}
|n<10=[n]
|otherwise= y:digits x
where
(x,y)=divMod n 10
groups=1000
problem_92 b=sum [sum_pow a|a<-[1+b*groups..groups+b*groups]]
gogo li
=if (li>9999)
then return()
else do appendFile "file.log" ((show$problem_92 li) ++ "\n")
gogo (li+1)
main=gogo 0
```

## Problem 93

Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers.

Solution:

```
problem_93 = undefined
```

## Problem 94

Investigating almost equilateral triangles with integral sides and area.

Solution:

```
problem_94 = undefined
```

## Problem 95

Find the smallest member of the longest amicable chain with no element exceeding one million.

Solution which avoid visiting a number more than one time :

```
import Data.Array.Unboxed
import qualified Data.IntSet as S
import Data.List
takeUntil _ [] = []
takeUntil pred (x:xs) = x : if pred x then takeUntil pred xs else []
chain n s = lgo [n] $ properDivisorsSum ! n
where lgo xs x | x > 1000000 || S.notMember x s = (xs,[])
| x `elem` xs = (xs,x : takeUntil (/= x) xs)
| otherwise = lgo (x:xs) $ properDivisorsSum ! x
properDivisorsSum :: UArray Int Int
properDivisorsSum = accumArray (+) 1 (0,1000000)
$ (0,-1):[(k,factor)|
factor<-[2..1000000 `div` 2]
, k<-[2*factor,2*factor+factor..1000000]
]
base = S.fromList [1..1000000]
problem_95 = fst $ until (S.null . snd) f ((0,0),base)
where
f (p@(n,m), s) = (p', s')
where
setMin = head $ S.toAscList s
(explored, chn) = chain setMin s
len = length chn
p' = if len > m then (minimum chn, len) else p
s' = foldl' (flip S.delete) s explored
```

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 sum of all proper divisors of n.
d n = product [(p * product g - 1) `div` (p - 1) |
g <- group $ primeFactors n, let p = head g
] - n
primeFactors = pf primes
where
pf ps@(p:ps') n
| p * p > n = [n]
| r == 0 = p : pf ps q
| otherwise = pf ps' n
where
(q, r) = n `divMod` p
primes = 2 : filter (null . tail . primeFactors) [3,5..]
-- 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'.
longestChain m m' = (n, k)
where
(n, Just k) = foldl1' cmpChain [(n, findChain n) | n <- [2..m]]
findChain n = f [] n $ d n
f s n n'
| n' == n = Just $ 1 + length s
| n' < n = Nothing
| maybe False (< n') m' = Nothing
| n' `elem` s = Nothing
| otherwise = f (n' : s) n $ d n'
cmpChain p@(n, k) q@(n', k')
| (k, negate n) < (k', negate n') = q
| otherwise = p
problem_95_v2 = longestChain 1000000 (Just 1000000)
```

## Problem 96

Devise an algorithm for solving Su Doku puzzles.

See numerous solutions on the Sudoku page.

## Problem 97

Find the last ten digits of the non-Mersenne prime: 28433 × 2^{7830457} + 1.

Solution:

```
problem_97 = (28433 * 2^7830457 + 1) `mod` (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
```

## Problem 99

Which base/exponent pair in the file has the greatest numerical value?

Solution:

```
import Data.List
lognum [a, b]=b*log a
split :: String -> String -> [String]
split tok splitme = unfoldr (sp1 tok) splitme
where sp1 _ "" = Nothing
sp1 t s = case find (t `isSuffixOf`) (inits s) of
Nothing -> Just (s, "")
Just p -> Just (take ((length p) - (length t)) p,
drop (length p) s)
fun x=lognum$map ((+0).read) $split "," x
problem_99 file = head$map fst $ sortBy (\(_,a) (_,b) -> compare b a) $ zip [1..] $map fun $lines file
```

## Problem 100

Finding the number of blue discs for which there is 50% chance of taking two blue.

Solution:

```
problem_100 = undefined
```