Personal tools

Euler problems/91 to 100

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(Removing category tags. See Talk:Euler_problems)
(Added problem_98)
Line 147: Line 147:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_98 = undefined
+
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 × 27830457 + 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