# Euler problems/91 to 100

### From HaskellWiki

(Removing category tags. See Talk:Euler_problems) |
(Added problem_98) |
||

Line 147: | Line 147: | ||

Solution: | Solution: | ||

<haskell> | <haskell> | ||

− | problem_98 = | + | import Data.List |

+ | import Data.Maybe | ||

+ | import qualified Data.Map as M | ||

+ | |||

+ | -- 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 list | ||

+ | hist :: Ord a => [a] -> [(a, Int)] | ||

+ | hist = M.toList . foldl' (\m x -> M.insertWith' (+) x 1 m) M.empty | ||

+ | |||

+ | -- 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 p = profile w1 | ||

+ | 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> | </haskell> | ||

## Revision as of 21:57, 14 November 2007

## Contents |

## 1 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)

## 2 Problem 92

Investigating a square digits number chain with a surprising property.

Solution:

problem_92 = undefined

## 3 Problem 93

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

Solution:

problem_93 = undefined

## 4 Problem 94

Investigating almost equilateral triangles with integral sides and area.

Solution:

problem_94 = undefined

## 5 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)

## 6 Problem 96

Devise an algorithm for solving Su Doku puzzles.

See numerous solutions on the Sudoku page.

## 7 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)

## 8 Problem 98

Investigating words, and their anagrams, which can represent square numbers.

Solution:

import Data.List import Data.Maybe import qualified Data.Map as M -- 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 list hist :: Ord a => [a] -> [(a, Int)] hist = M.toList . foldl' (\m x -> M.insertWith' (+) x 1 m) M.empty -- 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 p = profile w1 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

## 9 Problem 99

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

Solution:

problem_99 = undefined

## 10 Problem 100

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

Solution:

problem_100 = undefined