Euler problems/91 to 100
Find the number of right angle triangles in the quadrant.
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 ]
Investigating a square digits number chain with a surprising property.
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
Using four distinct digits and the rules of arithmetic, find the longest sequence of target numbers.
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
Investigating almost equilateral triangles with integral sides and area.
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
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) 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
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 = 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
Find the last ten digits of the non-Mersenne prime: 28433 × 27830457 + 1.
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
Investigating words, and their anagrams, which can represent square numbers.
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
Which base/exponent pair in the file has the greatest numerical value?
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 f<-readFile "base_exp.txt" print$problem_99 f
Finding the number of blue discs for which there is 50% chance of taking two blue.
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