Personal tools

Euler problems/91 to 100

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(Euler problem 91)
m
 
(22 intermediate revisions by 7 users not shown)
Line 1: Line 1:
[[Category:Programming exercise spoilers]]
+
== [http://projecteuler.net/index.php?section=problems&id=91 Problem 91] ==
== [http://projecteuler.net/index.php?section=view&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 (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>
   
== [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: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>
 
</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,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 = 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 (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>
 
</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.
  +
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.
   
Solution which avoid visiting a number more than one time :
+
This solution avoids using unboxed arrays, which many consider to be
<haskell>
+
somewhat of an imperitive-style hack. In fact, no memoization
import Data.Array.Unboxed
+
at all is required.
import qualified Data.IntSet as S
 
import Data.List
 
   
takeUntil _ [] = []
+
<haskell>
takeUntil pred (x:xs) = x : if pred x then takeUntil pred xs else []
+
import Data.List (foldl1', group)
+
chain n s = lgo [n] $ properDivisorsSum ! n
+
where lgo xs x | x > 1000000 || S.notMember x s = (xs,[])
+
-- The longest chain of numbers is (n, k), where
| x `elem` xs = (xs,x : takeUntil (/= x) xs)
+
-- n is the smallest number in the chain, and k is the length
| otherwise = lgo (x:xs) $ properDivisorsSum ! x
+
-- of the chain. We limit the search to chains whose
+
-- smallest number is no more than m and, optionally, whose
properDivisorsSum :: UArray Int Int
+
-- largest number is no more than m'.
properDivisorsSum = accumArray (+) 1 (0,1000000)
+
chain s n n'
$ (0,-1):[(k,factor)|
+
| n' == n = s
factor<-[2..1000000 `div` 2]
+
| n' < n = []
, k<-[2*factor,2*factor+factor..1000000]
+
| (< n') 1000000 = []
]
+
| n' `elem` s = []
+
| otherwise = chain(n' : s) n $ eulerTotient n'
base = S.fromList [1..1000000]
+
findChain n = length$chain [] n $ eulerTotient n
+
longestChain =
problem_95 = fst $ until (S.null . snd) f ((0,0),base)
+
foldl1' cmpChain [(n, findChain n) | n <- [12496..15000]]
where
+
where
f (p@(n,m), s) = (p', s')
+
cmpChain p@(n, k) q@(n', k')
where
+
| (k, negate n) < (k', negate n') = q
setMin = head $ S.toAscList s
+
| otherwise = p
(explored, chn) = chain setMin s
+
problem_95 = fst $ longestChain
len = length chn
 
p' = if len > m then (minimum chn, len) else p
 
s' = foldl' (flip S.delete) s explored
 
 
</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.
   
Solution:
+
See numerous solutions on the [[Sudoku]] page.
 
<haskell>
 
<haskell>
problem_96 = undefined
+
import Data.List
</haskell>
+
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 non-Mersenne prime: 28433 × 2<sup>7830457</sup> + 1.
 
Find the last ten digits of the non-Mersenne 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.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_98 = undefined
+
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 short-circuiting
  +
compareLen :: [a] -> [a] -> Ordering
  +
compareLen (_:xs) (_:ys) = compareLen xs ys
  +
compareLen (_:_) [] = GT
  +
compareLen [] [] = EQ
  +
compareLen [] (_:_) = LT
 
</haskell>
 
</haskell>
  +
(Cf. [[short-circuiting]])
   
== [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>
 
[[Category:Tutorials]]
 
[[Category:Code]]
 

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 (n-y1) 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: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

[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,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 = 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 (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

[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 imperitive-style 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 non-Mersenne prime: 28433 × 27830457 + 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 short-circuiting
compareLen :: [a] -> [a] -> Ordering
compareLen (_:xs) (_:ys) = compareLen xs ys
compareLen (_:_)  []     = GT
compareLen []     []     = EQ
compareLen []     (_:_)  = LT

(Cf. short-circuiting)

[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