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

From HaskellWiki
Jump to: navigation, search
Line 7: Line 7:
 
where d = gcd x y
 
where d = gcd x y
   
problem_91 n = 3*n*n + 2* sum others
+
problem_91 n =
where
+
3*n*n + 2* sum others
others = do
+
where
x1 <- [1..n]
+
others =[min xc yc|
y1 <- [1..n]
+
x1 <- [1..n],
let (yi,xi) = reduce x1 y1
+
y1 <- [1..n],
let yc = quot (n-y1) yi
+
let (yi,xi) = reduce x1 y1,
let xc = quot x1 xi
+
let yc = quot (n-y1) yi,
return (min xc yc)
+
let xc = quot x1 xi
  +
]
 
</haskell>
 
</haskell>
   
Line 53: Line 53:
 
=if (num>99)
 
=if (num>99)
 
then return()
 
then return()
else do appendFile "files.log" $foldl (++) "" [show$problem_92 num ," ",(show num),"\n"]
+
else do let lst=[show$problem_92 num ," ",(show num),"\n"]
  +
appendFile "files.log" $foldl (++) "" lst
 
google (num+1)
 
google (num+1)
 
main=google 0
 
main=google 0
Line 68: Line 68:
 
x<-readFile "files.log"
 
x<-readFile "files.log"
 
print $sum$map sToInt $lines x
 
print $sum$map sToInt $lines x
 
 
</haskell>
 
</haskell>
   
Line 207: Line 206:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_97 = (28433 * 2^7830457 + 1) `mod` (10^10)
 
  +
mulMod :: Integral a => a -> a -> a -> a
  +
mulMod a b c= (b * c) `rem` a
  +
squareMod :: Integral a => a -> a -> a
  +
squareMod a b = (b * b) `rem` a
  +
pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a
  +
pow' _ _ _ 0 = 1
  +
pow' mul sq x' n' = f x' n' 1
  +
where
  +
f x n y
  +
| n == 1 = x `mul` y
  +
| r == 0 = f x2 q y
  +
| otherwise = f x2 q (x `mul` y)
  +
where
  +
(q,r) = quotRem n 2
  +
x2 = sq x
  +
powMod :: Integral a => a -> a -> a -> a
  +
powMod m = pow' (mulMod m) (squareMod m)
  +
problem_97 =
  +
flip mod limit $ 28433 * powMod limit 2 7830457 + 1
  +
where
  +
limit=10^10
 
</haskell>
 
</haskell>
   
Line 289: Line 308:
 
<haskell>
 
<haskell>
 
import Data.List
 
import Data.List
 
split :: Char -> String -> [String]
  +
split = unfoldr . split'
  +
  +
split' :: Char -> String -> Maybe (String, String)
  +
split' c l
 
| null l = Nothing
  +
| otherwise = Just (h, drop 1 t)
  +
where (h, t) = span (/=c) l
 
lognum [a, b]=b*log a
 
lognum [a, b]=b*log a
split :: String -> String -> [String]
 
 
logfun x=lognum$map ((+0).read) $split ',' x
split tok splitme = unfoldr (sp1 tok) splitme
 
  +
problem_99 file =
where sp1 _ "" = Nothing
 
 
head$map fst $ sortBy (\(_,a) (_,b) -> compare b a) $
sp1 t s = case find (t `isSuffixOf`) (inits s) of
 
  +
zip [1..] $map logfun $lines file
Nothing -> Just (s, "")
 
  +
main=do
Just p -> Just (take ((length p) - (length t)) p,
 
  +
f<-readFile "base_exp.txt"
drop (length p) s)
 
  +
print$problem_99 f
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>
   
Line 308: Line 332:
 
<haskell>
 
<haskell>
 
nextAB a b
 
nextAB a b
|a+b>10^12 =[a,b]
+
|a+b>10^12 =[a,b]
|otherwise=nextAB (3*a+2*b+2) (4*a+3*b+3)
+
|otherwise=nextAB (3*a+2*b+2) (4*a+3*b+3)
 
problem_100=(+1)$head$nextAB 14 20
 
problem_100=(+1)$head$nextAB 14 20
 
</haskell>
 
</haskell>

Revision as of 05:57, 6 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.List
import Data.Map(fromList,(!))
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])
sumMap=fromList[(k,
    fromList[(i,sum_pow ki)
    |i<-[0..1000],
    let ki=k*1000+i
    ])|
    k<-[0..400]
    ]
fastsumpow x
    |x<400000=sumMap!d!m
    |otherwise=fastsumpow(sum [pow2 !! y |y<-digits x])
    where
    (d,m)=divMod x 1000
digits n 
{-  change 123 to [3,2,1]
 -}
    |n<10=[n]
    |otherwise= y:digits x 
    where
    (x,y)=divMod n 10
groups=100000
problem_92 b=sum [fastsumpow a|a<-[1+b*groups..groups+b*groups]]
google num
  =if (num>99)
      then return()
      else do let lst=[show$problem_92 num ,"   ",(show num),"\n"]
              appendFile "files.log" $foldl (++) "" lst
              google (num+1)
main=google 0
split :: Char -> String -> [String]
split = unfoldr . split'
 
split' :: Char -> String -> Maybe (String, String)
split' c l
    | null l = Nothing
    | otherwise = Just (h, drop 1 t)
    where (h, t) = span (/=c) l
sToInt x=((+0).read) $head$split ' ' x
problem_92a=do
    x<-readFile "files.log"
    print $sum$map sToInt $lines x

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:

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.

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 × 27830457 + 1.

Solution:

mulMod :: Integral a => a -> a -> a -> a
mulMod a b c= (b * c) `rem` a
squareMod :: Integral a => a -> a -> a
squareMod a b = (b * b) `rem` a
pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a
pow' _ _ _ 0 = 1
pow' mul sq x' n' = f x' n' 1
    where
    f x n y
        | n == 1 = x `mul` y
        | r == 0 = f x2 q y
        | otherwise = f x2 q (x `mul` y)
        where
            (q,r) = quotRem n 2
            x2 = sq x
powMod :: Integral a => a -> a -> a -> a
powMod m = pow' (mulMod m) (squareMod m)
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

Problem 99

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

Solution:

import Data.List
split :: Char -> String -> [String]
split = unfoldr . split'
 
split' :: Char -> String -> Maybe (String, String)
split' c l
    | null l = Nothing
    | otherwise = Just (h, drop 1 t)
    where (h, t) = span (/=c) l
lognum [a, b]=b*log a
logfun x=lognum$map ((+0).read)  $split ',' 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