commit b81b9e6e5e7cc5fc6947bcc71764088144c1c97d Author: User <> Date: Tue Jul 30 16:51:15 2019 +0200 haskell solutions 14, 17-22, 24-47, 49-85, 89, 92, 94, 97, 120, 144, 243, 612 diff --git a/project-euler.hs b/project-euler.hs new file mode 100644 index 0000000..ad31a5e --- /dev/null +++ b/project-euler.hs @@ -0,0 +1,1118 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} +{-# LANGUAGE FlexibleInstances #-} +import Prelude +import Control.Applicative +import Control.Arrow +import Control.Monad +import Data.Array +import Data.Bits +import Data.Char +import Data.Ix (Ix) +import Data.List +import Data.Function +import Data.Function.Memoize +import Data.Maybe +import Data.Monoid +import Data.Ratio +import qualified Data.Set as S +import Math.LinearEquationSolver +import Numeric +--import Math.NumberTheory.Moduli + +binsearch xs value = binsearch' xs value 0 (high' 1) + where + high' i = if xs!!i < value then high' (i*2) else i + +-- binsearch' :: [Integer] -> Integer -> Integer -> Integer -> Integer -- list, value, low, high, return int +binsearch' xs value low high + | high < low = -1 + | xs!!mid > value = binsearch' xs value low (mid-1) + | xs!!mid < value = binsearch' xs value (mid+1) high + | otherwise = mid + where + mid = low + ((high - low) `div` 2) + +(^!) :: Num a => a -> Int -> a +(^!) x n = x^n + +squareRoot :: Integer -> Integer +squareRoot 0 = 0 +squareRoot 1 = 1 +squareRoot n = + let + twopows = iterate (^!2) 2 + (lowerRoot, lowerN) = last $ takeWhile ((n>=) . snd) $ zip (1:twopows) twopows + newtonStep x = div (x + div n x) 2 + iters = iterate newtonStep (squareRoot (div n lowerN) * lowerRoot) + isRoot r = r^!2 <= n && n < (r+1)^!2 + in head $ dropWhile (not . isRoot) iters + +isPrime :: Integer -> Bool +isPrime n = n > 1 && foldr (\p r -> p*p > n || ((n `rem` p) /= 0 && r)) True primes + +primes :: [Integer] +primes = 2 : filter isPrime [3,5..] + +primeFactors :: Integer -> [Integer] +primeFactors n | n > 1 = go n primes + where + go n ps@(p:t) + | p*p > n = [n] + | r == 0 = p : go q ps + | otherwise = go n t + where + (q,r) = quotRem n p + +integerLength = fromIntegral . length + +list :: [Integer] +list = [37107287533902102798797998220837590246510135740250,46376937677490009712648124896970078050417018260538,74324986199524741059474233309513058123726617309629,91942213363574161572522430563301811072406154908250,23067588207539346171171980310421047513778063246676,89261670696623633820136378418383684178734361726757,28112879812849979408065481931592621691275889832738,44274228917432520321923589422876796487670272189318,47451445736001306439091167216856844588711603153276,70386486105843025439939619828917593665686757934951,62176457141856560629502157223196586755079324193331,64906352462741904929101432445813822663347944758178,92575867718337217661963751590579239728245598838407,58203565325359399008402633568948830189458628227828,80181199384826282014278194139940567587151170094390,35398664372827112653829987240784473053190104293586,86515506006295864861532075273371959191420517255829,71693888707715466499115593487603532921714970056938,54370070576826684624621495650076471787294438377604,53282654108756828443191190634694037855217779295145,36123272525000296071075082563815656710885258350721,45876576172410976447339110607218265236877223636045,17423706905851860660448207621209813287860733969412,81142660418086830619328460811191061556940512689692,51934325451728388641918047049293215058642563049483,62467221648435076201727918039944693004732956340691,15732444386908125794514089057706229429197107928209,55037687525678773091862540744969844508330393682126,18336384825330154686196124348767681297534375946515,80386287592878490201521685554828717201219257766954,78182833757993103614740356856449095527097864797581,16726320100436897842553539920931837441497806860984,48403098129077791799088218795327364475675590848030,87086987551392711854517078544161852424320693150332,59959406895756536782107074926966537676326235447210,69793950679652694742597709739166693763042633987085,41052684708299085211399427365734116182760315001271,65378607361501080857009149939512557028198746004375,35829035317434717326932123578154982629742552737307,94953759765105305946966067683156574377167401875275,88902802571733229619176668713819931811048770190271,25267680276078003013678680992525463401061632866526,36270218540497705585629946580636237993140746255962,24074486908231174977792365466257246923322810917141,91430288197103288597806669760892938638285025333403,34413065578016127815921815005561868836468420090470,23053081172816430487623791969842487255036638784583,11487696932154902810424020138335124462181441773470,63783299490636259666498587618221225225512486764533,67720186971698544312419572409913959008952310058822,95548255300263520781532296796249481641953868218774,76085327132285723110424803456124867697064507995236,37774242535411291684276865538926205024910326572967,23701913275725675285653248258265463092207058596522,29798860272258331913126375147341994889534765745501,18495701454879288984856827726077713721403798879715,38298203783031473527721580348144513491373226651381,34829543829199918180278916522431027392251122869539,40957953066405232632538044100059654939159879593635,29746152185502371307642255121183693803580388584903,41698116222072977186158236678424689157993532961922,62467957194401269043877107275048102390895523597457,23189706772547915061505504953922979530901129967519,86188088225875314529584099251203829009407770775672,11306739708304724483816533873502340845647058077308,82959174767140363198008187129011875491310547126581,97623331044818386269515456334926366572897563400500,42846280183517070527831839425882145521227251250327,55121603546981200581762165212827652751691296897789,32238195734329339946437501907836945765883352399886,75506164965184775180738168837861091527357929701337,62177842752192623401942399639168044983993173312731,32924185707147349566916674687634660915035914677504,99518671430235219628894890102423325116913619626622,73267460800591547471830798392868535206946944540724,76841822524674417161514036427982273348055556214818,97142617910342598647204516893989422179826088076852,87783646182799346313767754307809363333018982642090,10848802521674670883215120185883543223812876952786,71329612474782464538636993009049310363619763878039,62184073572399794223406235393808339651327408011116,66627891981488087797941876876144230030984490851411,60661826293682836764744779239180335110989069790714,85786944089552990653640447425576083659976645795096,66024396409905389607120198219976047599490197230297,64913982680032973156037120041377903785566085089252,16730939319872750275468906903707539413042652315011,94809377245048795150954100921645863754710598436791,78639167021187492431995700641917969777599028300699,15368713711936614952811305876380278410754449733078,40789923115535562561142322423255033685442488917353,44889911501440648020369068063960672322193204149535,41503128880339536053299340368006977710650566631954,81234880673210146739058568557934581403627822703280,82616570773948327592232845941706525094512325230608,22918802058777319719839450180888072429661980811197,77158542502016545090413245809786882778948721859617,72107838435069186155435662884062257473692284509516,20849603980134001723930671666823555245252804609722,53503534226472524250874054075591789781264330331690] + +m = take 10 $ show $ foldl1 (+) list + +listToInt = foldl (\temp val -> 10*temp+val) 0 + +--main = print $ foldl1 (\a b -> if (snd b > snd a) then b else a) $ map (\n -> (n, collatz 0 n)) [1..999999] +--main = print $ totalLength [1..1000] + +--Problem 14 +collatz :: Integer -> Integer -> Integer +collatz steps 1 = steps + +collatz steps n + | even n = collatz (steps+1) (div n 2) + | otherwise = collatz (steps+1) (n*3+1) + +--Problem 17 +totalLength list = foldl1 (+) $ map (length.filterAlphabetic.n2s) list +filterAlphabetic = filter (\x -> elem x "abcdefghijklmnopqrstuvwxyz") + +n2s :: Int -> String +n2s 0 = "zero" +n2s n = n2s' $ map (\c -> read [c]) $ show n + +n2s' :: [Int] -> String +n2s' [1] = "one" +n2s' [2] = "two" +n2s' [3] = "three" +n2s' [4] = "four" +n2s' [5] = "five" +n2s' [6] = "six" +n2s' [7] = "seven" +n2s' [8] = "eight" +n2s' [9] = "nine" +n2s' [0,n] = n2s' [n] +n2s' [1,0] = "ten" +n2s' [1,1] = "eleven" +n2s' [1,2] = "twelve" +n2s' [1,3] = "thirteen" +n2s' [1,4] = "fourteen" +n2s' [1,5] = "fifteen" +n2s' [1,6] = "sixteen" +n2s' [1,7] = "seventeen" +n2s' [1,8] = "eighteen" +n2s' [1,9] = "nineteen" +n2s' [2,0] = "twenty" +n2s' [3,0] = "thirty" +n2s' [4,0] = "forty" +n2s' [5,0] = "fifty" +n2s' [6,0] = "sixty" +n2s' [7,0] = "seventy" +n2s' [8,0] = "eighty" +n2s' [9,0] = "ninety" +n2s' [x,i] = n2s' [x,0] ++ "-" ++ n2s' [i] +n2s' [c,0,0] = n2s' [c] ++ " hundred" +n2s' [c,x,i] = n2s' [c] ++ " hundred and " ++ n2s' [x,i] +n2s' [m,0,0,0] = n2s' [m] ++ " thousand" +n2s' [m,0,x,i] = n2s' [m] ++ " thousand and " ++ n2s' [x,i] +n2s' [m,c,x,i] = n2s' [m] ++ " thousand " ++ n2s' [c,x,i] +n2s' _ = "" + + + + +--Problem 18 +triangle = [[75],[95,64],[17,47,82],[18,35,87,10],[20,04,82,47,65],[19,01,23,75,03,34],[88,02,77,73,07,63,67],[99,65,04,28,06,16,70,92],[41,41,26,56,83,40,80,70,33],[41,48,72,33,47,32,37,16,94,29],[53,71,44,65,25,43,91,52,97,51,14],[70,11,33,28,77,73,17,78,39,68,17,57],[91,71,52,38,17,14,91,43,58,50,27,29,48],[63,66,04,68,89,53,67,30,73,16,69,87,40,31],[04,62,98,27,23,09,70,98,73,93,38,53,60,04,23]] +maxPath [rest] = rest +maxPath (topRow:rest) = zipWith (+) topRow (zipWith max combineRow (tail combineRow)) + where combineRow = maxPath rest + + +--Problem 19 +data Month = January | February | March | April | May | June | July | August | September | October | November | December deriving (Eq, Show) + +firstSundays = countSundays 2000 December +countSundays 1900 January = (1,0) +countSundays year month = (weekday, if (year == 1901 && month == January) then 0 else (snd previous + if (weekday == 0) then 1 else 0)) + where + weekday = (fst previous + daycount previousMonth) `mod` 7 + daycount January = 31 + daycount February = if ((year `mod` 4 == 0 && (year `mod` 100) /= 0) || (year `mod` 400) == 0) then 29 else 28 + daycount March = 31 + daycount April = 30 + daycount May = 31 + daycount June = 30 + daycount July = 31 + daycount August = 31 + daycount September = 30 + daycount October = 31 + daycount November = 30 + daycount December = 31 + previousMonth = case month of + January -> December + February -> January + March -> February + April -> March + May -> April + June -> May + July -> June + August -> July + September -> August + October -> September + November -> October + December -> November + previous = case month of + January -> countSundays (year-1) December + otherwise -> countSundays year previousMonth + +--Problem 20 +digitSum = (sum . map (read.(:[])) . show ) (product [1..100]) + + +--Problem 21 +amicableSum = (sum . filter (\n -> divisorSum !! n /= n && (divisorSum !! (divisorSum !! n)) == n)) [1..10000] +divisorSum = 0:[(sum . filter (\k -> n `mod` k == 0)) [1..max (n-1) 1] | n <- [1..]] + + +--Problem 22 +getNameScore = fmap nameScore (readFile "p022_names.txt") +nameScore contents = sum $ map (\(num,name) -> num * sum [fromEnum c - 64 | c<-name]) $ zip [1..] $ sort $ (read::(String->[String])) ("[" ++ contents ++ "]") + +--Problem 23 +{- JavaScript +divisorSum = new Array(28124); +divisorSum.fill(0); +for (var i = 1; i < divisorSum.length; i++) + for (var j = i*2; j < divisorSum.length; j += i) + divisorSum[j] += i + +abundant = []; +for (var i = 1; i < divisorSum.length; i++) + if (divisorSum[i] > i) + abundant.push(i); + +isAbundantSummable = new Array(28124); +isAbundantSummable.fill(false); +abundant.forEach(function(a) { + abundant.forEach(function(b) { + if (a+b < isAbundantSummable.length) + isAbundantSummable[a+b] = true; + }) +}); + +unsummableSum = 0; +for (var i = 1; i < isAbundantSummable.length; i++) + if (!isAbundantSummable[i]) + unsummableSum += i; + +unsummableSum +-} + +--Problem 24 +perms n 0 = [] +perms n d = perm : perms (n+product[1..d]*perm) (d-1) + where perm = last $ takeWhile (\k -> n+product[1..d]*k < 1000000) [0..9] + +takeAt n list = (head back, front ++ tail back) + where (front,back) = splitAt n list + +getPerm = concat $ map show $ getPerm' (perms 0 9) [0..9] + where + getPerm' [] [digit] = [digit] + getPerm' (pos:ps) digits = digit : getPerm' ps ds + where + (digit,ds) = takeAt pos digits + +euler24 = (read getPerm)::Int + +--Problem 25 +fib 0 = 0 +fib 1 = 1 +fib n + | even n = f1 * (f1 + 2 * f2) + | n `mod` 4 == 1 = (2 * f1 + f2) * (2 * f1 - f2) + 2 + | otherwise = (2 * f1 + f2) * (2 * f1 - f2) - 2 + where + k = n `div` 2 + f1 = fib k + f2 = fib (k-1) + +--approximation is 2 off +fib1000 a = (approx-a, fib $ approx - a) + where approx = (floor $ 1000*(logBase ((1+sqrt(5))/2) 10)) + +euler25 = fst (fib1000 2) + +--Problem 26 +euler26 = fst $ maxSnd [(,) n $ head [ len | (len,nine) <- nines, denominator (nine % n) == 1] | n <-[1..1000]] + where + nines = [(n,(10^n-1)*1000000000) | n <- [1..1000000]] + +maxSnd = foldl1 sortSnd + where sortSnd = \a b -> if snd b > snd a then b else a + +--Problem 27 +euler27 = fst $ maxSnd [(a*b, length $ takeWhile isPrime [n*n+a*n+b | n <- [0..]]) | a <- [-1000..1000], b <- [0..1000]] + +-- isPrime 1 = False +-- isPrime 2 = True +-- isPrime x = if x < 0 then False else not $ any divisible $ takeWhile notTooBig (2:[3,5..]) +-- where +-- divisible y = x `mod`y == 0 +-- notTooBig y = y*y <= x + +--Problem 28 +--average of 4 corners of loop k = 4k^2+k+1 +euler28 = 1+sum [4*(4*k*k+k+1) | k<-[1..500]] + +--Problem 29 +euler29 = length $ nub [a^b | a <-[2..100], b<-[2..100]] + +--Problem 30 +euler30 = [a*100000+b*10000+c*1000+d*100+e*10+f | a<-[0..9], b<-[0..9], c<-[0..9], d<-[0..9], e<-[0..9], f<-[0..9], a^5+b^5+c^5+d^5+e^5+f^5 == a*100000+b*10000+c*1000+d*100+e*10+f, a*100000+b*10000+c*1000+d*100+e*10+f /= 1] + +--Problem 31 +euler31 = 1+length (do + p100 <- [0,100..200] + p50 <- [p100,p100+50..200] + p20 <- [p50,p50+20..200] + p10 <- [p20,p20+10..200] + p5 <- [p10,p10+5..200] + p2 <- [p5,p5+2..200] + return () + ) + +--Problem 32 +-- abc*de=fghi, abcd*e=fghi +euler32 = sum $ nub $ do + perm <- permutations [1..9] + alen <- [3..4] + let a = concatDigits $ take alen perm + let b = concatDigits $ take (5-alen) $ drop alen perm + let c = concatDigits $ drop 5 perm + guard (a*b==c) + return c + +concatDigits :: [Integer] -> Integer +concatDigits = concat' 0 + where + concat' n (d:ds) = concat' (10*n+d) ds + concat' n [] = n + +--Problem 33 +euler33 = do + numerator <- [11..99] + guard (numerator `mod` 10 /= 0) + denominator <- [numerator+1..99] + guard (isCurious numerator denominator) + return (numerator%denominator) + +isCurious numerator denominator + | num10 == den10 && den1 /= 0 = (numerator % denominator == num1 % den1 ) + | num10 == den1 && den10 /= 0 = (numerator % denominator == num1 % den10) + | num1 == den10 && den1 /= 0 = (numerator % denominator == num10 % den1 ) + | num1 == den1 && den10 /= 0 = (numerator % denominator == num10 % den10) + | otherwise = False + where + num10 = numerator `div` 10 + num1 = numerator `mod` 10 + den10 = denominator `div` 10 + den1 = denominator `mod` 10 + +--Problem 34 +euler34 = sum $ map (concatDigits) $ filter (\ns -> length ns > 1) $ filter (\ns -> concatDigits ns == (sum $ map fac ns)) $ map (dropWhile (==0)) $ cartesianPower [0..9] 7 + where + fac 0 = 1 + fac n = n*fac (n-1) + +cartesianPower :: [a] -> Integer -> [[a]] +cartesianPower xs 0 = [[]] +cartesianPower xs n = [x:rs | x <- xs, rs <- cartesianPower xs (n-1)] + +--Problem 35 +euler35 = length [n | n <- map (dropWhile (==0)) $ tail $ cartesianPower [0..9] 6, all isPrime $ map concatDigits $ rotations n] + where + rotations :: [Integer] -> [[Integer]] + rotations xs = [take (length xs) $ drop d $ cycle xs | d <- [0..length xs - 1]] + +--Problem 36 +showBase2 num = showIntAtBase 2 intToDigit num "" +isPalindrome str = reverse str == str + +doublePalindromes = filter (\n -> isPalindrome (showBase2 n)) (filter (\n -> isPalindrome (show n)) [1,3..999999]) +euler36 = sum doublePalindromes + +--Problem 37 +euler37 = sum $ map concatDigits $ filter rtlTrunc $ ltrTruncs + where + rtlTrunc ns = all isPrime $ map concatDigits $ tail $ inits $ ns + ltrTruncs = filter (\ns -> length ns > 1) $ concatMap (ltrTruncs'.pure) [3,5,7] + ltrTruncs' ns = if isPrime (concatDigits ns) then ns:concat [ltrTruncs' (n:ns) | n<-[1,2,3,5,7,9]] else [] + +--Problem 38 +euler38 = foldl1 max $ map concatDigits [digits | x<-[1..10000], n <- [2..9 `div` (integerLength (numToDig x))], digits <- pure $ concatMap (numToDig . (x*)) [1..n], length digits == 9, null (digits \\ [1..9])] + +numToDig :: Integer -> [Integer] +numToDig x = let (tens, units) = x `divMod` 10 in (if tens > 0 then numToDig tens else []) ++ [units] + +--Problem 39 +euler39 = fst $ maxSnd [(p, length [() | a<-[1..p `div` 2], b<-[a+1..(p-a) `div` 2], c<-[p-a-b], a*a+b*b==c*c]) | p <- [1..1000]] + +isSquare n = sq * sq == n + where sq = floor $ sqrt $ (fromIntegral n::Double) + +--Problem 40 +euler40 = product $ map (digits!!) [1,10,100,1000,10000,100000,1000000] + where + digits = concatMap numToDig [0..] + +--Problem 41 +euler41 = foldl1 max [concatDigits perm |n<-[1..9], perm <- permutations [1..n], isPrime $ concatDigits perm] + +--Problem 42 +euler42 = do + f <- readFile "p042_words.txt" + return $ length $ filter isTriangle $ map wordValue $ lines f + where + wordValue word = sum $ map (\c -> fromEnum c - 64) word + isTriangle x = any (x==) $ takeWhile (x>=) [(a*(a+1)) `div` 2 | a<-[1..]] + +--Problem 43 +euler43 = sum $ map listToInt $ filter (\list -> all (0==) $ zipWith mod (zipWith3 zipzip (drop 1 list) (drop 2 list) (drop 3 list)) [2,3,5,7,11,13,17]) $ filter (\(d1:_) -> d1 /= 0) $ permutations $ [0..9] + where + zipzip a b c = 100*a+10*b+c + +--Problem 44 +euler44 = head [pd | (n,pd) <- zip [1..] pentagonal, pk <- take (3*n+1) pentagonal, isP (pd + 2*pk), isP (pd + pk)] + where + isP n = isSquare (24*n+1) && (squareRoot (24*n+1)) `mod` 6 == 5 + +pentagonal :: [Integer] +pentagonal = map (\n -> (n*(3*n-1)) `div` 2) [1..] + +--Problem 45 +euler45 = drop 2 $ do + (n,tn) <- zip triangular [0..] + let hn = binsearch hexagonal n + guard (hn /= -1) + let pn = binsearch pentagonal n + guard (pn /= -1) + return (n,tn+1,pn+1,hn+1) + +triangular = map (\n -> (n*(n+1)) `div` 2) [1..] +hexagonal = map (\n -> n*(2*n-1)) [1..] + +--Problem 46 +euler46 = [n | n<-[3,5..], not $ isPrime n, null $ filter isPrime $ takeWhile (1<) $ map (\x->n-2*x*x) [1..]] + +--Problem 47 +euler47 = head $ filter (\n -> all fourDistinctFactors [n,n+1,n+2,n+3]) [2..] + where fourDistinctFactors = (4==).length.nub.primeFactors + + +--Problem 48 +--euler48 = (`mod` 10000000000) $ sum $ map (\n -> powerModInteger n n 10000000000) [1..1000] + +--Problem 49 +euler49 = filter (not.null) $ map triplet $ groupBy (\pa pb -> null ((numToDig pa) \\ (numToDig pb)) && null ((numToDig pb) \\ numToDig pa) ) $ sortBy (compare `on` (sort.numToDig)) $ takeWhile (10000>) $ dropWhile (1000>) primes + where + triplet g = filter (\[a,b,c] -> c-b == b-a) $ combinations g 3 + +combinations xs 1 = map pure xs +combinations xs n = concatMap (\(y:ys) -> map (y:) $ combinations ys (n-1)) $ init $ tails xs + +--Problem 50 +euler50 = maxSnd $ filter (isPrime.fst) $ filter ((1000000>).fst) $ map (\xs -> (sum xs, length xs)) $ concatMap tails $ inits $ take 2000 $ takeWhile (1000000 `div` 20 >) primes + +--Problem 51 +euler51 = head [ p | p<-primes, any (\rs -> length (filter (isPrime . concatDigits) rs) >= 8) (replacements (numToDig p))] + where + replaceDigits n n' = map (\x -> if x == n then n' else x) + replacements xs = [[replaceDigits n r xs | r<-[n..9]]|n<- [0..2], n `elem` xs] + +--Problem52 +euler52 = [x | x<-[1..], sameDigits x (2*x), sameDigits x (3*x), sameDigits x (4*x), sameDigits x (5*x), sameDigits x (6*x)] + where + sameDigits a b = null ((numToDig a) \\ (numToDig b)) && null ((numToDig b) \\ numToDig a) + + +--Problem53 +euler53 = sum [countLargerThanMillion n rm | n<-[1..100], rm<-take 1 $ dropWhile ((1000000>) . nCr n) [1..n `div` 2]] + where + nCr n r = product [r+1..n] `div` product [2..n-r] + countLargerThanMillion n rm = n+1 - 2*rm + + + +--Problem54 +euler54 = fmap proc $ readFile "p054_poker.txt" + where + proc file = sum $ map (compareHands . map textToCard . words) $ lines file + compareHands cards = if handValue (take 5 cards) > handValue (drop 5 cards) then 1 else 0 + textToCard [value,suit] = (suit, maybe 0 (+2) $ elemIndex value "23456789TJQKA") + handValue hand = reverse $ sort $ concat [testStraightFlush, testKind, testFullHouse, testFlush, testStraight, testTwoPair] + where + testStraightFlush + | sameSuit && consecutive (head groupSuit) = [[10,firstValue groupSuit]] + | otherwise = [] + testKind = map (\cards -> [kindRank $ length cards, snd $ head cards]) $ groupValue + testFullHouse + | any triplet groupValue && any pair groupValue = [[7, firstValue $ filter triplet groupValue, firstValue $ filter pair groupValue]] + | otherwise = [] + testFlush + | sameSuit = [[6]] + | otherwise = [] + testStraight + | consecutive $ concat groupValue = [[5, firstValue groupValue]] + | otherwise = [] + testTwoPair + | length pairs == 2 = [3 : map (snd.head) (reverse pairs)] + | otherwise = [] + kindRank 4 = 8 + kindRank 3 = 4 + kindRank n = n + sameSuit = length (groupSuit) == 1 + groupSuit = map (sortBy (compare `on` snd)) $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) hand + groupValue = (map (sortBy (compare `on` fst)) $ groupBy ((==) `on` snd) $ sortBy (compare `on` snd) hand) :: [[(Char,Int)]] + consecutive = (\vals -> all (1==) $ zipWith (-) (drop 1 vals) vals) . map snd + pairs = filter ((2==).length) groupValue + firstValue = snd . head . head + triplet = hasLength 3 + pair = hasLength 2 + +hasLength n xs = length xs == n +--Problem55 +euler55 = filter (not . any (isPalindrome . numToDig) . take 51 . tail . iterate addReverse) [1..10000-1] + where + addReverse x = x + (concatDigits.reverse.numToDig) x + + +--Problem56 +euler56 = maximum $ map (sum . numToDig) $ [a^b | a<-[2..100-1], b<-[2..100-1]] + + +--Problem57 +euler57 = length $ filter (\r -> digits (numerator r) > digits (denominator r)) $ map (\n -> 1+1/n) $ take 1000 $ iterate (\n -> 2+(1/n)) (2%1) + where digits = length . numToDig + + +--Problem58 +euler58 = snd $ head $ dropWhile (\(r,l) -> r >= 1%10) $ tail $ map (fmap sideLength) $ snd $ mapAccumL accPrimeCount 0 spiralnumbers + where + spiralnumbers = (1,[]) : spiralnumbers' 2 + spiralnumbers' n = (n,[4*n^2 - 6*n + 3, 4*(n-1)^2 + 1, 4*n^2 - 10*n + 7]) : spiralnumbers' (n+1) + accPrimeCount primeCount (level,ns) = let primeCount' = primeCount + integerLength (filter isPrime ns) in (primeCount', (primeCount' % (level*4-3), level)) + sideLength level = 2*level-1 + + +--Problem59 +euler59 = fmap proc (readFile "p059_cipher.txt") + where + proc f = (sum . map fromEnum . head) [combine c0 c1 c2 | c0<-(dec 0 f), c1<-(dec 1 f), c2<-(dec 2 f)] + combine (a:as) (b:bs) (c:cs) = a:b:c:combine as bs cs + combine (a:as) (b:bs) [] = a:b:combine as bs [] + combine (a:as) [] [] = a:as + dec n f = decode (map (!!n) $ takeWhile ((n<).length) (charcodes f)) + charcodes f = (map (map read . words) (lines f))::[[Int]] + decode cs = [text | c<-['a'..'z'], text<-pure $ map (toEnum . xor (fromEnum c)) cs, all isPrint text, not $ any (`elem`"$`%") text] + + +--Problem60 +euler60 = [(s,primeSet) |s<-[790..], primeSet<-[[p1,p2,p3,p4]| + p1<-takeWhile (s`div`5>) primes, + p2<-filter (concatable [p1]) $ takeWhile ((s-p1)`div`4>) $ dropWhile (p1>=) primes, + p3<-filter (concatable [p1,p2]) $ takeWhile ((s-p1-p2)`div`3>) $ dropWhile (p2>=) primes, + p4<-filter (concatable [p1,p2,p3]) $ takeWhile ((s-p1-p2-p3)`div`2>) $ dropWhile (p3>=) primes, + p5<-pure (s-p1-p2-p3-p4), + isPrime p5, concatable [p1,p2,p3,p4] p5]] + where + concatable xs a = all (isPrime . concatNumber a) xs && all (isPrime . flip concatNumber a) xs + concatNumber a b = a*10^(length (show b))+b + + +--Problem61 +euler61 = filter isCyclic $ [perm | p3 <- trans triangular, p4 <- trans [n*n|n<-[1..]], p5 <- trans pentagonal, p6 <- trans [n*(2*n-1)|n<-[1..]], p7 <- trans [(n*(5*n-3)) `div` 2|n<-[1..]], p8 <- trans [n*(3*n-2)|n<-[1..]], perm <- map (p8:) $ permutations [p3,p4,p5,p6,p7]] + where + trans = (map splitNumber . fourDigs) + isCyclic xs = and $ zipWith (\(_,r) (l,_) -> r==l) xs (tail $ cycle xs) + splitNumber = (`divMod` 100) + fourDigs = takeWhile (10000>) . dropWhile (1000>=) + +euler61' = filter (isSquare . closingNumber) $ filter isSemiCyclic $ [perm | p3 <- trans triangular, p5 <- trans pentagonal, p6 <- trans [n*(2*n-1)|n<-[1..]], p7 <- trans [(n*(5*n-3)) `div` 2|n<-[1..]], p8 <- trans [n*(3*n-2)|n<-[1..]], perm <- permutations [p3,p5,p6,p7,p8]] + where + closingNumber ((l,_):xs) = 100*(snd $ last xs) + l + trans = (map splitNumber . fourDigs) + isSemiCyclic xs = and $ zipWith (\(_,r) (l,_) -> r==l) xs (tail xs) + splitNumber = (`divMod` 100) + fourDigs = takeWhile (10000>) . dropWhile (1000>=) + + +--Problem62 +euler62 = fst . head . head . head . dropWhile null . map (filter ((5==) . length) . groupBy ((==) `on` snd) . sortBy (compare `on` snd)) $ groupBy((==) `on` (length.snd)) [(x^3,sort (numToDig (x^3)))|x<-[345..]] + +isCube n = ((n==) . head . dropWhile (n>)) [x^3 | x<-[1..]] + +--Problem63 +euler63 = length [(x,p) | p<-takeWhile (\p -> 9^p >= 10^(p-1)) [1..], x<-[1..9], 10^(p-1) <= x^p] + + +--Problem64 +euler64 = length $ filter oddPeriod [iterate (expand root) $ (floorSqrt root, -floorSqrt root, 1) | root<-[2..10000], not (isSquare root)] + where + oddPeriod (_:x:xs) = (odd . (1+) . length . takeWhile (x/=)) xs + floorSqrt = floor . sqrt . fromIntegral + expand root (_,addition,multiplier) = (units,addition',reducedDenom) + where + addition' = remainder-floorSqrt root + (units,remainder) = (floorSqrt root - addition) `divMod` reducedDenom + reducedDenom = (root-addition*addition) `div` multiplier + +continuedFractionRoot n = continuedFraction ((floor . sqrt . fromIntegral) n) n + +continuedFraction n nsquared = n : expand (-n) 1 + where + expand addition _ | addition*addition == nsquared = [] + expand addition multiplier = units : expand addition' reducedDenom + where + addition' = remainder-n + (units,remainder) = (n - addition) `divMod` reducedDenom + reducedDenom = (nsquared-addition*addition) `div` multiplier + +repeatingContinuedFraction n nsquared = (n, (map (\(a,_,_)->a) . getPeriod . expand) (n, -n, 1)) + where + getPeriod (x:xs) = x : (takeWhile (x/=)) xs + expand (_,addition,multiplier) = if reducedDenom == 0 then [] else (units,addition',reducedDenom) : expand (units,addition',reducedDenom) + where + addition' = remainder-n + (units,remainder) = (n - addition) `divMod` reducedDenom + reducedDenom = (nsquared-addition*addition) `div` multiplier + +contFracSqrt n = repeatingContinuedFraction ((floor . sqrt . fromIntegral) n) n + + +--Problem65 +euler65 = (sum . numToDig . numerator) approximation + where + approximation = 2 + 1 / (foldr1 (\a c -> a+1/c) . take 99) eFactors + eFactors = concatMap (\x -> map toRational [1,2*x,1]) [1..] + + +--Problem66 +-- euler66 d = x +-- where +-- a = (fst . contFracSqrt) d : (cycle . snd . contFracSqrt) d +-- r = (length . snd . contFracSqrt) d +-- p 0 = a!!0 +-- p 1 = a!!1 * a!!0 + 1 +-- p n = a!!n * p (n-1) + p (n-2) +-- q 0 = 1 +-- q 1 = a!!1 +-- q n = a!!n * q (n-1) + q (n-2) +-- x = head [(d, p n, q n, n)| n<-[1..], (p n)^2 -d*(q n)^2 == 1] + +euler66' = (fst3 . maximumBy (compare `on` snd3) . map pell . filter (not.isSquare)) [1..1000] + where + + pell d = ((\(n,x,y,_)->(n,x,y)) . head . dropWhile (\(_,_,_,k) -> k /= 1) . iterate solve) (d, a0, 1, a0^2-d) + where a0 = 1+squareRoot d + solve (d,a,b,k) = (d,a',b',k') + where + scale el = el `div` (abs k) + a' = scale (a*m + d*b) + b' = scale (a+b*m) + k' = (m^2-d) `div` k + m = minimumBy (compare `on` (\m -> abs (m^2-d))) [m | m<-[squareRoot d - abs k..squareRoot d + abs k], (a+b*m) `mod` k == 0] + + +fst3 (a,_,_) = a +snd3 (_,b,_) = b + +--Problem67 +euler67 = fmap proc $ readFile "p067_triangle.txt" + where + proc = solve . map (map read . words) . lines + solve (lastrow:[]) = lastrow + solve (row:rows) = zipWith (+) (zipWith max solution (tail solution)) row + where solution = solve rows + + +--Problem68 +euler68 = (concat . map show . maximum) [[a,f,g,b,g,h,c,h,i,d,i,j,e,j,f]| [a,b,c,d,e,f,g,h,i,j]<-permutations [1..10], all (a<) [b,c,d,e], all (a+f+g ==) [b+g+h,c+h+i,d+i+j,e+j+f], 10 `elem` [a,b,c,d,e] ] + + +--Problem69 +euler69 = solve primes 1 + where + solve (p:ps) n = if largestMultiple > p then solve ps (n*p) else n*largestMultiple + where largestMultiple = 1000000`div`n + + +--Problem70 +euler70 = solve 2 0 (1000%1) + where + solve 10000000 bestN bestRatio = [(bestN,bestRatio)] + solve n bestN bestRatio + | ratio < bestRatio && isAnagram (show n) (show (totient n)) = (n,ratio) : solve (n+1) n ratio + | otherwise = solve (n+1) bestN bestRatio + where ratio = n % totient n + + + +isAnagram xs ys = length xs == length ys && null (xs \\ ys) + +totient n = (n `div` product factors) * product (map (subtract 1) factors) + where factors = distinctFactorize n + +--distinctFactorize n = snd $ foldl' (\(last,list) f -> if f==last then (last,list) else (f,list++[f])) (1,[]) (factorize n) +distinctFactorize n = factorize' primes n + where + factorize' _ 1 = [] + factorize' (p:ps) n + | p*p > n = [n] + | factorOut p n /= n = p : factorize' ps (factorOut p n) + | otherwise = factorize' ps n + factorOut = fix (\r p n -> if n `mod` p == 0 then r p (n `div` p) else n) + +factorize n = factorize' n (map fromInteger primes :: [Integer]) + where + factorize' 1 _ = [] + factorize' n pps@(p:ps) + | p*p > n = [n] + | n `mod` p /= 0 = factorize' n ps + | otherwise = p : factorize' (n `div` p) pps + -- factorize' n ps = head ps' : factorize' (n`div` (head ps')) ps' + -- where ps' = dropWhile (\p->n `mod` p /= 0) ps + +factorCount = fix (\r p n -> if n `mod` p == 0 then 1 + r p (n `div` p) else 0) +factorPower = fix (\r p n -> if n `mod` p == 0 then p * r p (n `div` p) else 1) + + +--Problem 71 +euler71 = maximum [floor(d*3%7) % d|d<-[1..1000000],d `mod` 7 /= 0] + + +--Problem 72 +euler72 = sum (map totient [2..1000000]) + + +--Problem 73 +euler73 = sum [length [n%d | n<-[d`div`3..d`div`2], gcd n d == 1, 3*n > d, 2*n < d]|d<-[2..12000]] + + +--Problem 74 +euler74 = error "Unsolved" + + +--Problem 75 +euler75 = error "See a059.cpp" + + +euclidSingularTriangles lmax = 12 : [l |l<-[14,16..lmax], lengthEquals 1 (tryLength l)] + where + tryLength l = [() | m<-[(squareRoot l) `div` 2..squareRoot (l `div` 2) - 1], l `mod` (2*m) == 0, let n = (l `div` (2*m))-m, n < m] + +lengthEquals 0 [] = True +lengthEquals 0 (_:_) = False +lengthEquals n [] = False +lengthEquals n (_:xs) = lengthEquals (n-1) xs + + +--Problem 76 +euler76 n = euler78' n - 1 -- solve n (n-1) + where + solve total maxn + | total == 1 || maxn == 1 = 1 + | total < maxn = solve total (maxn-1) + | total == maxn = solve total (maxn-1) + 1 + | total > maxn = solve total (maxn-1) + solve (total-maxn) maxn + + +--Problem 77 +euler77 = error "Unsolved" + + +--Problem 78 +euler78 = memo --filter (\n -> memo (n,n) `mod` divisor == 0) [1..] + where + memo = memoize step + step :: (Integer,Integer) -> Integer + step (total,maxn) + | total == 1 || maxn == 1 = 1 + | total < maxn = memo (total,maxn-1) + | total == maxn = memo (total,maxn-1) + 1 + | total > maxn = memo (total,maxn-1) + memo (total-maxn,maxn) + +euler78' = a' + where + a' = memoize a + a :: Integer -> Integer + a 0 = 1 + a 1 = 1 + a 2 = 2 + a n = sum [plusmin k * a' (n - gpn k) | k<-takeWhile ((n>=) . gpn) [1..]] + plusmin k = if (k-1) `mod` 4 < 2 then 1 else -1 + gpn n = (((n+1)`div`2) * ((3*n+2)`div`2))`div` 2 + +--Problem 79 +euler79 = fmap (solve . lines) $ readFile "p079_keylog.txt" + where + solve xs = (compose . sortBy (compare `on` (length.snd)) . map (liftM2 (,) (fst.head) (map snd)) . groupBy ((==)`on`fst) . sort . nub) $ xs >>= (\[a,b,c]->[(a,b),(a,c),(b,c)]) + compose xs = foldl (\acc (n,_) -> n:acc) (snd (head xs)) xs + + +--Problem 80 +euler80 = sum [(sum . take 100 . rootOf 0) n | n<-[1..100], (squareRoot n)^2 /= n] + where + rootOf p 0 = [] + rootOf p c = x : rootOf (10*p+x) (100*(c-y x)) + where + x = last $ takeWhile (\x->y x <= c) [0..] + y x = x*(20*p+x) + + +--Problem 81 +euler81 = fmap (head . solve . map (\l -> read ("["++l++"]")) . lines) $ readFile "p081_matrix.txt" + where + -- solve' = memoize solve + -- solve :: [[Integer]]->Integer + -- solve [] = 0 + -- solve ([]:_) = 0 + -- solve mat@((cell:cs):rs) = cell + min (solve' rs) (solve' (map tail mat)) + solve (last:[]) = init $ scanr (+) 0 last + solve (r:rs) = init $ scanr (\(thiscell,downcell) rightcell -> thiscell+min downcell rightcell) (last nextrow) (zip r nextrow) + where nextrow = solve rs + + +--Problem 82 +euler82 = fmap (head . solve . map (\l -> (read::String->[Integer]) ("["++l++"]")) . lines) $ readFile "p082_matrix.txt" + where solve = const [0] + + +--Problem 83 +euler83 = fmap (solve . readMatrix) $ readFile "p083_matrix.txt" + where + solve :: Array a Int -> Int + solve cost = solveStep zeroMatrix [(cost!(1,1),(1,1))] + where + solveStep pathCost ((c,(80,80)):_) = c + solveStep pathCost ((c,(i,j)):rest) = + zeroMatrix = listArray ((1,1),(80,80)) (repeat Nothing) + + +readMatrix :: Read a => [Char] -> Array (Int,Int) a +readMatrix = listArray ((1,1),(80,80)) . concatMap (\r -> read ("["++r++"]")) . lines + +dijkstra :: (Functor f, Num w) => f v -> (v -> f (v,w)) -> v -> f (v,w) +dijkstra vertices edgeMap start = + step visited [] = visited + step visited (current:rest) = + +--Problem 84 +euler84 = do + Just [_,_,_,tripleDoubles] <- solveDTMC $ fmap2 (%4) [[3,1,0,0],[3,0,1,0],[3,0,0,1],[3,1,0,0]] + Just result <- solveDTMC $ map (elems . jailChance tripleDoubles . nextTileProbs) [GO ..] + let mostVisited = (take 3 . sortOn (negate . snd) . assocs . arrayFrom) result + return (map (fromEnum . fst) mostVisited) + where + jailChance tripleDoubles = flip (accum (+)) [(JAIL,tripleDoubles)] . fmap (*(1%1-tripleDoubles)) + nextTileProbs tile = fmap (*(1%16)) $ accum (+) (arrayFrom (repeat (0%1))) $ do + d1 <- [1..4] + d2 <- [1..4] + actionsFrom (enumAdd (d1+d2) tile) + arrayFrom = listArray (minBound :: MonopolyTile, maxBound) + actionsFrom tile + | tile `elem` [CC1,CC2,CC3] = (tile,14%16) : map (\t->(t,1%16)) [GO,JAIL] + | tile `elem` [CH1,CH2,CH3] = (tile,6%16) : (nextR tile,2%16) : map (\t->(t,1%16)) [GO,JAIL,C1,E3,H2,R1, nextU tile, enumAdd (-3) tile] + | tile == G2J = [(JAIL,1%1)] + | otherwise = [(tile,1%1)] + where + nextR CH1 = R2 + nextR CH2 = R3 + nextR CH3 = R1 + nextU CH1 = U1 + nextU CH2 = U2 + nextU CH3 = U1 + + +data MonopolyTile = GO | A1 | CC1 | A2 | T1 | R1 | B1 | CH1 | B2 | B3 | JAIL | C1 | U1 | C2 | C3 | R2 | D1 | CC2 | D2 | D3 | FP | E1 | CH2 | E2 | E3 | R3 | F1 | F2 | U2 | F3 | G2J | G1 | G2 | CC3 | G3 | R4 | CH3 | H1 | T2 | H2 deriving (Enum, Ord, Ix, Bounded, Show, Eq) + +arrayZipWith f a1 a2 = accum f a1 (assocs a2) +arrayApply :: Ix i => Array i e -> [(i, e->e)] -> Array i e +arrayApply = accum (flip ($)) + +instance Num a => Num [a] where + (+) = zipWith (+) + (*) = zipWith (*) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + negate = fmap negate + +identity 0 = [] +identity n = identity' `seq` (one : replicate (n-1) zero) : map (zero:) identity' + where + identity' = identity (n-1) + zero = fromInteger 0 + one = fromInteger 1 + +solveDTMC probs = let + size = length (head probs) + ones = replicate size (fromInteger 1) + id' = identity size + eq = head id' ++ [0] + in + solveRationalLinearEqs Z3 (ones : transpose probs - id') eq + +fmap2 :: (Functor f1, Functor f2) => (a->b)->f1(f2 a) -> f1(f2 b) +fmap2 = fmap . fmap +fmap3 :: (Functor f1, Functor f2, Functor f3) => (a->b)->f1(f2 (f3 a)) -> f1(f2 (f3 b)) +fmap3 = fmap . fmap . fmap +fmap4 :: (Functor f1, Functor f2, Functor f3, Functor f4) => (a->b)->f1(f2 (f3(f4 a))) -> f1(f2 (f3(f4 b))) +fmap4 = fmap . fmap . fmap . fmap + +enumAdd :: (Enum a, Bounded a) => Int -> a -> a +enumAdd n e = toEnum (toRange (fromEnum (minBound `asTypeOf` e)) (fromEnum (maxBound `asTypeOf` e)) (n + fromEnum e)) + where toRange lower upper n = (n+upper+1) `mod` (upper+1-lower) + lower + +--Problem 85 +euler85 = (\(w,h,_)->w*h) $ head $ sortOn (\(_,_,x) -> abs(x-2000000)) $ do + (w,n)<-zip [1..] $ takeWhile (1414>=) triangular + let desired = 2000000`div`n + let (m1,m2) = span ((desired>).snd) $ zip [1..] triangular + (h,m)<-[last m1,head m2] + pure (w,h,n*m) + + +--Problem 86 +euler86 = error "Unsolved" + +--Problem 87 +euler87 = error "Unsolved" + + +--Problem 88 +euler88 = error "Unsolved" + + +--Problem 89 +euler89 = fmap (sum . map getDifference . lines) $ readFile "p089_roman.txt" + where getDifference xs = length xs - length (toRomNum (fromRomNum xs)) + +toRomNum :: Integer -> String +toRomNum n + | n >= 1000 = 'M' : toRomNum (n-1000) + | n >= 900 = 'C' : 'M' : toRomNum (n-900) + | n >= 500 = 'D' : toRomNum (n-500) + | n >= 400 = 'C' : 'D' : toRomNum (n-400) + | n >= 100 = 'C' : toRomNum (n-100) + | n >= 90 = 'X' : 'C' : toRomNum (n-90) + | n >= 50 = 'L' : toRomNum (n-50) + | n >= 40 = 'X' : 'L' : toRomNum (n-40) + | n >= 10 = 'X' : toRomNum (n-10) + | n >= 9 = 'I' : 'X' : toRomNum (n-9) + | n >= 5 = 'V' : toRomNum (n-5) + | n >= 4 = 'I' : 'V' : toRomNum (n-4) + | otherwise = replicate (fromIntegral n) 'I' + +fromRomNum :: String -> Integer +fromRomNum xs = fst $ foldl accumulate (0,1000) $ map val xs + where + accumulate (value,last) current + | last >= current = (value+current,current) + | otherwise = (value-2*last+current, current) + val 'M' = 1000 + val 'D' = 500 + val 'C' = 100 + val 'L' = 50 + val 'X' = 10 + val 'V' = 5 + val 'I' = 1 + +--Problem 90 +euler90 = error "Unsolved" + + +--Problem 91 +euler91 = error "See a091.cpp" +{- +for every primitive basis (that is, gcd(x,y) = 1) + calculate the number of lattice points in the 50x50 square and subtract the number of points on the vector itself + solved by transforming the square to the new basis and calculating the + number of lattice points using https://en.wikipedia.org/wiki/Pick's_theorem +-} +{-euler91 = fmap count basisVectors + where + basisVectors = [(x,y) | x<-[0..50], y<-[0..50], x>0||y>0, gcd (numerator x) (numerator y) == 1] :: [(Rational, Rational)] + count basis@(x,y) = (i + b - onBasis) :: Rational + where + onBasis = (toRational . floor) (50 / max x y) :: Rational + inverseBasis = inverse [[x,-y],[y,x]] + [x',y'] = (inverseBasis `mvprod` [x,y]) :: [Rational] + area' = ((50/x)^2 + (50/y)^2) :: Rational + i = (area' - b/2 + 1) ::Rational + b = 4*fromIntegral (gcd (numerator x') (numerator y')) ::Rational +-} + +mvprod m v = fmap (sum . zipWith (*) v) m + +inverse [[a,b],[c,d]] = fmap2 (/determinant) [[d,-b],[-c,a]] + where determinant = a*d-b*c + + +--Problem 92 +euler92 = (\(a,b)->(S.size a,S.size b)) $ foldl solveFor (S.singleton 1,S.singleton 89) [1..10000000-1] + where + solveFor sets@(s1,s89) n + | n `S.member` s1 || n `S.member` s89 = sets + | next `S.member` s1' = (S.insert n s1',s89') + | otherwise = (s1',S.insert n s89') + where + next = sum (map (^2) (numToDig n)) + (s1',s89') = solveFor (s1,s89) next + +euler92' = length [()|n<-[1..10000000-1],solve n] + where + solve 1=False + solve 89=True + solve n=(solve . sum . map (^2) . numToDig) n + + +--Problem 94 +--using Heron's formula (so sides a and b must be odd to make c and therefore a+b+c divisible by 2) +euler94 = const (error "See a094.cpp") $ sum $ do + equalSide<-[3,5..1000000000`div`3 + 1] + otherSide<-[equalSide-1,equalSide+1] + let s = equalSide + otherSide `div` 2 + guard (isSquare (s*(s-otherSide))) + pure (2*s) + + +--Problem 97 +euler97 :: Integer +euler97 = mod (28433*massivePowerMod 2 7830457 (10^10) + 1) (10^10) + +massivePowerMod _ 0 _ = 1 +massivePowerMod b p m + | even p = mod ((massivePowerMod b (div p 2) m)^2) m + | otherwise = mod ((massivePowerMod b (p-1) m) * b) m + + +--Problem 120 +euler120 = [maximum [r a n | n<-[1..2*a]]| a<-[3..1000]] + where + r a n = let p b = massivePowerMod b n (a^2) in (p (a-1) + p (a+1)) `mod` (a^2) + + +-- Problem 144 +euler144 = [v0,v1,dv,normal,dv'] + where + v0@(Vec2 x0 y0) = Vec2 ((0.0+1.4)/2) ((10.1+(-9.6))/2) + dv@(Vec2 dx dy) = normalize $ Vec2 (1.4-0.0) ((-9.6)-10.1) + a = 1/5 + b = 1/10 + t0 = solveIntersect v0 dv + solveIntersect (Vec2 x0 y0) (Vec2 dx dy) = (-b+d)/(2*a) :: Double + where + a = 4*dx^2 + dy^2 + b = 8*x0*dx + 2*y0*dy + c = y0^2 + 4*x0^2 - 100 + d = sqrt(b ^2 - 4 * a * c ) + v1@(Vec2 x' y') = v0 + t0 `smul` dv + getEllipseNormal a b (Vec2 x y) = normalize (Vec2 (x*b^2) (-y*a^2)) + normal = getEllipseNormal a b v1 + dv' = ((2 * normal `inprod` dv) `smul` normal) - dv + +data Vec2 a = Vec2 a a + deriving (Show, Eq) + +n `smul` v = (pure (n*)) <*> v +v1 `inprod` v2 = vsum (liftA2 (*) v1 v2) +vlen v = sqrt(v `inprod` v) +vsum (Vec2 x y) = x+y +normalize v = fmap (/vlen v) v + +instance Functor Vec2 where + fmap f (Vec2 x y) = Vec2 (f x) (f y) + +instance Applicative Vec2 where + pure n = Vec2 n n + (Vec2 fx fy) <*> (Vec2 x y) = Vec2 (fx x) (fy y) + +instance Num a => Num (Vec2 a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + negate = fmap negate + + + +--Problem 233 +--420 = 4*3*5*7 => the multiplicities of all prime factors f = 1 (mod 4) of n must form {1,2,3},{1,45},{2,21},{3,15},{105} +circleLatticePoints n = 4+8*integerLength (filter isATriangle testCases) + where + n' = 2*n + isATriangle b = isSquare (rSquared - b^2) + rSquared = 2*n^2 + testCases = [n+2,n+4..squareRoot rSquared] + +circleLatticePoints' n = 4*product [2*e+1|(p,e)<-groupMultiplicities (factorize n), p `mod` 4 == 1] + +s420 = [359125, 469625, 612625, 718250, 781625, 866125, 933725, 939250, 1047625, 1077375, 1119625, 1225250, 1288625, 1336625, 1366625, 1408875, 1436500, 1481125, 1542125, 1563250, 1592825, 1596725, 1732250, 1787125, 1837875, 1867450, 1878500, 1880125, 1914625, 2032225, 2049125, 2095250, 2133625, 2154750, 2203625, 2224625, 2239250, 2251925, 2302625, 2344875, 2387125, 2450500, 2513875, 2577250, 2598375, 2637125, 2673250, 2731625, 2733250, 2801175, 2817750, 2873000, 2894125, 2909125, 2911025, 2962250, 3084250, 3126500, 3142875, 3147625, 3174665, 3185650, 3193450, 3215125, 3232125, 3287375, 3316625, 3350425, 3358875, 3464500, 3504125, 3561925, 3572125, 3574250, 3648625, 3654625, 3675750, 3734900, 3757000, 3760250, 3823625, 3829250, 3865875, 3889625, 3937625, 3950375, 4009525, 4009875, 4064450, 4077125, 4082125, 4098250, 4099875, 4151485, 4161625, 4190500, 4226625, 4267250, 4288375, 4309500, 4310125, 4407250, 4443375, 4449250, 4478500, 4503850, 4544525, 4564625, 4605250, 4626375, 4689750, 4774250, 4778475, 4790175, 4837625, 4888325, 4901000, 4922125, 4949125, 4962625, 5027750, 5035825, 5091125, 5154500, 5165875, 5196750, 5274250, 5327725, 5346500, 5361375, 5382625, 5429125, 5463250, 5466500, 5471375, 5513625, 5547425, 5571625, 5602350, 5635500, 5640375] + +groupMultiplicities (x:xs) = let (eqs,rest) = span (x==) xs in (x,1+integerLength eqs) : groupMultiplicities rest +groupMultiplicities [] = [] + +groupBy2 :: (a->a->Bool) -> [a] -> [[a]] +groupBy2 _ [] = [] +groupBy2 f (x:xs) = group : groupBy2 f rest + where + (group,rest) = spanF [x] x xs + spanF acc _ [] = (acc,[]) + spanF acc a (b:xs) = if f a b then spanF (acc++[b]) b xs else (acc,b:xs) + + +--Problem 243 +euler243 = head $ dropWhile (\n -> totient n % (n-1) >= 15499%94744) $ drop 2 (inits primes) >>= (\xs -> map (product (init xs) *) [1..last xs -1]) + where + incrementalBest = map (factorize . fromIntegral) $ getBest 2 2 -- is https://oeis.org/A060735 + getBest best n + | cur < best = n : getBest cur (n+1) + | otherwise = getBest best (n+1) + where cur = totient n % (n-1) + + +--Problem 612 +euler612 = friend 1 (replicate 10 0) + where + friend n friends = friendCount : friend (n+1) (zipWith (+) friends digitCount) + where + digitCount = map (flip hasDigit n) [0..9] + hasDigit _ 0 = 0 + hasDigit k n + | m == k = 1 + | otherwise = hasDigit k d + where (d,m) = n `divMod` 10 + friendCount = sum $ zipWith (*) friends digitCount + +groupEvery _ [] = [] +groupEvery n xs = as : groupEvery n bs + where (as,bs) = splitAt n xs + +{- +--Problem +euler = error "Unsolved" + + +-} \ No newline at end of file