Some more puzzles. As these get harder, I'm skipping way too many...

Author: jmarianer

Diff for: Euler47.hs

@@ -0,0 +1,37 @@
+import Data.List
+
+-- Sieve of Eratosthenes
+mult n k = (n `mod` k) == 0
+sqrt' :: Integral a => a -> Int
+sqrt' = floor . sqrt . fromIntegral
+isPrime 1 = False
+isPrime 2 = True
+isPrime n = all not $ map (mult n) $ takeWhile (<= sqrt' n) $ primes
+primes = filter isPrime [2..]
+
+{-
+factors = factors' [] primes
+factors' acc _ 1 = acc
+factors' acc (p:ps) n
+  | n `mod` p == 0  = factors' (p:acc) (p:ps) (n `div` p)
+  | otherwise       = factors' acc ps n
+-}
+
+factors = map (factors' primes) [0..]
+factors' _ 0 = []
+factors' _ 1 = []
+factors' (p:ps) n
+  | n `mod` p == 0  = p : factors !! (n `div` p)
+  | otherwise       = factors' ps n
+
+factorCounts = map (length . nub) factors
+
+k = 4
+numsWithKFactors = map fst . filter (\(_,f) -> f == k) . zip [0..] $ factorCounts
+
+firstInteresting all@(n:ns)
+  | take k all == [n..n-1+(fromIntegral k)]  = n
+  | otherwise                    = firstInteresting ns
+
+main = print . firstInteresting $ numsWithKFactors
+--}

Diff for: Euler50.hs

@@ -0,0 +1,15 @@
+import Data.List
+
+-- Sieve of Eratosthenes
+mult n k = (n `mod` k) == 0
+sqrt' :: Integral a => a -> Int
+sqrt' = floor . sqrt . fromIntegral
+isPrime 1 = False
+isPrime 2 = True
+isPrime n = all not $ map (mult n) $ takeWhile (<= sqrt' n) $ primes
+primes = filter isPrime [2..]
+
+sumsOfPrimes = takeWhile (not . null) $ map (takeWhile (<1000000) . sumsOfPrimesWithLength) [1..]
+sumsOfPrimesWithLength k = map (\n -> sum . take k . drop n $ primes) [0..]
+
+main = print . last . filter isPrime . concat $ sumsOfPrimes

Diff for: Euler52.hs

@@ -0,0 +1,2 @@
+-- I didn't write any code to solve this. I simply remembered an interesting fact about the decimal expansion of 1/7 and guessed.
+main = print 142857

Diff for: Euler56.hs

@@ -0,0 +1,8 @@
+import Data.List
+import Control.Monad
+
+digits n
+  | n < 10    = [n]
+  | otherwise = digits (n `div` 10) ++ [n `mod` 10]
+
+main = print . maximum . map (sum . digits) . liftM2 (^) [1..100] $ [1..100]

Diff for: Euler57.hs

@@ -0,0 +1,17 @@
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ratio
+
+next :: Rational -> Rational
+next n = 1 + 1/(1 + n)
+
+expansions = iterate next 1
+
+digitCount n = elemIndex True . map (n<) . map (10^) $ [0..]
+
+longerNumerator rat = liftM2 (>) (digitCount p) $ digitCount q
+  where p = numerator rat
+        q = denominator rat
+
+main = print . length . filter (fromJust . longerNumerator) . take 1000 $ expansions

Diff for: Euler58.hs

@@ -0,0 +1,24 @@
+import Data.List
+import Data.Ratio
+
+diagDiffs = 2:2:2:2 : map (+2) diagDiffs
+diags = 1 : zipWith (+) diagDiffs diags
+
+-- Sieve of Eratosthenes
+mult n k = (n `mod` k) == 0
+sqrt' :: Integral a => a -> Int
+sqrt' = floor . sqrt . fromIntegral
+isPrime 1 = False
+isPrime 2 = True
+isPrime n = all not $ map (mult n) $ takeWhile (<= sqrt' n) $ primes
+primes = filter isPrime [2..]
+
+diagsPrime = map isPrime diags
+
+-- n is half the side of the square (rounded down)
+primesAlongDiags n = length . filter id . take (4*n+1) $ diagsPrime
+totalDiagLength n = (4*n+1)
+
+ratio n = primesAlongDiags n % totalDiagLength n
+
+main = print . (\n -> 2*n+1) . head . filter (\n -> ratio n < 1%10) $ [1..]

Diff for: Euler61.hs

@@ -0,0 +1,44 @@
+import Data.List
+
+poly n = 1 : zipWith (+) (poly n) [n-1, 2*n-3..]
+
+elemIncreasing a (x:xs)
+  | x == a     = True
+  | x > a      = False
+  | otherwise  = elemIncreasing a xs
+
+concatNum m n = m * 100 + n
+
+{- Too slow
+sextuplets = [[a `concatNum` b, b `concatNum` c, c `concatNum` d, d `concatNum` e, e `concatNum` f, f `concatNum` a]
+              | a <- [10..99], b <- [10..99], c <- [10..99], d <- [10..99], e <- [10..99], f <- [10..99]]
+
+setsRepresented xs = [n | n <- [3..8], x <- xs, x `elemIncreasing` p n]
+-}
+
+fourDigitOctagonals = takeWhile (<10000) . dropWhile (<1000) $ poly 8
+
+-- h = upper two digits
+-- ps = list of figurates
+-- out = (figurates, answer)
+--findPentagonal :: Int -> [Int] -> [(Int, Int)]
+findPentagonal h ps = concat . map find' $ ps
+  where find' p = zip (repeat p) . takeWhile (<(h+1)*100) . dropWhile (<1000) . dropWhile (<h*100) $ poly p
+
+
+first = map (\n -> ([3..7], [n])) fourDigitOctagonals
+
+addOnePentagonal foo = foo >>= next
+next :: ([Integer], [Integer]) -> [([Integer], [Integer])]
+next (ps, ans) = map something . findPentagonal ((last ans) `mod` 100) $ ps
+  where something (p, newAns) = (delete p ps, ans ++ [newAns])
+
+myLast = iterate addOnePentagonal first !! 4
+
+filtered = filter g myLast
+  where g ([p], ans) = (completeCircle ans > 1000) && (completeCircle ans) `elemIncreasing` (poly p)
+
+completeCircle ans = ((head ans) `div` 100) + ((last ans) `mod` 100 * 100)
+
+main = print (sum l + completeCircle l)
+  where l = snd . head $ filtered