Personal tools

Euler problems/91 to 100

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=problems&id=91 Problem 91] ==
+
Do them on your own!
Find the number of right angle triangles in the quadrant.
+
 
+
Solution:
+
<haskell>
+
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
+
        ]
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=92 Problem 92] ==
+
Investigating a square digits number chain with a surprising property.
+
 
+
Solution:
+
<haskell>
+
import Data.Array
+
import Data.Char
+
import Data.List
+
makeIncreas 1 minnum  = [[a]|a<-[minnum..9]]
+
makeIncreas digits minnum  = [a:b|a<-[minnum ..9],b<-makeIncreas (digits-1) a]
+
squares :: Array Char Int
+
squares = array ('0','9') [ (intToDigit x,x^2) | x <- [0..9] ]
+
+
next :: Int -> Int
+
next = sum . map (squares !) . show
+
factorial n = if n == 0 then 1 else n * factorial (n - 1) 
+
countNum xs=ys
+
    where
+
    ys=product$map (factorial.length)$group xs
+
yield :: Int -> Int
+
yield = until (\x -> x == 89 || x == 1) next
+
problem_92=
+
    sum[div p7 $countNum a|
+
    a<-tail$makeIncreas  7 0,
+
    let k=sum $map (^2) a,
+
    yield k==89
+
    ]
+
    where
+
    p7=factorial 7
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=93 Problem 93] ==
+
Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers.
+
 
+
Solution:
+
<haskell>
+
import Data.List
+
import Control.Monad
+
+
solve [] [x] = [x]
+
solve ns stack =
+
    pushes ++ ops
+
    where
+
    pushes = do
+
        x <- ns
+
        solve (x `delete` ns) (x:stack)
+
    ops = do
+
        guard (length stack > 1)
+
        x <- opResults (stack!!0) (stack!!1)
+
        solve ns (x : drop 2 stack)
+
+
opResults a b =
+
    [a*b,a+b,a-b] ++ (if b /= 0 then [a / b] else [])
+
 
+
results xs = fun 1 ys
+
    where
+
    ys = nub $ sort $ map truncate $
+
        filter (\x -> x > 0 && floor x == ceiling x) $ solve xs []
+
    fun n (x:xs)
+
        |n == x =fun (n+1) xs
+
        |otherwise=n-1
+
+
cmp a b = results a `compare` results b
+
+
main =
+
    appendFile "p93.log" $ show $
+
    maximumBy cmp $ [[a,b,c,d] |
+
    a <- [1..10],
+
    b <- [a+1..10],
+
    c <- [b+1..10],
+
    d <- [c+1..10]
+
    ]
+
problem_93 = main
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=94 Problem 94] ==
+
Investigating almost equilateral triangles with integral sides and area.
+
 
+
Solution:
+
<haskell>
+
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
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=95 Problem 95] ==
+
Find the smallest member of the longest amicable chain with no element exceeding one million.
+
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.
+
 
+
<haskell>
+
import Data.List (foldl1', group)
+
+
+
-- 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'.
+
chain s n n'
+
    | n' == n              = s
+
    | n' < n                = []
+
    | (< n') 1000000 = []
+
    | n' `elem` s          = []
+
    | otherwise            = chain(n' : s) n $ eulerTotient n'
+
findChain n = length$chain [] n $ eulerTotient n
+
longestChain =
+
    foldl1' cmpChain [(n, findChain n) | n <- [12496..15000]]
+
    where
+
    cmpChain p@(n, k) q@(n', k')
+
        | (k, negate n) < (k', negate n') = q
+
        | otherwise                      = p
+
problem_95 = fst $ longestChain 
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=96 Problem 96] ==
+
Devise an algorithm for solving Su Doku puzzles.
+
 
+
See numerous solutions on the [[Sudoku]] page.
+
<haskell>
+
import Data.List
+
import Char
+
+
top3 :: Grid -> Int
+
top3 g =
+
    read . take 3 $ (g !! 0)
+
 
+
type Grid = [String]
+
type Row  = String
+
type Col  = String
+
type Cell = String
+
type Pos = Int
+
+
row :: Grid -> Pos -> Row
+
row [] _ = []
+
row g  p = filter (/='0') (g !! (p `div` 9))
+
+
col :: Grid -> Pos -> Col
+
col [] _ = []
+
col g  p = filter (/='0') ((transpose g) !! (p `mod` 9))
+
+
cell :: Grid -> Pos -> Cell
+
cell [] _ = []
+
cell g  p =
+
    concat rows
+
    where
+
    r = p `div` 9 `div` 3 * 3
+
    c = p `mod` 9 `div` 3 * 3
+
    rows =
+
        map (take 3 . drop c) . map (g !!) $ [r, r+1, r+2]
+
+
groupsOf _ [] = []
+
groupsOf n xs =
+
    front : groupsOf n back
+
    where
+
    (front,back) = splitAt n xs
+
 
+
extrapolate :: Grid -> [Grid]
+
extrapolate [] = []
+
extrapolate g  =
+
    if null zeroes
+
    then [] -- no more zeroes, must have solved it
+
    else map mkGrid possibilities
+
    where
+
    flat = concat g
+
    numbered = zip [0..] flat
+
    zeroes = filter ((=='0') . snd) numbered
+
    p = fst . head $ zeroes
+
    possibilities =
+
        ['1'..'9'] \\ (row g p ++ col g p ++ cell g p)
+
    (front,_:back) = splitAt p flat
+
    mkGrid new = groupsOf 9 (front ++ [new] ++ back)
+
+
loop :: [Grid] -> [Grid]
+
loop [] = []
+
loop xs = concat . map extrapolate $ xs
+
+
solve :: Grid -> Grid
+
solve g =
+
    head .
+
    last .
+
    takeWhile (not . null) .
+
    iterate loop $ [g]
+
 
+
main = do
+
    contents <- readFile "sudoku.txt"
+
    let
+
        grids :: [Grid]
+
        grids =
+
            groupsOf 9 .
+
            filter ((/='G') . head) .
+
            lines $ contents
+
    let rgrids=map (concat.map words) grids
+
    writeFile "p96.log"$show$  sum $ map (top3 . solve) $ rgrids
+
problem_96 =main
+
</haskell>
+
== [http://projecteuler.net/index.php?section=problems&id=97 Problem 97] ==
+
Find the last ten digits of the non-Mersenne prime: 28433 × 2<sup>7830457</sup> + 1.
+
 
+
Solution:
+
<haskell>
+
problem_97 =
+
    flip mod limit $ 28433 * powMod limit 2 7830457 + 1
+
    where
+
    limit=10^10
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=98 Problem 98] ==
+
Investigating words, and their anagrams, which can represent square numbers.
+
 
+
Solution:
+
<haskell>
+
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
+
</haskell>
+
(Cf. [[short-circuiting]])
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=99 Problem 99] ==
+
Which base/exponent pair in the file has the greatest numerical value?
+
 
+
Solution:
+
<haskell>
+
import Data.List
+
lognum [_,a, b]=b*log a
+
logfun x=lognum$((0:).read)  $"["++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
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=100 Problem 100] ==
+
Finding the number of blue discs for which there is 50% chance of taking two blue.
+
 
+
Solution:
+
<haskell>
+
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
+
</haskell>
+

Revision as of 21:45, 29 January 2008

Do them on your own!