Init with old files.

001-010.hs

@@ -0,0 +1,47 @@
+import Data.Function
+import Data.List
+import qualified Data.Set as S
+
+-- 1 - sum of numbers ...
+problem_1 :: Int
+problem_1 = sum . nub $ [3,6..999] ++ [5,10..999]
+problem_1' = sum $ union [3,6..999] [5,10..999]
+
+
+-- 2 - all even primes lower 4 million
+problem_2 :: Int
+problem_2 = sum [x | x <- (takeWhile (<= 4000000) ((fix (\f x y -> x:f y (x+y))) 1 1)), even x]
+
+
+-- 3 - largest prime factor
+-- problem_3 :: Integer -> Integer
+prims = fix (\f (x:xs) -> x:f (filter (\y -> rem y x /= 0) xs)) [2..]
+get_prims :: Integer -> [Integer]
+get_prims 1 = []
+get_prims n = let p = head $ dropWhile (\x -> rem n x /= 0) prims
+              in p:get_prims (div n p)
+--next_prim xs = head $ dropWhile (\y -> any (\e -> rem y e == 0) xs) [last xs + 1..]
+--prims = filter (\x -> not $ any (\n -> rem x n == 0) [2..(x-1)]) [1..] 
+--pfactors n = [x | x <- takeWhile (\y ->  y*y <= n) [2..], n `mod` x == 0, null $ pfactors x] 
+problem_3 :: Integer -> Integer
+problem_3 x = last $ get_prims x
+
+
+-- 10 - sum prime smaller 2 million
+eres :: Integral a => [a] -> [a]
+eres (x:xs) = if x*x < last xs then x:eres (filter (\y -> rem y x /= 0) xs) else (x:xs)
+problem_10 = sum $ eres [2..2000000]
+
+
+-- 11 - biggest multiple in 2d field
+parseSquare :: String -> [[Integer]]
+parseSquare = map (\line -> map read $ words line) . lines
+
+columns :: [[a]] -> [[a]]
+columns [[]] = []
+columns xs = map 
+
+exercise_11 :: IO ()
+exercise_11 = do
+  fileString <- readFile "problem_11.txt"
+  putStrLn . show $ parseSquare fileString

012.hs

@@ -0,0 +1,36 @@
+import Data.List
+
+divisor_count :: Integer -> Int
+divisor_count n = length [x | x <- [1..n], rem n x == 0]
+
+--triangles :: [Integer]
+--triangles = undefined
+
+triag :: [Integer]
+triag = triag' 1 2
+	where triag' s i = s:(triag' (s+i) (i+1))
+
+rest60 :: Integer -> Integer
+rest60 x = rem x 60
+
+atkin :: Int -> [Integer]
+atkin = undefined
+
+prims :: Integer -> [Integer]
+prims n = eres [2..n]
+	where 
+  eres (x:xs)
+  	| x*x > n   = (x:xs)
+  	| otherwise = x:eres (filter (\y -> rem y x /= 0) xs)
+
+prim_factors :: Integer -> [Integer]
+prim_factors 1 = []
+prim_factors x = p:prim_factors (quot x p)
+	where p = head $ filter (\y -> rem x y == 0) (prims x)
+
+--divisor_count' :: Integer -> Int
+divisor_count' x = product . map (succ . length) . group $ prim_factors x
+
+
+main = do
+	putStrLn . show $ filter (\x -> divisor_count' x >= 500) triag

013.hs

@@ -0,0 +1,4 @@
+main = do
+	--print . map read 
+	file <- readFile "13.txt"
+	putStrLn . take 10 $ show . sum $ map read (lines file)

014.hs

@@ -0,0 +1,8 @@
+collatz :: Integral a => a -> [a]
+collatz 1 = 1:[]
+collatz x
+	| even x = x:collatz (quot x 2)
+	| odd x  = x:collatz (3*x + 1)
+
+main = do
+	putStrLn . show $ maximum $ zip (map (length . collatz) [1..1000000]) [1..]

016.hs

@@ -0,0 +1,9 @@
+import Data.Char
+
+myPow :: Integral a => a -> a -> a
+myPow x 0 = 1
+myPow x 1 = x
+myPow x n = x*(myPow x (n-1))
+
+--digitSum :: Integral a => a -> a
+digitSum x = sum $ map digitToInt $ show x

017.hs

@@ -0,0 +1,41 @@
+toWord :: Int -> [Char]
+toWord = toWord' . show
+
+toWord' :: [Char] -> [Char]
+toWord' ('0':[]) = ""
+toWord' ('1':[]) = "one"
+toWord' ('2':[]) = "two"
+toWord' ('3':[]) = "three"
+toWord' ('4':[]) = "four"
+toWord' ('5':[]) = "five"
+toWord' ('6':[]) = "six"
+toWord' ('7':[]) = "seven"
+toWord' ('8':[]) = "eight"
+toWord' ('9':[]) = "nine"
+
+toWord' ('1':'0':[]) = "ten"
+toWord' ('1':'1':[]) = "eleven"
+toWord' ('1':'2':[]) = "twelve"
+toWord' ('1':'3':[]) = "thirteen"
+toWord' ('1':'4':[]) = "fourteen"
+toWord' ('1':'5':[]) = "fifteen"
+toWord' ('1':'6':[]) = "sixteen"
+toWord' ('1':'7':[]) = "seventeen"
+toWord' ('1':'8':[]) = "eighteen"
+toWord' ('1':'9':[]) = "nineteen"
+
+toWord' ('2':c:[]) = "twenty" ++ toWord' (c:[])
+toWord' ('3':c:[]) = "thirty" ++ toWord' (c:[])
+toWord' ('4':c:[]) = "forty" ++ toWord' (c:[])
+toWord' ('5':c:[]) = "fifty" ++ toWord' (c:[])
+toWord' ('6':c:[]) = "sixty" ++ toWord' (c:[])
+toWord' ('7':c:[]) = "seventy" ++ toWord' (c:[])
+toWord' ('8':c:[]) = "eighty" ++ toWord' (c:[])
+toWord' ('9':c:[]) = "ninety" ++ toWord' (c:[])
+
+toWord' (h:'0':'0':[]) = (toWord' (h:[])) ++ "hundred"
+toWord' (h:'0':s:[]) = (toWord' (h:[])) ++ "hundredand" ++ (toWord' (s:[]))
+toWord' (h:d:s:[]) = (toWord' (h:[])) ++ "hundredand" ++ (toWord' (d:s:[]))
+
+toWord' (k:'0':'0':'0':[]) = (toWord' (k:[])) ++ "thousand"
+toWord' (k:h:d:s:[]) = (toWord' (k:[])) ++ "thousand" ++ toWord' (h:d:s:[])

018.hs

@@ -0,0 +1,98 @@
+data Tree a = Empty | Node a (Tree a) (Tree a)
+  deriving (Eq, Ord, Show)
+
+leaf :: a -> Tree a
+leaf x = Node x Empty Empty
+
+tree = Node 5 (Node 6 (leaf 8) (leaf 9)) (Node 7 (leaf 10) (leaf 11))
+treeList = [[1], [2, 3], [4, 5, 6], [7, 8, 9, 10]]
+easyList = [[3], [7, 4], [2, 4, 6], [8, 5, 9, 3]]
+
+infiniteTree :: Tree Char
+infiniteTree = Node 'x' infiniteTree infiniteTree
+
+-- breadth first traversal
+bftrav :: Tree a -> [a]
+bftrav = bftrav' . flip (:) []
+  where
+  bftrav' :: [Tree a] -> [a]
+  bftrav' []                = []
+  bftrav' (Empty:xs)        = bftrav' xs
+  bftrav' ((Node x l r):xs) = x:bftrav' (xs ++ l:r:[])
+
+-- breadth first numbering
+bfnum :: Integral a => Tree b -> Tree a
+bfnum t = t'
+  where t':[] = bfnum' 1 [t]
+
+bfnum' :: Integral a => a -> [Tree b] -> [Tree a]
+bfnum' i []                = []
+bfnum' i (Empty:xs)        = Empty:bfnum' i xs
+bfnum' i ((Node x l r):xs) = (Node i l' r'):(reverse xs')
+  where r':l':xs' = reverse $ bfnum' (i+1) (xs ++ l:r:[])
+  --where xs':l':r' = bfnum' (i+1) (xs ++ l:r:[])
+
+bfinsert' :: Maybe a -> [Tree a] -> [Tree a]
+bfinsert' _ []                = []
+bfinsert' (Just x) (Empty:ts) = (leaf x):bfinsert' Nothing ts
+bfinsert' Nothing (Empty:ts)  = Empty:bfinsert' Nothing ts
+bfinsert' x ((Node y l r):ts) = (Node y l' r'):(reverse ts')
+  where r':l':ts' = reverse $ bfinsert' x (ts ++ l:r:[])
+
+fromList :: [a] -> Tree a
+fromList = head . foldl (flip bfinsert') [Empty] . map Just
+
+parseToLists :: String -> [[Integer]]
+parseToLists = map (map read . words) . lines
+
+getLeft :: [[a]] -> [[a]]
+getLeft = map init
+
+getRight :: [[a]] -> [[a]]
+getRight = map tail 
+
+bfdepth :: [[a]] -> Tree a
+bfdepth []          = Empty
+bfdepth ((x:[]):xs) = Node x (bfdepth . getLeft $ xs) (bfdepth . getRight $ xs)
+
+fromLists :: [[a]] -> Tree a
+fromLists = bfdepth
+
+easyTree = fromLists easyList
+
+getPotential :: Integral a => Tree a -> a
+getPotential Empty        = 0
+getPotential (Node x l r) = x + max (getPotential l) (getPotential r)
+
+getHeight :: Tree a -> Int
+getHeight Empty        = 0
+getHeight (Node _ t _) = 1 + getHeight t
+
+maxLeft :: [[Integer]] -> [Integer]
+maxLeft []     = []
+maxLeft [x]    = [maximum x]
+maxLeft (x:xs) = let ms = maxLeft xs in (maximum x + head ms):ms
+
+type Current  = Integer
+type MaxFound = Integer
+type State    = (Current, MaxFound)
+
+findMaxPath :: [Integer] -> State -> Tree Integer -> State
+findMaxPath _ (c, m) (Node x Empty Empty) = if c + x > m then (c, c + x) else (c, m)
+findMaxPath (p:ps) (c, m) (Node x l@(Node xl _ _) r@(Node xr _ _))
+  | c + p <= m = (c, m)
+  | otherwise  = (c, m'')
+    where
+    (_, m')  = (findMaxPath ps (c + x, m) l) 
+    (_, m'') = if m' < c + p then 
+                 if m' > m then (findMaxPath ps (c + x, m') r) else (findMaxPath ps (c + x, m) r)
+                 else (c, m')
+
+
+main = do
+  s <- readFile "67.txt"
+  let l = parseToLists s
+  let t = fromLists l
+  let m = maxLeft l
+  let p = putStrLn . show
+  p $ findMaxPath m (0, 0) t

019.hs

@@ -0,0 +1,41 @@
+data Weekday = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
+	deriving (Show, Eq, Ord, Enum)
+
+data Month = January | February | March | April | May | June | July | August | September | October | November | December
+	deriving (Show, Eq, Ord, Enum)
+
+type Day = Int
+type Year = Int
+
+data Date = Date Year Month Day Weekday
+	deriving (Show, Eq, Ord)
+
+nextWeekday :: Weekday -> Weekday
+nextWeekday Sunday = Monday
+nextWeekday d = succ d
+
+nextMonth :: Month -> Month
+nextMonth December = January
+nextMonth m = succ m
+
+getDays :: Month -> Year -> Int
+getDays m y
+	| elem m [September, April, June, November] = 30
+  | m == February = if rem y 4 == 0 && if rem y 100 == 0 && rem y 400 /= 0 then False else True
+										then 29 else 28
+	| otherwise = 31
+
+nextDate :: Date -> Date
+nextDate (Date y m d wd)
+	| d < getDays m y = Date y m (d+1) (nextWeekday wd)
+	| m == December   = Date (y+1) January 1 (nextWeekday wd)
+	| otherwise       = Date y (nextMonth m) 1 (nextWeekday wd)
+
+
+daysTwentieth :: [Date]
+daysTwentieth = takeWhile (\(Date y _ _ _) -> y /=2001) (dates start)
+	where 
+		dates d = d:dates (nextDate d)
+		start = Date 1901 January 1 Tuesday
+
+e019 = length . filter (\(Date y m d wd) -> d == 1 && wd == Sunday) $ daysTwentieth 

020.hs

@@ -0,0 +1,8 @@
+import Data.Char (digitToInt)
+
+factorial :: Integer -> Integer
+factorial 1 = 1
+factorial x = x * factorial (x - 1)
+
+sumDigits :: Integer -> Int
+sumDigits = sum . map digitToInt . show

022.hs

@@ -0,0 +1,15 @@
+import Data.List
+
+toScore :: Char -> Integer
+toScore b = snd . head . dropWhile (\(c, i) -> c /= b) $ zip ['A'..'Z'] [1..26]
+
+nameScore :: (Integer, String) -> Integer
+nameScore (i, s) = i * (sum (map toScore s))
+
+listScore :: [String] -> Integer
+listScore = sum . map nameScore . zip [1..]
+
+main = do
+	file <- readFile "22.txt"
+	let names = sort . read $ file :: [String]
+	putStrLn . show . listScore $ names

025.hs

@@ -0,0 +1,5 @@
+fib = 1 : 1 : zipWith (+) fib (tail fib)
+
+fibIndexed = zip fib [1..]
+
+e025 = filter (\(d, _) -> (length . show $ d) >= 1000) fibIndexed

049.hs

@@ -0,0 +1,27 @@
+import Data.Function
+import Data.List
+import qualified Data.Set as S
+
+
+prims = fix (\f (x:xs) -> x:f (filter (\y -> rem y x /= 0) xs)) [2..]
+
+--permu :: Integer -> S.Set Integer
+permu :: Integer -> S.Set Integer
+permu = S.fromList . map read . permutations . show
+
+
+primsList = dropWhile (< 1000) $ takeWhile (< 10000) prims
+primsSet = S.fromList primsList
+
+candidates :: [[Integer]]
+candidates  = map (\prim -> S.toList $ S.intersection primsSet (permu prim)) primsList
+
+candidates' = filter (\x -> 3 <= length x) candidates
+candidates'' = map sort candidates'
+
+--permu' :: [a] -> [[a]]
+permu' []     = []
+permu' (x:xs) = [map permu' y | y <- tails xs]
+
+--permu3 xs = filter (\(a:b:c:[]) -> a < b && b < c && b - a == c - b) $ nub $ map (take 3) $ permutations xs
+

067.hs

@@ -0,0 +1,20 @@
+easyTree = [[3], [7,4], [2,4,6], [8,5,9,3]]
+
+parseToLists :: String -> [[Integer]]
+parseToLists = map (map read . words) . lines
+
+maxPairs :: Ord a => [a] -> [a]
+maxPairs [x] = [x]
+maxPairs xs  = zipWith max (init xs) (tail xs)
+
+nextRow :: Num a => Ord a => [a] -> [a] -> [a]
+nextRow ls hs = zipWith (+) (maxPairs ls) hs
+
+solveTree :: Num a => Ord a => [[a]] -> [a]
+solveTree xs = foldl nextRow y ys
+	where (y:ys) = reverse xs
+
+main = do
+  s <- readFile "67.txt"
+  let l = parseToLists s
+  putStrLn . show . solveTree $ l

99_problems_001-010.hs

@@ -0,0 +1,95 @@
+import Data.List
+
+-- 1 - myLast
+myLast :: [a] -> a
+
+myLast (x:[]) = x
+myLast (x:xs) = myLast xs
+
+myLast' :: [a] -> a
+myLast' = last
+
+myLast'' :: [a] -> a
+myLast'' (x:[]) = x
+myLast'' xs     = myLast'' $ tail xs
+
+
+-- 2 - myButLast
+myButLast :: [a] -> a
+
+myButLast (x:y:[]) = x
+myButLast (x:xs) = myButLast xs
+
+myButLast' = head . reverse . init
+
+
+-- 3 - elementAt
+elementAt :: [a] -> Int -> a
+
+elementAt (x:_)  1 = x
+elementAt (_:xs) i = elementAt xs (i-1)
+
+elementAt' :: [a] -> Int -> a
+elementAt' xs i = snd . head $ filter (\t -> (fst t) == i) (zip [1..] xs)
+
+
+-- 4 - myLength
+myLength :: [a] -> Int
+
+myLength xs = sum [1 | _ <- xs]
+
+myLength' = sum . map (\_ -> 1)
+
+myLength'' = foldr (\_ x -> (x + 1)) 0
+
+myLength''' []     = 0
+myLength''' (x:xs) = 1 + myLength''' xs
+
+
+-- 5 - myReverse
+myReverse :: [a] -> [a]
+myReverse = reverse 
+myReverse' = foldr (\x xs -> x:xs)
+
+
+-- 6 - isPalindrome
+isPalindrome :: Eq a => [a] -> Bool
+isPalindrome xs = and (zipWith (\x y -> x == y) xs (reverse xs))
+
+
+-- 7 - myFlatten
+data NestedList a = Elem a | List [NestedList a]
+  deriving (Show, Read)
+
+
+myFlatten :: (NestedList a) -> [a]
+myFlatten (Elem a)  = [a]
+myFlatten (List xs) = foldl (++) [] (map myFlatten xs)
+
+myFlatten' (Elem a)  = [a]
+myFlatten' (List []) = []
+myFlatten' (List (x:xs)) = foldl (\a b -> (a ++ (myFlatten b))) (myFlatten x) xs
+
+myFlatten'' (Elem a)  = [a]
+myFlatten'' (List xs) = concatMap myFlatten'' xs
+
+
+-- 8 - compress
+-- compress "aaaabcccaadeeee" -> "abcade"
+compress :: Eq a => [a] -> [a]
+compress []     = []
+compress (x:xs) = reverse $ foldl (\(r:rs) l -> if r == l then r:rs else  l:r:rs) [x] xs
+compress' xs = map head (group xs)
+
+
+-- 9 - pack
+pack :: Eq a => [a] -> [[a]]
+pack = group
+
+pack' :: Eq a => [a] -> [[a]]
+pack' [] = []
+pack' xs = (takeWhile (\e -> e == (head xs)) xs):(pack' $ dropWhile (\e -> e == (head xs)) xs)
+
+-- 10 - encode
+encode :: Eq a => [a] -> [(Int, a)]
+encode xs = map (\l -> (length l, head l)) $ pack' xs

99_problems_011-020.hs

@@ -0,0 +1,54 @@
+import Data.List
+
+-- 11 - encode
+data Encoded a = Single a | Multiple Int a
+  deriving (Show)
+
+encode :: Eq a => [a] -> [(Encoded a)]
+encode xs = map (\l -> if length l > 1 then Multiple (length l) (head l) else Single (head l)) $ group xs
+
+
+-- 12 - decode
+decode :: [(Encoded a)] -> [a]
+decode []                  = []
+decode ((Single x):xs)     = x:(decode xs)
+decode ((Multiple n x):xs) = (replicate n x) ++ (decode xs)
+
+
+-- 13 - encode - direct
+
+
+-- 14 - dupli
+dupli :: [a] -> [a]
+dupli []     = []
+dupli (x:xs) = x:x:(dupli xs)
+
+dupli' xs = concat $ [[x, x] | x <- xs]
+dupli'' = concatMap (\x -> [x, x])
+
+
+-- 15 - repli
+repli :: [a] -> Int -> [a]
+repli xs n = concatMap (\x -> replicate n x) xs
+
+
+-- 16 - dropEvery
+dropEvery :: [a] -> Int -> [a]
+dropEvery [] _     = []
+dropEvery xs n = (take (n-1) xs) ++ dropEvery (drop n xs) n
+
+
+-- 17 - split
+split :: [a] -> Int -> ([a], [a])
+split xs n = (take n xs, drop n xs)
+
+
+-- 18 - slice
+slice :: [a] -> Int -> Int -> [a]
+slice xs l u = take (u-l+1) $ drop (l-1) xs
+-- not mine: slice xs i k = [x | (x,j) <- zip xs [1..k], i <= j]
+
+
+-- 19 - rotate
+rotate :: [a] -> Int -> [a]
+rotate xs _ = []

bcs.hs

@@ -0,0 +1,40 @@
+import Prelude hiding ((>>=), return)
+
+type Choice a = [a]
+
+choose :: [a] -> Choice a
+choose xs = xs
+
+pair456 :: Int -> Choice (Int, Int)
+pair456 x = choose [(x, 4), (x, 5), (x, 6)]
+
+join :: Choice (Choice a) -> Choice a
+join = concat
+
+-- join $ map pair456 [1,2,3] 
+-- [1, 2, 3] >>= pair456
+(>>=) :: Choice a -> (a -> Choice b) -> Choice b
+choices >>= f = join (map f choices)
+
+return :: a -> Choice a
+return x = [x]
+
+makePairs :: Choice (Int, Int)
+makePairs = 
+  choose [1, 2, 3] >>= (\x ->
+  choose [4, 5, 6] >>= (\y ->
+  return (x, y)))
+
+mzero :: Choice a
+mzero = choose []
+
+guard :: Bool -> Choice ()
+guard True  = return ()
+guard False = mzero
+
+makePairs' :: Choice (Int,Int)
+makePairs' = do
+  x <- choose [1,2,3]
+  y <- choose [4,5,6]
+  guard (x*y == 8)
+  return (x,y)