day11 part 2

Makefile

@@ -1,4 +1,4 @@
-DAY = 4
+DAY = 11
 
 DIR = day$(DAY)
 

day10/main.hs

@@ -0,0 +1,62 @@
+import System.IO
+
+import Data.List.Split
+
+
+
+data Cycle = Noop | Addx1 | Addx2 Int deriving (Show)
+
+
+
+parseInstr :: String -> [Cycle]
+parseInstr ('n':_) = [Noop]
+parseInstr ('a':xs) = [Addx1,Addx2 dx]
+    where
+        dxs = last $ splitOn " " xs
+        dx  = read dxs :: Int
+
+parseAsm :: String -> [Cycle]
+parseAsm = concat . map parseInstr . lines
+
+
+
+
+computeX :: Int -> Cycle -> Int
+computeX x (Addx2 dx) = x + dx
+computeX x _ = x
+
+
+
+
+drawCRT :: [Bool] -> (Int, Int) -> [Bool]
+drawCRT crt (c,x) = sx ++ [draw] ++ (tail xs)
+    where
+        (sx,xs) = splitAt c crt
+        sprite = [x-1,x,x+1]
+        col = (c `mod` 40)
+        draw = elem col sprite
+
+printCRT :: [Bool] -> String
+printCRT = concat . map (++"\n") . chunksOf 40 . map crtchr
+    where
+        crtchr False = '.'
+        crtchr True  = '#'
+
+
+
+
+handler :: String -> String
+handler s = (show $ sum score) ++ "\n" ++
+            (printCRT crt) ++ "\n"
+    where
+        cycles = parseAsm s
+        xhs = scanl computeX 1 cycles
+        sigstr = zipWith (*) [1..] xhs
+        score = map ((0:sigstr) !!) [20,60..220]
+        crt = foldl drawCRT (replicate 240 False) (zip [0..239] xhs)
+
+main :: IO ()
+main = do
+    interact handler
+
+

day11/main.hs

@@ -0,0 +1,99 @@
+import System.IO
+
+import Data.List
+import Data.List.Split
+
+--import Debug.Trace
+
+
+
+data Monkey = Monkey { name :: Int
+                     , items :: [Integer]
+                     , op :: (Integer -> Integer)
+                     , cond :: (Integer -> Bool)
+                     , dest :: (Bool -> Int)
+                     , counter :: Int
+                     }
+
+instance Show Monkey where
+    show (Monkey n i _ _ _ c) = "Monkey " ++ show n ++ " " ++ show i ++ " " ++ show c
+
+instance Eq Monkey where
+    m1 == m2 = (name m1) == (name m2)
+
+instance Ord Monkey where
+    compare m1 m2 = compare (counter m1) (counter m2)
+
+
+
+parseOFunc :: [String] -> (Integer -> Integer)
+parseOFunc ["+","old"] = (\x -> x + x)
+parseOFunc ["+",num]   = (\x -> x + n) where n = read num :: Integer
+parseOFunc ["*","old"] = (\x -> x * x)
+parseOFunc ["*",num]   = (\x -> x * n) where n = read num :: Integer
+
+parseTFunc :: Integer -> (Integer -> Bool)
+parseTFunc d = (\x -> (x `mod` d) == 0)
+
+parseMonkey :: [String] -> (Monkey,Integer)
+parseMonkey xs = (Monkey n i o t d 0,t')
+    where
+        n = read [head $ drop 7 (xs !! 0)] :: Int
+        i = map (\x -> read x :: Integer) $ splitOn ", " $ drop 18 (xs !! 1)
+        o = parseOFunc $ splitOn " " $ drop 23 (xs !! 2)
+        t'= read (last $ splitOn " " (xs !! 3)) :: Integer
+        t = parseTFunc t'
+        d'= map (\x -> read (last $ splitOn " " x) :: Int) $ drop 4 xs
+        d = (\x -> if x then head d' else last d')
+
+
+
+
+throw :: Monkey -> [(Integer,Int)] -> [Monkey] -> [Monkey]
+throw (Monkey from _ _ _ de _) throws = map throwMod -- trace ("THROWS: " ++ show throws)
+    where
+        deT = de True
+        deF = de False
+        (thT,thF) = partition (\(_,y) -> y == deT) throws
+        toT = map (\(x,_) -> x) thT
+        toF = map (\(x,_) -> x) thF
+        throwMod m@(Monkey n i o t d c)
+            | n == from = Monkey n [] o t d (c + length throws)
+            | n == deT  = Monkey n (i ++ toT) o t d c
+            | n == deF  = Monkey n (i ++ toF) o t d c
+            | otherwise = m
+
+applyTurn :: Integer -> Integer -> Monkey -> [Monkey] -> [Monkey]
+applyTurn lcmd wrd m@(Monkey n i o t d _) ms = nms -- trace ("NEW: " ++ show nms)
+    where
+        postInsp = map ((`mod` lcmd) . o) i -- trace ("TURN: " ++ show m)
+        postBore = map (`div` wrd) postInsp
+        postTest = map t postBore
+        throwTo  = map d postTest
+        nms      = throw m (zip postBore throwTo) ms
+
+applyTurns :: Integer -> Integer -> [Monkey] -> [Monkey] -> [Monkey]
+applyTurns _ _ [] ms = ms
+applyTurns l wrd (t:ts) ms = applyTurns l wrd ts (applyTurn l wrd (ms !! (name t)) ms)
+
+
+
+
+
+handler :: String -> String
+handler s = (show p1) ++ "\n" ++
+            (show p2) ++ "\n"
+    where
+        (monkeys,divisors) = unzip $ map parseMonkey $ splitOn [""] $ lines s
+        lcmd    = foldl1 lcm divisors
+        turns   = (\nt -> take (nt * length monkeys) $ concat $ repeat monkeys)
+        final1  = applyTurns lcmd 3 (turns 20) monkeys
+        final2  = applyTurns lcmd 1 (turns 10000) monkeys
+        topprod = product . map counter . take 2 . reverse . sort
+        [p1,p2] = map topprod [final1,final2]
+
+main :: IO ()
+main = do
+    interact handler
+
+

day5/main.hs

@@ -0,0 +1,58 @@
+import System.IO
+
+import Data.List
+import Data.List.Split
+
+
+
+
+parseStacks :: [String] -> [[Char]]
+parseStacks = map (filter (/=' ') . init) . transpose . map (map (!!1) . chunksOf 4)
+
+
+parseMove :: String -> (Int,Int,Int)
+parseMove s = (read (x!!1) :: Int, read (x!!3) :: Int, read (x!!5) :: Int)
+    where x = splitOn " " s
+
+
+
+
+applyStacks :: (Int,[Char]) -> (Int,[Char]) -> (Int,[Char]) -> [Char]
+applyStacks (f,fs) (t,ts) (c,cs)
+    | c == f = fs
+    | c == t = ts
+    | otherwise = cs
+
+
+applyMove :: [[Char]] -> (Int,Int,Int) -> [[Char]]
+applyMove acc (n,f,t) = map (applyStacks (f,fromstack) (t,newstack)) $ zip [1..] acc
+    where oldstack = acc !! (f-1)
+          c = take n oldstack
+          fromstack = drop n oldstack
+          tostack = acc !! (t-1)
+          newstack = c ++ tostack
+
+
+applyMoves :: [[Char]] -> (Int,Int,Int) -> [[Char]]
+applyMoves acc (0,_,_)   = acc
+applyMoves acc (n,f,l) = applyMoves (applyMove acc (1,f,l)) (n-1,f,l)
+
+
+
+
+applyMoves2 :: [[Char]] -> (Int,Int,Int) -> [[Char]]
+applyMoves2 acc move = applyMove acc move
+
+
+
+
+handler :: String -> String
+handler s = (show $ map head $ foldl applyMoves stacks moves) ++ "\n" ++
+            (show $ map head $ foldl applyMoves2 stacks moves) ++ "\n"
+    where sections = splitOn [""] $ lines s
+          stacks = parseStacks $ sections !! 0
+          moves  = map parseMove $ sections !! 1
+
+main :: IO ()
+main = do
+    interact handler

day6/main.hs

@@ -0,0 +1,21 @@
+import System.IO
+import Data.List
+
+
+
+
+marker :: Int -> Int -> String -> Int
+marker p n s@(_:xs)
+    | unique == n = p+n
+    | otherwise   = marker (p+1) n xs
+    where
+        unique = length $ nub $ take n s
+
+
+handler :: String -> String
+handler s = (show $ marker 0 4 s) ++ "\n" ++
+            (show $ marker 0 14 s) ++ "\n"
+
+main :: IO ()
+main = do
+    interact handler

day7/main.hs

@@ -0,0 +1,122 @@
+import System.IO
+
+import Data.List
+import Data.List.Split
+
+import Debug.Trace
+
+
+
+data Node = File String Int | Dir String Int [Node] deriving (Show)
+
+instance Eq Node where
+    Dir n1 _ _ == Dir n2 _ _ = n1 == n2
+    File n1 _  == File n2 _  = n1 == n2
+
+instance Ord Node where
+    Dir _ s1 _ `compare` Dir _ s2 _ = s1 `compare` s2
+    File _ s1  `compare` File _ s2  = s1 `compare` s2
+
+nodeSize :: Node -> Int
+nodeSize (File _ s) = s
+nodeSize (Dir _ s _) = s
+
+
+nodeInfo :: Node -> String
+nodeInfo (File n s) = n ++ "(file, size=" ++ show s ++ ")"
+nodeInfo (Dir n s _) = n ++ "(dir, size=" ++ show s ++ ")"
+
+printNode :: Int -> Node -> String
+printNode lvl n = case n of
+    File n s  -> sp ++ "- " ++ n ++ " (file, size=" ++ show s ++ ")\n"
+    Dir n s c -> sp ++ "- " ++ n ++ " (dir, size=" ++ show s ++ ")\n" ++ printNodes (lvl+1) c
+    where
+        sp = replicate (2*lvl) ' '
+
+printNodes :: Int -> [Node] -> String
+printNodes a = concat . map (printNode a)
+
+
+
+
+
+--parseDir' :: [String] -> [Node]
+--parseDir' (x:xs) =
+
+dirInNodes :: String -> [Node] -> (Bool,Node,[Node])
+dirInNodes name onodes = (exists, instanc, removed)
+    where
+        matches = filter (\node@(Dir n _ _) -> n == name) onodes
+        exists  = (length matches) > 0
+        instanc = if exists then head matches else File "<nonexistent>" 0
+        removed = delete instanc onodes
+
+
+
+
+parseDir :: [Node] -> [Node] -> [String] -> ([Node],[String])
+parseDir onodes nodes (x:xs)
+    | "$ cd " `isPrefixOf` x = ((Dir (drop 5 x) (sum $ map nodeSize nodes) nodes:onodes), xs)
+    | "dir "  `isPrefixOf` x = case dirInNodes (drop 4 x) onodes of
+                                    (True,node,restnodes) -> parseDir restnodes (node:nodes) xs
+                                    (False,_,_) -> parseDir onodes nodes xs
+    | otherwise = parseDir onodes (File fname fsize:nodes) xs
+    where
+        [fsize',fname] = splitOn " " x
+        fsize = read fsize' :: Int
+
+
+
+parseCli :: [Node] ->  [String] -> [String] -> [Node]
+parseCli nodes [] [] = []
+parseCli nodes stack [] = onodes ++ parseCli onodes reststack []
+    where (onodes,reststack) = parseDir nodes [] $ stack
+parseCli nodes stack (x:xs)
+    | x == "$ cd .." = onodes ++ parseCli onodes reststack xs
+    | otherwise = parseCli nodes (x:stack) xs
+    where (onodes,reststack) = parseDir nodes [] $ stack
+
+
+prepCli :: [String] -> [String]
+prepCli = filter (/= "$ ls")
+
+
+
+
+
+findNodes :: (Node -> Bool) -> Node -> [Node]
+findNodes f file@(File _ _) = if (f file) then [file] else []
+findNodes f dir@(Dir _ _ c) = (if (f dir) then [dir] else []) ++ (concat $ map (findNodes f) c)
+
+
+dirSize :: (Int -> Bool) -> Node -> Bool
+dirSize _ (File _ _)  = False
+dirSize f (Dir _ s _) = f s
+
+
+
+
+findDeletable :: Int -> Int -> Node -> Node
+findDeletable fss req root@(Dir _ used _) = smallest
+    where
+        tbf = req - (fss-used)
+        candidates = findNodes (dirSize (>= tbf)) root
+        smallest = head $ sort candidates
+
+
+
+
+handler :: String -> String
+handler s = (show sumUnder) ++ "\n" ++
+            (show savsize) ++ "\n"
+    where
+        rootNode = last $ parseCli [] [] $ prepCli $ lines s
+        under100k = findNodes (dirSize (<= 100000)) rootNode
+        sumUnder = sum $ map (\(Dir _ s _) -> s) under100k
+        (Dir _ savsize _) = findDeletable 70000000 30000000 rootNode
+
+main :: IO ()
+main = do
+    interact handler
+
+

day8/main.hs

@@ -0,0 +1,79 @@
+import System.IO
+
+import Data.List
+import Data.List.Split
+
+
+parseForest :: String -> [[Int]]
+parseForest = map (\ r -> map toInt r) . lines
+    where toInt = (\ c -> read [c] :: Int)
+
+
+rotateForest :: Int -> [[a]] -> [[a]]
+rotateForest 0 f = f
+rotateForest 1 f = transpose f
+rotateForest 2 f = map reverse f
+rotateForest 3 f = map reverse $ transpose f
+
+rotateForestBack 3 f = transpose $ map reverse f
+rotateForestBack n f = rotateForest n f
+
+
+
+
+visibilityRow :: Int -> [Int] -> [Bool]
+visibilityRow _ [] = []
+visibilityRow m (x:xs)
+    | x == 9    = (True:[False | _ <- xs])
+    | x > m     = (True:visibilityRow x xs)
+    | otherwise = (False:visibilityRow m xs)
+
+
+visibilityMap :: [[Int]] -> [[Bool]]
+visibilityMap = map (visibilityRow (-1))
+
+
+
+
+merge' :: (a -> a -> a) -> [[[a]]] -> [[a]]
+merge' f = foldl1 (zipWith (zipWith f))
+
+merge :: (a -> a -> a) -> [[[a]]] -> [[a]]
+merge f m = merge' f $ zipWith rotateForestBack [0..length m] m
+
+count :: [[Bool]] -> Int
+count = length . filter (==True) . concat
+
+
+
+
+hv :: [[Int]] -> Int
+hv [left,[c],right] = (v $ reverse left) * (v right)
+    where
+        v [] = 0
+        v (x:xs)
+            | x >= c = 1
+            | otherwise = 1 + (v xs)
+
+
+hvm :: [[Int]] -> [[Int]]
+hvm = map (map hv . splits)
+    where
+        splits a = map (\n -> splitPlacesBlanks [n,1,length a] a) [0..length a-1]
+
+
+
+
+handler :: String -> String
+handler s = (show visibleTrees) ++ "\n" ++
+            (show hvs) ++ "\n"
+    where
+        f = parseForest s
+        dirs = map (\ x -> rotateForest x f) [0..3]
+        visibleTrees = count $ merge (||) $ map visibilityMap dirs
+        hvs = maximum $ concat $ merge (*) $ map hvm (take 2 dirs)
+
+
+main :: IO ()
+main = do
+    interact handler

day9/main.hs

@@ -0,0 +1,96 @@
+import System.IO
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Data.Char (ord,chr)
+
+
+
+
+type Pos = (Int,Int)
+
+
+
+
+ppinsert :: Char -> [Pos] -> ([String],Int,Int) -> [String]
+ppinsert _ [] (b,_,_) = b
+ppinsert id ((x,y):xs) d@(b,minx,miny) = nbrd
+    where
+        nextid
+            | id == '#' = '#'
+            | id == 'H' = '1'
+            | otherwise = chr $ (ord id)+1
+        (brows,(orow:arows)) = splitAt (y-miny) $ ppinsert nextid xs d
+        (bchars,(_:achars)) = splitAt (x-minx) orow
+        nrow = bchars ++ [id] ++ achars
+        nbrd = brows ++ [nrow] ++ arows
+
+
+ppp :: Char -> [Pos] -> String
+ppp h l = concat $ reverse $ ppinsert h l (start,minx,miny)
+    where
+        (x,y) = unzip l
+        minx  = min (-10) (minimum x)
+        miny  = min (-5) (minimum y)
+        maxx  = max 10 (maximum x)
+        maxy  = max 5 (maximum y)
+        srow  = replicate (-minx) '.' ++ "s" ++ replicate maxx '.' ++ "\n"
+        brow  = replicate (-minx) '.' ++ "." ++ replicate maxx '.' ++ "\n"
+        start = replicate (-miny) brow ++ [srow] ++ replicate maxy brow
+
+
+
+
+parseMove :: String -> [Pos]
+parseMove s = replicate n dv
+    where
+        d  = head s
+        n  = read (drop 2 s) :: Int
+        dv = case d of 'U' -> (0,1)
+                       'R' -> (1,0)
+                       'D' -> (0,-1)
+                       'L' -> (-1,0)
+
+parseMoves :: String -> [Pos]
+parseMoves = concat . map parseMove . lines
+
+
+
+
+dragTail :: [Pos] -> [Pos]
+dragTail [t] = [t]
+dragTail l@( h@(hx,hy) : (nx,ny) : xs)
+    | dx > 1    = (h : dragTail ((nx+1  ,ny+dyu) : xs))
+    | dy > 1    = (h : dragTail ((nx+dxu,ny+1  ) : xs))
+    | dx < -1   = (h : dragTail ((nx-1  ,ny+dyu) : xs))
+    | dy < -1   = (h : dragTail ((nx+dxu,ny-1  ) : xs))
+    | otherwise = l
+    where
+        (dx,dy) = (hx-nx,hy-ny)
+        (dxu,dyu) = (signum dx,signum dy)
+
+sim :: (Set Pos,[Pos]) -> Pos -> (Set Pos,[Pos])
+sim (s,((hx,hy):t)) (dx,dy) = (ns,nl) -- trace (ppp 'H' nl)
+    where
+        nh = (hx+dx,hy+dy)
+        nl = dragTail (nh:t)
+        ns = Set.insert (last nl) s
+
+
+
+
+handler :: String -> String
+handler s = (show $ Set.size trail2) ++ "\n" ++
+            (show $ Set.size trail10) ++ "\n"
+    where
+        moves = parseMoves s
+        start2 = (Set.empty,[(0,0),(0,0)])
+        start10 = (Set.empty,replicate 10 (0,0))
+        (trail2,_) = foldl sim start2 $ moves
+        (trail10,_) = foldl sim start10 $ moves
+
+main :: IO ()
+main = do
+    interact handler
+