# Difference between revisions of "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 =[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]]
=if (num>99)
then return()
else do let lst=[show\$problem_92 num ,"   ",(show num),"\n"]
appendFile "files.log" \$foldl (++) "" lst
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
problem_92a=do
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:

import Data.List

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

## Problem 94

Investigating almost equilateral triangles with integral sides and area.

Solution:

import List
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 = 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)
merge xs@(x:xt) ys@(y:yt) = case compare x y of
LT -> x : (merge xt ys)
EQ -> x : (merge xt yt)
GT -> y : (merge xs yt)

diff  xs@(x:xt) ys@(y:yt) = case compare x y of
LT -> x : (diff xt ys)
EQ -> diff xt yt
GT -> diff xs yt

primes    = [2,3,5] ++ (diff [7,9..] nonprimes)
nonprimes = foldr1 f . map g \$ tail primes
where f (x:xt) ys = x : (merge xt ys)
g p = [ n*p | n <- [p,p+2..]]
fstfac x = [(head a ,length a)|a<-group\$primeFactors x]
-- The sum of all proper divisors of n.
sumDivi m =
product [div (a^(n+1)-1) (a-1)|
(a,n)<-fstfac m
]-m

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

-- 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 \$ sumDivi n'
findChain n = length\$chain [] n \$ sumDivi 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

## 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 [] = []
loop xs = concat . map extrapolate \$ xs

solve :: Grid -> Grid
solve g =
last .
takeWhile (not . null) .
iterate loop \$ [g]

main = do
let
grids :: [Grid]
grids =
groupsOf 9 .
lines \$ contents
let rgrids=map (concat.map words) grids
writeFile "p96.log"\$show\$  sum \$ map (top3 . solve) \$ rgrids
problem_96 =main

## 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
[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
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