Euler problems/91 to 100

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.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 appendFile "files.log" $foldl (++) "" [show$problem_92 num ,"   ",(show num),"\n"]
              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 × 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:

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