Euler problems/91 to 100
From HaskellWiki
(Added problem_98) 
m 

(18 intermediate revisions by 7 users not shown)  
Line 1:  Line 1:  
−  == [http://projecteuler.net/index.php?section=view&id=91 Problem 91] == 
+  == [http://projecteuler.net/index.php?section=problems&id=91 Problem 91] == 
Find the number of right angle triangles in the quadrant. 
Find the number of right angle triangles in the quadrant. 

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 (ny1) yi 
+  let (yi,xi) = reduce x1 y1, 
−  let xc = quot x1 xi 
+  let yc = quot (ny1) yi, 
−  return (min xc yc) 
+  let xc = quot x1 xi 
+  ] 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=92 Problem 92] == 
+  == [http://projecteuler.net/index.php?section=problems&id=92 Problem 92] == 
Investigating a square digits number chain with a surprising property. 
Investigating a square digits number chain with a surprising property. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_92 = undefined 
+  import Data.Array 
+  import Data.Char 

+  import Data.List 

+  makeIncreas 1 minnum = [[a]a<[minnum..9]] 

+  makeIncreas digits minnum = [a:ba<[minnum ..9],b<makeIncreas (digits1) 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> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=93 Problem 93] == 
+  == [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. 
Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_93 = undefined 
+  import Data.List 
+  import Control.Monad 

+  import Data.Ord (comparing) 

+  
+  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,ab] ++ (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=n1 

+  
+  cmp = comparing results 

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

−  == [http://projecteuler.net/index.php?section=view&id=94 Problem 94] == 
+  == [http://projecteuler.net/index.php?section=problems&id=94 Problem 94] == 
Investigating almost equilateral triangles with integral sides and area. 
Investigating almost equilateral triangles with integral sides and area. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_94 = undefined 
+  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 (n1) x 

+  where 

+  mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1] 

+  find it looks like (556) 

+  f556 =takeWhile (<10^9) 

+  [n2i<[1..], 

+  let [_,m,_]=pow i$findmin 12, 

+  let n=div (m1) 6, 

+  let n1=4*n+1,  sides 

+  let n2=3*n1+1  perimeter 

+  ] 

+  find it looks like (566) 

+  f665 =takeWhile (<10^9) 

+  [n2i<[1..], 

+  let [_,m,_]=pow i$findmin 3, 

+  mod (m2) 3==0, 

+  let n=div (m2) 3, 

+  let n1=2*n, 

+  let n2=3*n1+2 

+  ] 

+  problem_94=sum f556+sum f6652 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=95 Problem 95] == 
+  == [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. 
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 : 

−  <haskell> 

−  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 

−  </haskell> 

−   

Here is a more straightforward solution, without optimization. 
Here is a more straightforward solution, without optimization. 

Yet it solves the problem in a few seconds when 
Yet it solves the problem in a few seconds when 

Line 90:  Line 55:  
<haskell> 
<haskell> 

import Data.List (foldl1', group) 
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 
 The longest chain of numbers is (n, k), where 

 n is the smallest number in the chain, and k is the length 
 n is the smallest number in the chain, and k is the length 

Line 97:  Line 62:  
 smallest number is no more than m and, optionally, whose 
 smallest number is no more than m and, optionally, whose 

 largest number is no more than m'. 
 largest number is no more than m'. 

−  longestChain m m' = (n, k) 
+  chain s n n' 
−  where 
+   n' == n = s 
−  (n, Just k) = foldl1' cmpChain [(n, findChain n)  n < [2..m]] 
+   n' < n = [] 
−  findChain n = f [] n $ d n 
+   (< n') 1000000 = [] 
−  f s n n' 
+   n' `elem` s = [] 
−   n' == n = Just $ 1 + length s 
+   otherwise = chain(n' : s) n $ eulerTotient n' 
−   n' < n = Nothing 
+  findChain n = length$chain [] n $ eulerTotient n 
−   maybe False (< n') m' = Nothing 
+  longestChain = 
−   n' `elem` s = Nothing 
+  foldl1' cmpChain [(n, findChain n)  n < [12496..15000]] 
−   otherwise = f (n' : s) n $ d n' 
+  where 
cmpChain p@(n, k) q@(n', k') 
cmpChain p@(n, k) q@(n', k') 

−   (k, negate n) < (k', negate n') = q 
+   (k, negate n) < (k', negate n') = q 
−   otherwise = p 
+   otherwise = p 
−  +  problem_95 = fst $ longestChain 

−  problem_95_v2 = longestChain 1000000 (Just 1000000) 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=96 Problem 96] == 
+  == [http://projecteuler.net/index.php?section=problems&id=96 Problem 96] == 
Devise an algorithm for solving Su Doku puzzles. 
Devise an algorithm for solving Su Doku puzzles. 

See numerous solutions on the [[Sudoku]] page. 
See numerous solutions on the [[Sudoku]] page. 

+  <haskell> 

+  import Data.List 

+  import Char 

+  
+  top3 :: Grid > Int 

+  top3 g = 

+  read . take 3 $ (g !! 0) 

−  == [http://projecteuler.net/index.php?section=view&id=97 Problem 97] == 
+  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 = concatMap extrapolate 

+  
+  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 (concatMap 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 nonMersenne prime: 28433 × 2<sup>7830457</sup> + 1. 
Find the last ten digits of the nonMersenne prime: 28433 × 2<sup>7830457</sup> + 1. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_97 = (28433 * 2^7830457 + 1) `mod` (10^10) 
+  problem_97 = 
+  flip mod limit $ 28433 * powMod limit 2 7830457 + 1 

+  where 

+  limit=10^10 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=98 Problem 98] == 
+  == [http://projecteuler.net/index.php?section=problems&id=98 Problem 98] == 
Investigating words, and their anagrams, which can represent square numbers. 
Investigating words, and their anagrams, which can represent square numbers. 

Line 133:  Line 105:  
import Data.List 
import Data.List 

import Data.Maybe 
import Data.Maybe 

−  import qualified Data.Map as M 
+  import Data.Function (on) 
 Replace each letter of a word, or digit of a number, with 
 Replace each letter of a word, or digit of a number, with 

Line 144:  Line 116:  
 Check for equality on the first component of a tuple 
 Check for equality on the first component of a tuple 

fstEq :: Eq a => (a, b) > (a, b) > Bool 
fstEq :: Eq a => (a, b) > (a, b) > Bool 

−  fstEq x y = (fst x) == (fst y) 
+  fstEq = (==) `on` fst 
−   The histogram of a list 
+   The histogram of a small list 
hist :: Ord a => [a] > [(a, Int)] 
hist :: Ord a => [a] > [(a, Int)] 

−  hist = M.toList . foldl' (\m x > M.insertWith' (+) x 1 m) M.empty 
+  hist = let item g = (head g, length g) in map item . group . sort 
 The list of anagram sets for a word list. 
 The list of anagram sets for a word list. 

Line 168:  Line 140:  
[y  was < sortBy longFirst $ anagrams ws,  word anagram sets 
[y  was < sortBy longFirst $ anagrams ws,  word anagram sets 

w1:t < tails was, w2 < t, 
w1:t < tails was, w2 < t, 

−  let p = profile w1 
+  let permute = mkPermute w1 w2, 
−  permute = mkPermute w1 w2, 

nas < sortBy longFirst $ anagrams $ 
nas < sortBy longFirst $ anagrams $ 

filter ((== profile w1) . profile) $ 
filter ((== profile w1) . profile) $ 

Line 186:  Line 158:  
 Sort on length of first element, from longest to shortest 
 Sort on length of first element, from longest to shortest 

longFirst :: [[a]] > [[a]] > Ordering 
longFirst :: [[a]] > [[a]] > Ordering 

−  longFirst (x:_) (y:_) = compareLen y x 
+  longFirst = flip compareLen `on` fst 
 Is y longer than x? 
 Is y longer than x? 

Line 194:  Line 166:  
 Compare the lengths of lists, with shortcircuiting 
 Compare the lengths of lists, with shortcircuiting 

compareLen :: [a] > [a] > Ordering 
compareLen :: [a] > [a] > Ordering 

−  compareLen (_:xs) y = case y of (_:ys) > compareLen xs ys 
+  compareLen (_:xs) (_:ys) = compareLen xs ys 
−  _ > GT 
+  compareLen (_:_) [] = GT 
−  compareLen _ [] = EQ 
+  compareLen [] [] = EQ 
−  compareLen _ _ = LT 
+  compareLen [] (_:_) = LT 
</haskell> 
</haskell> 

+  (Cf. [[shortcircuiting]]) 

−  == [http://projecteuler.net/index.php?section=view&id=99 Problem 99] == 
+  == [http://projecteuler.net/index.php?section=problems&id=99 Problem 99] == 
Which base/exponent pair in the file has the greatest numerical value? 
Which base/exponent pair in the file has the greatest numerical value? 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_99 = undefined 
+  import Data.List 
+  lognum (b,e) = e * log b 

+  logfun x = lognum . read $ "(" ++ x ++ ")" 

+  problem_99 = snd . maximum . flip zip [1..] . map logfun . lines 

+  main = readFile "base_exp.txt" >>= print . problem_99 

</haskell> 
</haskell> 

−  == [http://projecteuler.net/index.php?section=view&id=100 Problem 100] == 
+  == [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. 
Finding the number of blue discs for which there is 50% chance of taking two blue. 

Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_100 = undefined 
+  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> 
</haskell> 
Latest revision as of 20:08, 21 February 2010
Contents 
[edit] 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 =[min xc yc x1 < [1..n], y1 < [1..n], let (yi,xi) = reduce x1 y1, let yc = quot (ny1) yi, let xc = quot x1 xi ]
[edit] 2 Problem 92
Investigating a square digits number chain with a surprising property.
Solution:
import Data.Array import Data.Char import Data.List makeIncreas 1 minnum = [[a]a<[minnum..9]] makeIncreas digits minnum = [a:ba<[minnum ..9],b<makeIncreas (digits1) 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
[edit] 3 Problem 93
Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers.
Solution:
import Data.List import Control.Monad import Data.Ord (comparing) 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,ab] ++ (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=n1 cmp = comparing results 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
[edit] 4 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 (n1) x where mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1] find it looks like (556) f556 =takeWhile (<10^9) [n2i<[1..], let [_,m,_]=pow i$findmin 12, let n=div (m1) 6, let n1=4*n+1,  sides let n2=3*n1+1  perimeter ] find it looks like (566) f665 =takeWhile (<10^9) [n2i<[1..], let [_,m,_]=pow i$findmin 3, mod (m2) 3==0, let n=div (m2) 3, let n1=2*n, let n2=3*n1+2 ] problem_94=sum f556+sum f6652
[edit] 5 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 imperitivestyle hack. In fact, no memoization at all is required.
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
[edit] 6 Problem 96
Devise an algorithm for solving Su Doku puzzles.
See numerous solutions on the Sudoku page.
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 = concatMap extrapolate 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 (concatMap words) grids writeFile "p96.log"$show$ sum $ map (top3 . solve) $ rgrids problem_96 =main
[edit] 7 Problem 97
Find the last ten digits of the nonMersenne prime: 28433 × 2^{7830457} + 1.
Solution:
problem_97 = flip mod limit $ 28433 * powMod limit 2 7830457 + 1 where limit=10^10
[edit] 8 Problem 98
Investigating words, and their anagrams, which can represent square numbers.
Solution:
import Data.List import Data.Maybe import Data.Function (on)  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 = (==) `on` fst  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 = flip compareLen `on` fst  Is y longer than x? longerThan :: [a] > [a] > Bool longerThan x y = compareLen x y == LT  Compare the lengths of lists, with shortcircuiting compareLen :: [a] > [a] > Ordering compareLen (_:xs) (_:ys) = compareLen xs ys compareLen (_:_) [] = GT compareLen [] [] = EQ compareLen [] (_:_) = LT
(Cf. shortcircuiting)
[edit] 9 Problem 99
Which base/exponent pair in the file has the greatest numerical value?
Solution:
import Data.List lognum (b,e) = e * log b logfun x = lognum . read $ "(" ++ x ++ ")" problem_99 = snd . maximum . flip zip [1..] . map logfun . lines main = readFile "base_exp.txt" >>= print . problem_99
[edit] 10 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