+++ /dev/null
-name: adventofcode16
-version: 0.1.0.0
-synopsis: Initial project template from stack
-description: Please see README.md
-homepage: https://github.com/neilnjae/adventofcode16#readme
-license: BSD3
-license-file: LICENSE
-author: Neil Smith
-maintainer: noone@njae.me.uk
-copyright: 2016 Neil Smith
-category: None
-build-type: Simple
-extra-source-files: README.md
-cabal-version: >=1.10
-
-library
- hs-source-dirs: src
- exposed-modules: Lib
- build-depends: base >= 4.7 && < 5
- default-language: Haskell2010
-
-executable advent01
- hs-source-dirs: app
- main-is: advent01.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , split
- default-language: Haskell2010
-
-executable advent02
- hs-source-dirs: app
- main-is: advent02.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , array
- default-language: Haskell2010
-
-executable advent03
- hs-source-dirs: app
- main-is: advent03.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , split
- default-language: Haskell2010
-
-executable advent04
- hs-source-dirs: app
- main-is: advent04.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , split
- , containers
- default-language: Haskell2010
-
-executable advent05
- hs-source-dirs: app
- main-is: advent05.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , containers
- , MissingH
- default-language: Haskell2010
-
-executable advent06
- hs-source-dirs: app
- main-is: advent06.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent07
- hs-source-dirs: app
- main-is: advent07.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- default-language: Haskell2010
-
-executable advent08
- hs-source-dirs: app
- main-is: advent08.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , array
- , parsec
- default-language: Haskell2010
-
-executable advent09
- hs-source-dirs: app
- main-is: advent09.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , split
- default-language: Haskell2010
-
-executable advent10
- hs-source-dirs: app
- main-is: advent10.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , text
- , mtl
- default-language: Haskell2010
-
-executable advent11
- hs-source-dirs: app
- main-is: advent11.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent11a
- hs-source-dirs: app
- main-is: advent11a.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent11h
- hs-source-dirs: app
- main-is: advent11h.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent11p
- hs-source-dirs: app
- main-is: advent11p.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , pqueue
- default-language: Haskell2010
-
-executable advent12
- hs-source-dirs: app
- main-is: advent12.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- , mtl
- default-language: Haskell2010
-
-executable advent13
- hs-source-dirs: app
- main-is: advent13.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , MissingH
- default-language: Haskell2010
-
-executable advent14
- hs-source-dirs: app
- main-is: advent14.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , MissingH
- default-language: Haskell2010
-
-executable advent14c
- hs-source-dirs: app
- main-is: advent14c.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , bytestring
- , cryptonite
- default-language: Haskell2010
-
-executable advent14parallel
- hs-source-dirs: app
- main-is: advent14parallel.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parallel
- , bytestring
- , cryptonite
- default-language: Haskell2010
-
-executable advent15
- hs-source-dirs: app
- main-is: advent15.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- default-language: Haskell2010
-
-executable advent15l
- hs-source-dirs: app
- main-is: advent15l.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- default-language: Haskell2010
-
-executable advent16
- hs-source-dirs: app
- main-is: advent16.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent16i
- hs-source-dirs: app
- main-is: advent16i.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent17
- hs-source-dirs: app
- main-is: advent17.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , bytestring
- , cryptonite
- default-language: Haskell2010
-
-executable advent18
- hs-source-dirs: app
- main-is: advent18.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent18f
- hs-source-dirs: app
- main-is: advent18f.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-executable advent19
- hs-source-dirs: app
- main-is: advent19.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , containers
- default-language: Haskell2010
-
-executable advent20
- hs-source-dirs: app
- main-is: advent20.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- default-language: Haskell2010
-
-executable advent21
- hs-source-dirs: app
- main-is: advent21.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- , mtl
- default-language: Haskell2010
-
-executable advent22
- hs-source-dirs: app
- main-is: advent22.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- default-language: Haskell2010
-
-executable advent22search
- hs-source-dirs: app
- main-is: advent22search.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- default-language: Haskell2010
-
-executable advent22showgrid
- hs-source-dirs: app
- main-is: advent22showgrid.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- default-language: Haskell2010
-
-executable advent22library
- hs-source-dirs: app
- main-is: advent22library.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- , containers
- , astar
- , unordered-containers
- , hashable
- default-language: Haskell2010
-
-executable advent23
- hs-source-dirs: app
- main-is: advent23.hs
- ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- , parsec
- , parsec-numbers
- , mtl
- default-language: Haskell2010
-
-executable adventofcode16-exe
- hs-source-dirs: app
- main-is: Main.hs
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , adventofcode16
- default-language: Haskell2010
-
-test-suite adventofcode16-test
- type: exitcode-stdio-1.0
- hs-source-dirs: test
- main-is: Spec.hs
- build-depends: base
- , adventofcode16
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
- default-language: Haskell2010
-
-source-repository head
- type: git
- location: https://github.com/neilnjae/adventofcode16
--- /dev/null
+name: adventofcode16
+version: 0.1.0.0
+synopsis: Initial project template from stack
+description: Please see README.md
+homepage: https://github.com/neilnjae/adventofcode16#readme
+license: BSD3
+license-file: LICENSE
+author: Neil Smith
+maintainer: noone@njae.me.uk
+copyright: 2016 Neil Smith
+category: None
+build-type: Simple
+extra-source-files: README.md
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ exposed-modules: Lib
+ build-depends: base >= 4.7 && < 5
+ default-language: Haskell2010
+
+executable advent03
+ hs-source-dirs: app
+ main-is: advent03.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , split
+ default-language: Haskell2010
+
+executable advent04
+ hs-source-dirs: app
+ main-is: advent04.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , split
+ , containers
+ default-language: Haskell2010
+
+executable advent05
+ hs-source-dirs: app
+ main-is: advent05.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , containers
+ , MissingH
+ default-language: Haskell2010
+
+executable advent06
+ hs-source-dirs: app
+ main-is: advent06.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent07
+ hs-source-dirs: app
+ main-is: advent07.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ default-language: Haskell2010
+
+executable advent08
+ hs-source-dirs: app
+ main-is: advent08.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , array
+ , parsec
+ default-language: Haskell2010
+
+executable advent09
+ hs-source-dirs: app
+ main-is: advent09.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , split
+ default-language: Haskell2010
+
+executable advent10
+ hs-source-dirs: app
+ main-is: advent10.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , text
+ , mtl
+ default-language: Haskell2010
+
+executable advent11
+ hs-source-dirs: app
+ main-is: advent11.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent11a
+ hs-source-dirs: app
+ main-is: advent11a.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent11h
+ hs-source-dirs: app
+ main-is: advent11h.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent11p
+ hs-source-dirs: app
+ main-is: advent11p.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , pqueue
+ default-language: Haskell2010
+
+executable advent12
+ hs-source-dirs: app
+ main-is: advent12.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ , mtl
+ default-language: Haskell2010
+
+executable advent13
+ hs-source-dirs: app
+ main-is: advent13.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , MissingH
+ default-language: Haskell2010
+
+executable advent14
+ hs-source-dirs: app
+ main-is: advent14.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , MissingH
+ default-language: Haskell2010
+
+executable advent14c
+ hs-source-dirs: app
+ main-is: advent14c.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , bytestring
+ , cryptonite
+ default-language: Haskell2010
+
+executable advent14parallel
+ hs-source-dirs: app
+ main-is: advent14parallel.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parallel
+ , bytestring
+ , cryptonite
+ default-language: Haskell2010
+
+executable advent15
+ hs-source-dirs: app
+ main-is: advent15.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ default-language: Haskell2010
+
+executable advent15l
+ hs-source-dirs: app
+ main-is: advent15l.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ default-language: Haskell2010
+
+executable advent16
+ hs-source-dirs: app
+ main-is: advent16.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent16i
+ hs-source-dirs: app
+ main-is: advent16i.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent17
+ hs-source-dirs: app
+ main-is: advent17.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , bytestring
+ , cryptonite
+ default-language: Haskell2010
+
+executable advent18
+ hs-source-dirs: app
+ main-is: advent18.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent18f
+ hs-source-dirs: app
+ main-is: advent18f.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+executable advent19
+ hs-source-dirs: app
+ main-is: advent19.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , containers
+ default-language: Haskell2010
+
+executable advent20
+ hs-source-dirs: app
+ main-is: advent20.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ default-language: Haskell2010
+
+executable advent21
+ hs-source-dirs: app
+ main-is: advent21.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ , mtl
+ default-language: Haskell2010
+
+executable advent22
+ hs-source-dirs: app
+ main-is: advent22.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ default-language: Haskell2010
+
+executable advent22search
+ hs-source-dirs: app
+ main-is: advent22search.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ default-language: Haskell2010
+
+executable advent22showgrid
+ hs-source-dirs: app
+ main-is: advent22showgrid.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ default-language: Haskell2010
+
+executable advent22library
+ hs-source-dirs: app
+ main-is: advent22library.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ , containers
+ , astar
+ , unordered-containers
+ , hashable
+ default-language: Haskell2010
+
+executable advent23
+ hs-source-dirs: app
+ main-is: advent23.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ , parsec
+ , parsec-numbers
+ , mtl
+ default-language: Haskell2010
+
+executable adventofcode16-exe
+ hs-source-dirs: app
+ main-is: Main.hs
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode16
+ default-language: Haskell2010
+
+test-suite adventofcode16-test
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Spec.hs
+ build-depends: base
+ , adventofcode16
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ default-language: Haskell2010
+
+source-repository head
+ type: git
+ location: https://github.com/neilnjae/adventofcode16
--- /dev/null
+module Main where
+
+import Lib
+
+main :: IO ()
+main = someFunc
--- /dev/null
+module Main(main) where
+
+import Data.List (transpose, sort)
+import Data.List.Split (splitOn, chunksOf)
+
+type Triple = [Integer]
+
+main :: IO ()
+main = do
+ instrText <- readFile "data/advent03.txt"
+ let triangles = map (parseLine) $ lines instrText
+ part1 triangles
+ part2 triangles
+
+
+part1 :: [Triple] -> IO ()
+part1 triangles = do
+ print $ length $ filter (validTriangle) triangles
+
+part2 :: [Triple] -> IO ()
+part2 triangles = do
+ print $ length $ filter (validTriangle) $ byColumns triangles
+
+
+parseLine :: String -> Triple
+parseLine = map (read) . filter (not . null) . splitOn " "
+
+validTriangle :: Triple -> Bool
+validTriangle triple = sortedTriple!!0 + sortedTriple!!1 > sortedTriple!!2
+ where sortedTriple = sort triple
+
+byColumns :: [[Integer]] -> [Triple]
+byColumns = chunksOf 3 . concat . transpose
--- /dev/null
+module Main(main) where
+
+import Data.List (last, intersperse, sortBy, intercalate, isInfixOf, init)
+import Data.List.Split (splitOn)
+import Data.Char (isLetter, ord, chr)
+import qualified Data.Map.Lazy as Map
+
+data Room = Room { name :: String
+ , sector :: Int
+ , checksum :: String
+ } deriving (Show)
+
+main :: IO ()
+main = do
+ instrText <- readFile "data/advent04.txt"
+ let rooms = map (parseLine) $ lines instrText
+ part1 rooms
+ part2 rooms
+
+
+part1 :: [Room] -> IO ()
+part1 rooms = do
+ print $ sum $ map (sector) validRooms
+ where
+ validChecksum room = (checksum room) == makeChecksum (name room)
+ validRooms = filter (validChecksum) rooms
+
+part2 :: [Room] -> IO ()
+part2 rooms = do
+ print $ fst $ head $ filter (\sn -> isInfixOf "north" (snd sn)) sectorNames
+ where
+ validChecksum room = (checksum room) == makeChecksum (name room)
+ validRooms = filter (validChecksum) rooms
+ sectorNames = [((sector r),
+ shiftWord (sector r) (name r)) | r <- validRooms]
+
+
+parseLine :: String -> Room
+parseLine line = Room {name=name, sector=sector, checksum=checksum}
+ where components = splitOn "-" line
+ name = intercalate "-" $ init components
+ sector = read $ head $ splitOn "[" $ last components
+ checksum = filter (isLetter) $ last components
+
+countedLetters :: String -> [(Char, Int)]
+countedLetters name = sortBy sortCLetter $ unsortedCountedLetters name
+ where unsortedCountedLetters name =
+ Map.toList $ Map.fromListWith (+) [(c, 1) | c <- filter (isLetter) name]
+
+sortCLetter :: (Char, Int) -> (Char, Int) -> Ordering
+sortCLetter (l1, n1) (l2, n2)
+ | n1 < n2 = GT
+ | n1 > n2 = LT
+ | n1 == n2 = compare l1 l2
+
+makeChecksum :: String -> String
+makeChecksum name = [l | (l, _) <- take 5 $ countedLetters name]
+
+
+shiftWord :: Int -> String -> String
+shiftWord shift letters = map (shiftLetter shift) letters
+
+shiftLetter :: Int -> Char -> Char
+shiftLetter shift letter
+ | isLetter letter = chr $ (ord letter - ord 'a' + shift) `mod` 26 + ord 'a'
+ | otherwise = ' '
--- /dev/null
+module Main(main) where
+
+import Data.Hash.MD5 (md5s, Str(..))
+import Data.List (isPrefixOf)
+import qualified Data.Map.Lazy as Map
+
+type Password = Map.Map Integer Char
+
+input = "cxdnnyjw"
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+
+part1 :: IO ()
+part1 = do
+ putStrLn $ take 8 [h!!5 | h <- filter (interesting) $ md5sequence input 0]
+
+part2 :: IO ()
+part2 = do
+ putStrLn $ Map.foldr (:) [] password
+ where interestingHashes =
+ [(read [h!!5], h!!6) |
+ h <- filter (interesting) (md5sequence input 0),
+ h!!5 `elem` "01234567"]
+ password = findPassword Map.empty interestingHashes
+
+
+md5sequence :: String -> Integer -> [String]
+md5sequence key i = (md5s (Str (key ++ show i))) : (md5sequence key (i+1))
+
+interesting :: String -> Bool
+interesting hash = "00000" `isPrefixOf` hash
+
+dontReplace :: (Integer, Char) -> Password -> Password
+dontReplace (k, v) = Map.insertWith (\_ v -> v) k v
+
+findPassword :: Password -> [(Integer, Char)] -> Password
+findPassword p (c:cs)
+ | Map.size p == 8 = p
+ | otherwise = findPassword p' cs
+ where p' = dontReplace c p
--- /dev/null
+module Main(main) where
+
+import Data.List (transpose)
+import Data.Char (isLetter)
+import qualified Data.Map.Lazy as Map
+
+main :: IO ()
+main = do
+ text <- readFile "advent06.txt"
+ let message = lines text
+ part1 message
+ part2 message
+
+part1 :: [String] -> IO ()
+part1 message = do
+ print $ map (fst) $ map (mostCommon) $ map (countedLetters) $ transpose message
+
+part2 :: [String] -> IO ()
+part2 message = do
+ print $ map (fst) $ map (leastCommon) $ map (countedLetters) $ transpose message
+
+
+countedLetters :: String -> Map.Map Char Int
+countedLetters name = Map.fromListWith (+) [(c, 1) | c <- filter (isLetter) name]
+
+mostCommon = Map.foldlWithKey (mostCommonP) ('a', 0)
+
+mostCommonP (letter0, count0) letter count
+ | count > count0 = (letter, count)
+ | otherwise = (letter0, count0)
+
+leastCommon = Map.foldlWithKey (leastCommonP) ('a', maxBound :: Int)
+
+leastCommonP (letter0, count0) letter count
+ | count < count0 = (letter, count)
+ | otherwise = (letter0, count0)
\ No newline at end of file
--- /dev/null
+module Main(main) where
+
+import Data.List (transpose, maximum, minimum, sort, group)
+import Data.Tuple (swap)
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent06.txt"
+ let message = lines text
+ part1 message
+ part2 message
+
+part1 :: [String] -> IO ()
+part1 message = do
+ putStrLn $ map (snd . maximum . counts) $ transpose message
+
+part2 :: [String] -> IO ()
+part2 message = do
+ putStrLn $ map (snd . minimum . counts) $ transpose message
+
+counts :: (Eq a, Ord a) => [a] -> [(Int, a)]
+counts = map (\g -> (length g, head g)) . group . sort
\ No newline at end of file
--- /dev/null
+module Main(main) where
+
+import Text.Parsec
+import Data.List (partition, union, intersect, tails)
+import Data.Char (isAlphaNum)
+
+data Chunk = Include String | Exclude String deriving (Show)
+data ChunkV = Includev Bool | Excludev Bool deriving (Show)
+
+chunkValue :: Chunk -> String
+chunkValue (Include v) = v
+chunkValue (Exclude v) = v
+
+isInclude :: Chunk -> Bool
+isInclude (Include _) = True
+isInclude (Exclude _) = False
+
+chunkValueV :: ChunkV -> Bool
+chunkValueV (Includev v) = v
+chunkValueV (Excludev v) = v
+
+isIncludeV :: ChunkV -> Bool
+isIncludeV (Includev _) = True
+isIncludeV (Excludev _) = False
+
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent07.txt"
+ part1 text
+ part2 text
+
+
+part1 :: String -> IO ()
+part1 text = do
+ print $ length $ filter (allowsAbba) $ successfulParse $ parseI7vf text
+
+
+part2 :: String -> IO ()
+part2 text = do
+ print $ length $ filter (supportsSSL) $ successfulParse $ parseI7f text
+
+allowsAbba :: [ChunkV] -> Bool
+allowsAbba chunks = (any (chunkValueV) includeChunks) && (not (any (chunkValueV) excludeChunks))
+ where (includeChunks, excludeChunks) = partition (isIncludeV) chunks
+
+i7file = i7line `endBy` newline
+i7line = many1 (includeChunk <|> excludeChunk)
+
+chunk = many1 alphaNum
+
+excludeChunk = Exclude <$> (between (char '[') (char ']') $ chunk)
+includeChunk = Include <$> chunk
+
+hasABBA = preambleAbba <* (many alphaNum)
+preambleAbba = (try abba) <|> (alphaNum >> preambleAbba)
+
+-- abba =
+-- do a <- alphaNum
+-- b <- alphaNum
+-- if a == b then
+-- fail "Identical"
+-- else do char b
+-- char a
+-- return [a, b, b, a]
+
+abba =
+ do a <- alphaNum
+ b <- noneOf [a]
+ char b
+ char a
+ return [a, b, b, a]
+
+-- where
+-- firstChar = satisfy (\a -> isLetter a || a == '_')
+-- nonFirstChar = satisfy (\a -> isDigit a || isLetter a || a == '_')
+
+ -- b <- bChar
+-- where bChar = satisfy (\l -> lsLetter l && l /= a)
+
+
+
+i7filev = i7linev `endBy` newline
+i7linev = many1 (includeChunkv <|> excludeChunkv)
+
+excludeChunkv = Excludev <$> (between (char '[') (char ']') $ hasABBAv)
+includeChunkv = Includev <$> hasABBAv
+
+hasABBAv =
+ (try (id True <$ preambleAbba <* (many alphaNum)))
+ <|>
+ (id False <$ (many1 alphaNum))
+
+
+parseI7f :: String -> Either ParseError [[Chunk]]
+parseI7f input = parse i7file "(unknown)" input
+
+parseI7 :: String -> Either ParseError [Chunk]
+parseI7 input = parse i7line "(unknown)" input
+
+parseAbba :: String -> Either ParseError String
+parseAbba input = parse hasABBA "(unknown)" input
+
+parseI7v :: String -> Either ParseError [ChunkV]
+parseI7v input = parse i7linev "(unknown)" input
+
+parseI7vf :: String -> Either ParseError [[ChunkV]]
+parseI7vf input = parse i7filev "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
+
+
+allSubstrings :: Int -> [a] -> [[a]]
+-- allSubstrings n es
+-- | length es < n = []
+-- | otherwise = (take n es) : (allSubstrings n $ tail es)
+allSubstrings n e = filter (\s -> length s == n) $ map (take n) $ tails e
+
+
+ieCandidates :: [Chunk] -> ([String], [String])
+ieCandidates chunks = (includeCandidates, excludeCandidates)
+ where (includeChunks, excludeChunks) = partition (isInclude) chunks
+ isABA s = (s!!0 == s!!2) && (s!!0 /= s!!1)
+ candidates = (filter (isABA)) . (foldl (union) []) . (map ((allSubstrings 3) . chunkValue))
+ includeCandidates = candidates includeChunks
+ excludeCandidates = candidates excludeChunks
+
+inverseABA :: String -> String
+inverseABA s = [s!!1, s!!0, s!!1]
+
+supportsSSL :: [Chunk] -> Bool
+supportsSSL chunks = not $ null $ intersect abas eabas
+ where (abas, babs) = ieCandidates chunks
+ eabas = map (inverseABA) babs
--- /dev/null
+module Main(main) where
+
+import Data.Array.IArray
+import Text.Parsec
+import Control.Monad (liftM, ap)
+
+-- Row 1 is top, column 1 is left
+type Position = (Int, Int)
+type Screen = Array Position Bool
+
+data Direction = Row | Column deriving (Show)
+data Command = Rect Int Int | Rotate Direction Int Int deriving (Show)
+
+data ScState a = ScState (Screen -> (Screen, a))
+
+mkScreen :: Int -> Int -> Screen
+mkScreen w h = array ((0, 0), (h - 1, w - 1))
+ [((i, j), False) | i <- [0..(h-1)], j <- [0..(w-1)]]
+
+showScreen :: Screen -> String
+showScreen screen = unlines [showRow r | r <- [minRow..maxRow]]
+ where ((minRow, minCol), (maxRow, maxCol)) = bounds screen
+ showCell True = '*'
+ showCell False = ' '
+ showRow r = [showCell (screen!(r, c)) | c <- [minCol..maxCol]]
+
+countLights :: Screen -> Int
+countLights screen = length $ filter (id) $ elems screen
+
+screen0 :: Screen
+screen0 = mkScreen 50 6
+
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent08.txt"
+ let instrs = successfulParse $ parseCommands text
+ part1 instrs
+ part2 instrs
+
+part1 :: [Command] -> IO ()
+part1 commands =
+ print $ countLights $ (extractScreen . doCommands) commands
+
+part2 :: [Command] -> IO ()
+part2 commands =
+ putStrLn $ showScreen $ (extractScreen . doCommands) commands
+
+
+instance Functor ScState where
+ fmap = liftM
+
+instance Applicative ScState where
+ pure = return
+ (<*>) = ap
+
+instance Monad ScState where
+ return x = ScState (\screen -> (screen, x))
+
+ (ScState st) >>= f
+ = ScState (\screen -> let
+ (newScreen, y) = st screen
+ (ScState transformer) = f y
+ in
+ transformer newScreen)
+
+doCommands :: [Command] -> ScState (Int)
+doCommands [] = return 0
+doCommands (i:is) =
+ do doCommand i
+ doCommands is
+ return 0
+
+doCommand :: Command -> ScState Int
+doCommand i = ScState (execute i)
+
+execute :: Command -> (Screen -> (Screen, Int))
+execute (Rect w h) screen = (rect screen w h, 0)
+execute (Rotate Column c n) screen = (rotateColumn screen c n, 0)
+execute (Rotate Row r n) screen = (rotateRow screen r n, 0)
+
+extractScreen :: ScState Int -> Screen
+extractScreen (ScState st) = fst (st screen0)
+
+
+
+parseCommands :: String -> Either ParseError [Command]
+parseCommands input = parse commandFile "(unknown)" input
+
+commandFile = commandLine `endBy` newline
+commandLine = (try rectCommand) <|> rotateCommand
+
+rectCommand =
+ do string "rect"
+ spaces
+ w <- (many1 digit)
+ char 'x'
+ h <- (many1 digit)
+ return (Rect (read w) (read h))
+
+rotateCommand =
+ do string "rotate"
+ spaces
+ direction <- (string "row" <|> string "column")
+ spaces
+ string "x=" <|> string "y="
+ index <- (many1 digit)
+ spaces
+ string "by"
+ spaces
+ distance <- (many1 digit)
+ return (buildCommand direction index distance)
+
+buildCommand "row" i d = Rotate Row (read i) (read d)
+buildCommand "column" i d = Rotate Column (read i) (read d)
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
+
+
+
+
+rect :: Screen -> Int -> Int -> Screen
+rect screen w h = screen // newBits
+ where newBits = [((i, j), True) | i <- [0..(h-1)], j <- [0..(w-1)]]
+
+rotateColumn :: Screen -> Int -> Int -> Screen
+rotateColumn screen column givenShift = screen // newCells
+ where
+ ((minRow, minCol), (maxRow, maxCol)) = bounds screen
+ colLength = 1 + maxRow - minRow
+ shift = givenShift `mod` colLength
+ offset = colLength - shift
+ column0 = [screen!(r, column) | r <- [minRow..maxRow]]
+ newColumn = (drop offset column0) ++ (take offset column0)
+ newCells = [((r, column), cell) | (r, cell) <- zip [minRow..maxRow] newColumn]
+
+rotateRow :: Screen -> Int -> Int -> Screen
+rotateRow screen row givenShift = screen // newCells
+ where
+ ((minRow, minCol), (maxRow, maxCol)) = bounds screen
+ rowLength = 1 + maxCol - minCol
+ shift = givenShift `mod` rowLength
+ offset = rowLength - shift
+ row0 = [screen!(row, c) | c <- [minCol..maxCol]]
+ newRow = (drop offset row0) ++ (take offset row0)
+ newCells = [((row, c), cell) | (c, cell) <- zip [minCol..maxCol] newRow]
--- /dev/null
+module Main(main) where
+
+import Data.List.Split (splitOn)
+import Data.Char (isSpace)
+
+type Chunk = (Int, String)
+
+main :: IO ()
+main = do
+ textL <- readFile "data/advent09.txt"
+ let text = filter (not . isSpace) textL
+ part1 text
+ part2 text
+
+part1 :: String -> IO ()
+part1 text = do
+ print $ cLength $ decompress text
+
+part2 :: String -> IO ()
+part2 text = do
+ print $ cLength $ decompress2 text
+
+
+decompress :: String -> [Chunk]
+decompress text =
+ if not (null msuf)
+ then (1, pre):(num, chunk):drest
+ else [(1, pre)]
+ where
+ (pre, msuf) = span ('(' /= ) text
+ (marker, suf) = span (')' /= ) msuf
+ ln = splitOn "x" (tail marker)
+ len = read (ln!!0) :: Int
+ num = read (ln!!1) :: Int
+ (chunk, remainder) = splitAt len (tail suf)
+ drest = decompress remainder
+
+decompress2 :: String -> [Chunk]
+decompress2 text =
+ if not (null msuf)
+ then [(1, pre)] ++ mulDchunks ++ drest
+ else [(1, pre)]
+ where
+ (pre, msuf) = span ('(' /= ) text
+ (marker, suf) = span (')' /= ) msuf
+ ln = splitOn "x" (tail marker)
+ len = read (ln!!0) :: Int
+ num = read (ln!!1) :: Int
+ (chunk, remainder) = splitAt len (tail suf)
+ dchunks = decompress2 chunk
+ mulDchunks = [(dl * num, ds) | (dl, ds) <- dchunks]
+ drest = decompress2 remainder
+
+cLength :: [Chunk] -> Int
+cLength = sum . map (clen)
+ where clen (n, t) = n * (length t)
+
--- /dev/null
+import Text.Parsec hiding (State)
+import Data.Text (pack, unpack, toTitle)
+import Control.Monad.State.Lazy
+import Data.List (partition, findIndices, sort, find)
+import Data.Maybe (fromJust)
+
+data Destination = Bot | Output deriving (Show, Read, Eq)
+-- Rule bot low-destination high-destination
+-- Gift bot value
+data Instruction = Rule { ruleId :: Int
+ , lowDestType :: Destination
+ , lowDestId :: Int
+ , highDestType :: Destination
+ , highDestId :: Int
+ } |
+ Gift { giftId :: Int
+ , value :: Int
+ }
+ deriving (Show)
+
+-- bod id [item1, item2]
+data Place = Place { placeId :: Int
+ , placeType :: Destination
+ , items :: [Int]}
+ deriving (Show)
+
+-- delivery by bot of low-value and high-value
+data Event = Delivery { deliveryId :: Int
+ , lowDelivery :: Int
+ , highDelivery :: Int
+ } |
+ Update { updateId :: Int
+ , updateType :: Destination
+ , updateItem :: Int
+ } deriving (Show)
+
+type Factory = ([Place], [Instruction], [Event])
+-- data FactorySt History = FactorySt (Factory -> (Factory, History))
+
+emptyFactory :: Factory
+emptyFactory = ([], [], [])
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent10.txt"
+ let instructions = successfulParse $ parseIfile text
+ part1 instructions
+ part2 instructions
+
+
+part1 :: [Instruction] -> IO ()
+part1 instructions =
+ do let (_, _, events) = snd $ runState (runFactory instructions) emptyFactory
+ -- let (places, instructions, events) = snd finalFactory
+ print $ deliveryId $ fromJust $ findDelivery events 17 61
+
+part2 :: [Instruction] -> IO ()
+part2 instructions =
+ do let (places, _, _) = snd $ runState (runFactory instructions) emptyFactory
+ let outs = findOutputs places [0, 1, 2]
+ let product = foldl1 (*) $ concatMap (items) outs
+ print $ product
+
+
+findDelivery :: [Event] -> Int -> Int -> Maybe Event
+findDelivery events lowItem highItem = find (delivery) events
+ where delivery Update {} = False
+ delivery Delivery {deliveryId = bot, lowDelivery = l, highDelivery = h}
+ | l == lowItem && h == highItem = True
+ | otherwise = False
+
+findOutputs :: [Place] -> [Int] -> [Place]
+findOutputs outputs ids = filter (interesting) outputs
+ where interesting Place {placeId = p, placeType = t, items = i}
+ | (p `elem` ids) && t == Output = True
+ | otherwise = False
+
+
+runFactory :: [Instruction] -> State Factory ()
+runFactory instructions = do
+ addInstructions instructions
+ runInstructions instructions
+
+
+
+instructionFile = instructionLine `endBy` newline
+instructionLine = ruleL <|> giftL
+
+
+ruleL =
+ do (string "bot" >> spaces)
+ bot <- many1 digit
+ (spaces >> string "gives low to" >> spaces)
+ lowDestType <- (string "output" <|> string "bot")
+ spaces
+ lowDest <- many1 digit
+ (spaces >> string "and high to" >> spaces)
+ highDestType <- (string "output" <|> string "bot")
+ spaces
+ highDest <- many1 digit
+ let rule = Rule (read bot)
+ (read $ unpack $ toTitle $ pack lowDestType)
+ (read lowDest)
+ (read $ unpack $ toTitle $ pack highDestType)
+ (read highDest)
+ return rule
+
+giftL =
+ do (string "value" >> spaces)
+ value <- many1 digit
+ (spaces >> string "goes to bot" >> spaces)
+ bot <- many1 digit
+ let gift = Gift (read bot) (read value)
+ return gift
+
+
+parseIfile :: String -> Either ParseError [Instruction]
+parseIfile input = parse instructionFile "(unknown)" input
+
+parseIline :: String -> Either ParseError Instruction
+parseIline input = parse instructionLine "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
+
+
+
+
+addInstructions :: [Instruction] -> State Factory ()
+addInstructions [] = return ()
+addInstructions (i:is) = do
+ addInstruction i
+ addInstructions is
+
+
+addInstruction :: Instruction -> State Factory ()
+addInstruction r@(Rule {lowDestType = ld, lowDestId = li,
+ highDestType = hd, highDestId = hi}) =
+ do (places, rules, history) <- get
+ put (places, r:rules, history)
+ addPlace (Place {placeType = ld, placeId = li, items = []})
+ addPlace (Place {placeType = hd, placeId = hi, items = []})
+addInstruction Gift {giftId = g} =
+ do addPlace (Place {placeType = Bot, placeId = g, items = []})
+
+
+addPlace :: Place -> State Factory ()
+addPlace place =
+ do (places, rules, history) <- get
+ if not $ placeElem place places
+ then put ((place:places), rules, history)
+ else return ()
+
+
+runInstructions :: [Instruction] -> State Factory ()
+runInstructions [] = return ()
+runInstructions (i:is) =
+ do runInstruction i
+ runInstructions is
+
+
+runInstruction :: Instruction -> State Factory ()
+runInstruction Rule {} = return ()
+runInstruction g@(Gift {}) =
+ do updatePlace (giftId g) Bot (value g)
+ propogateUpdates
+
+updatePlace :: Int -> Destination -> Int -> State Factory ()
+updatePlace b d i =
+ do (places, instructions, events) <- get
+ let (place0s, otherPlaces) = partition (samePlace (Place {placeId = b, placeType = d, items = []})) places
+ let place = head place0s
+ let place' = place {items = i:(items place)}
+ let update = Update {updateId = b, updateType = d, updateItem = i}
+ put (place':otherPlaces, instructions, update:events)
+
+
+propogateUpdates :: State Factory ()
+propogateUpdates =
+ do (places, instructions, events) <- get
+ let (fullBots, otherPlaces) = fullRobots places
+ if (not . null) fullBots
+ then do let fullBot = head fullBots
+ let maybeRule = findRule instructions (placeId fullBot)
+ case maybeRule of
+ Nothing -> propogateUpdates
+ Just rule -> do let small:large:_ = sort $ items fullBot
+ let emptyBot = fullBot {items = []}
+ let delivery = Delivery { deliveryId = placeId fullBot
+ , lowDelivery = small
+ , highDelivery = large
+ }
+ put (emptyBot:(tail fullBots) ++ otherPlaces,
+ instructions,
+ delivery:events)
+ updatePlace (lowDestId rule) (lowDestType rule) small
+ updatePlace (highDestId rule) (highDestType rule) large
+ propogateUpdates
+ else return ()
+
+
+placeElem :: Place -> [Place] -> Bool
+placeElem place places = (not . null) $ findIndices (samePlace place) places
+
+samePlace :: Place -> Place -> Bool
+samePlace p1 p2 = (placeId p1 == placeId p2) && (placeType p1 == placeType p2)
+
+fullRobots :: [Place] -> ([Place], [Place])
+fullRobots places = partition (\p -> placeType p == Bot && length (items p) >= 2) places
+
+findRule :: [Instruction] -> Int -> Maybe Instruction
+findRule instructions bot = find ruleForBot instructions
+ where ruleForBot Gift {} = False
+ ruleForBot Rule {ruleId = b}
+ | b == bot = True
+ | otherwise = False
--- /dev/null
+module Main(main) where
+
+import Data.List (subsequences, (\\), sort, sortBy)
+import Data.Ord (comparing)
+
+data Item = Generator String | Microchip String deriving (Show, Eq)
+type Floor = [Item]
+data Building = Building Int [Floor] deriving (Show, Eq)
+
+instance Ord Item where
+ compare (Generator a) (Generator b) = compare a b
+ compare (Microchip a) (Microchip b) = compare a b
+ compare (Generator _) (Microchip _) = LT
+ compare (Microchip _) (Generator _) = GT
+
+instance Ord Building where
+ compare b1 b2 = comparing estimateCost b1 b2
+
+building1 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+building2 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
+ Generator "elerium", Microchip "elerium",
+ Generator "dilithium", Microchip "dilithium"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+
+buildingTest = Building 0 [
+ sort([Microchip "hydrogen", Microchip "lithium"]),
+ [Generator "hydrogen"],
+ [Generator "lithium"],
+ []]
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+
+part1 :: IO ()
+-- part1 = print $ length $ init $ extractJust $ hillClimb [[buildingTest]] []
+part1 = print $ length $ init $ extractJust $ hillClimb [[building1]] []
+-- part1 = print $ length $ init $ extractJust $ aStar [[building1]] []
+
+part2 :: IO ()
+part2 = print $ length $ init $ extractJust $ hillClimb [[building2]] []
+
+
+extractJust :: Maybe [a] -> [a]
+extractJust Nothing = []
+extractJust (Just x) = x
+
+hillClimb :: [[Building]] -> [Building] -> Maybe [Building]
+hillClimb [] _ = Nothing
+hillClimb (currentTrail:trails) closed =
+ if isGoal (head currentTrail) then Just currentTrail
+ else hillClimb newAgenda ((head currentTrail): closed)
+ where newAgenda =
+ sortBy (\t1 t2 -> (head t1) `compare` (head t2)) $
+ trails ++ (candidates currentTrail closed)
+
+aStar :: [[Building]] -> [Building] -> Maybe [Building]
+aStar [] _ = Nothing
+aStar (currentTrail:trails) closed =
+ if isGoal (head currentTrail) then Just currentTrail
+ else aStar newAgenda ((head currentTrail): closed)
+ where newAgenda =
+ sortBy (\t1 t2 -> (trailCost t1) `compare` (trailCost t2)) $
+ trails ++ (candidates currentTrail closed)
+ trailCost t = estimateCost (head t) + length t - 1
+
+
+candidates :: [Building] -> [Building] -> [[Building]]
+candidates currentTrail closed = newCandidates
+ where
+ (candidate:trail) = currentTrail
+ succs = legalSuccessors $ successors candidate
+ nonloops = (succs \\ trail) \\ closed
+ newCandidates = map (\n -> n:candidate:trail) nonloops
+
+isGoal :: Building -> Bool
+isGoal (Building f floors) =
+ f+1 == height && (all (null) $ take f floors)
+ where height = length floors
+
+isLegal :: Building -> Bool
+isLegal (Building f floors) =
+ null floor
+ ||
+ not (any (isGenerator) floor)
+ ||
+ any (safePair) pairs
+ where floor = floors!!f
+ pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
+ safePair (Generator e, Microchip f) = e == f
+ safePair (Generator _, Generator _) = False
+
+isGenerator :: Item -> Bool
+isGenerator (Generator _) = True
+isGenerator (Microchip _) = False
+
+successors :: Building -> [Building]
+successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
+ where
+ floor = floors!!f
+ items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
+ nextFloors = if f == 0 then [1]
+ else if f+1 == length floors then [f-1]
+ else [f+1, f-1]
+
+legalSuccessors :: [Building] -> [Building]
+legalSuccessors = filter (isLegal)
+
+updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
+updateBuilding oldF oldFloors newF items = Building newF newFloors
+ where newFloors = map (updateFloor) $ zip [0..] oldFloors
+ updateFloor (f, fl)
+ | f == oldF = sort $ fl \\ items
+ | f == newF = sort $ items ++ fl
+ | otherwise = fl
+
+estimateCost :: Building -> Int
+estimateCost (Building _ floors) =
+ sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
+
--- /dev/null
+-- Using the idea of canonical representation of buildings from
+-- https://andars.github.io/aoc_day11.html by Andrew Foote,
+-- plus my extension of represening the pairs as an integer.
+
+-- This version is A* search, using a list for the agenda.
+
+module Main(main) where
+
+import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
+import Data.Ord (comparing)
+import Data.Char (isDigit)
+
+data Item = Generator String | Microchip String deriving (Show, Eq)
+type Floor = [Item]
+data Building = Building Int [Floor] deriving (Show, Eq)
+data CBuilding = CBuilding Int Integer deriving (Show, Eq)
+data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int}
+
+instance Ord Item where
+ compare (Generator a) (Generator b) = compare a b
+ compare (Microchip a) (Microchip b) = compare a b
+ compare (Generator _) (Microchip _) = LT
+ compare (Microchip _) (Generator _) = GT
+
+instance Ord Building where
+ compare b1 b2 = comparing estimateCost b1 b2
+
+building1 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+building0 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+building2 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
+ Generator "elerium", Microchip "elerium",
+ Generator "dilithium", Microchip "dilithium"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+
+buildingTest = Building 0 [
+ sort([Microchip "hydrogen", Microchip "lithium"]),
+ [Generator "hydrogen"],
+ [Generator "lithium"],
+ []]
+
+canonical :: Building -> CBuilding
+canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
+ where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
+ floorOf (Generator g) = head (findIndices
+ (\fl -> (Generator g) `elem` fl)
+ floors)
+ floorOf (Microchip g) = head (findIndices
+ (\fl -> (Microchip g) `elem` fl)
+ floors)
+ pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
+
+
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+
+part1 :: IO ()
+part1 = print $ length $ trail $ aStar (initAgenda building1) []
+
+part2 :: IO ()
+part2 = print $ length $ trail $aStar (initAgenda building2) []
+
+initAgenda :: Building -> [Agendum]
+initAgenda b = [Agendum {current = b, trail=[], cost = estimateCost b}]
+
+
+aStar :: [Agendum] -> [CBuilding] -> Agendum
+aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
+aStar (currentAgendum:agenda) closed =
+ if isGoal reached then currentAgendum
+ else if creached `elem` closed
+ then aStar agenda closed
+ else aStar newAgenda (creached:closed)
+ where
+ reached = current currentAgendum
+ creached = canonical reached
+ newAgenda =
+ sortOn (cost) $
+ agenda ++ (candidates currentAgendum closed)
+
+
+candidates :: Agendum -> [CBuilding] -> [Agendum]
+candidates agendum closed = newCandidates
+ where
+ candidate = current agendum
+ previous = trail agendum
+ succs = legalSuccessors $ successors candidate
+ excludable = previous ++ closed
+ nonloops = filter (\s -> not $ (canonical s) `elem` excludable) succs
+ newCandidates = map (\n -> makeAgendum n) nonloops
+ makeAgendum new = Agendum {current = new,
+ trail = (canonical candidate):previous,
+ cost = estimateCost new + length previous + 1}
+
+isGoal :: Building -> Bool
+isGoal (Building f floors) =
+ f+1 == height && (all (null) $ take f floors)
+ where height = length floors
+
+isLegal :: Building -> Bool
+isLegal (Building f floors) =
+ null floor
+ ||
+ not (any (isGenerator) floor)
+ ||
+ any (safePair) pairs
+ where floor = floors!!f
+ pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
+ safePair (Generator e, Microchip f) = e == f
+ safePair (Generator _, Generator _) = False
+
+isGenerator :: Item -> Bool
+isGenerator (Generator _) = True
+isGenerator (Microchip _) = False
+
+successors :: Building -> [Building]
+successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
+ where
+ floor = floors!!f
+ items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
+ nextFloors = if f == 0 then [1]
+ else if f+1 == length floors then [f-1]
+ else [f+1, f-1]
+
+legalSuccessors :: [Building] -> [Building]
+legalSuccessors = filter (isLegal)
+
+updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
+updateBuilding oldF oldFloors newF items = Building newF newFloors
+ where newFloors = map (updateFloor) $ zip [0..] oldFloors
+ updateFloor (f, fl)
+ | f == oldF = sort $ fl \\ items
+ | f == newF = sort $ items ++ fl
+ | otherwise = fl
+
+estimateCost :: Building -> Int
+estimateCost (Building _ floors) =
+ sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
+
--- /dev/null
+-- Using the idea of canonical representation of buildings from
+-- https://andars.github.io/aoc_day11.html by Andrew Foote,
+-- plus my extension of represening the pairs as an integer.
+
+-- This version is hillclimbing search, using a list for the agenda.
+module Main(main) where
+
+import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
+import Data.Ord (comparing)
+import Data.Char (isDigit)
+
+data Item = Generator String | Microchip String deriving (Show, Eq)
+type Floor = [Item]
+data Building = Building Int [Floor] deriving (Show, Eq)
+data CBuilding = CBuilding Int Integer deriving (Show, Eq)
+data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int}
+
+instance Ord Item where
+ compare (Generator a) (Generator b) = compare a b
+ compare (Microchip a) (Microchip b) = compare a b
+ compare (Generator _) (Microchip _) = LT
+ compare (Microchip _) (Generator _) = GT
+
+instance Ord Building where
+ compare b1 b2 = comparing estimateCost b1 b2
+
+building1 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+building0 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+building2 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
+ Generator "elerium", Microchip "elerium",
+ Generator "dilithium", Microchip "dilithium"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+
+buildingTest = Building 0 [
+ sort([Microchip "hydrogen", Microchip "lithium"]),
+ [Generator "hydrogen"],
+ [Generator "lithium"],
+ []]
+
+canonical :: Building -> CBuilding
+canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
+ where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
+ floorOf (Generator g) = head (findIndices
+ (\fl -> (Generator g) `elem` fl)
+ floors)
+ floorOf (Microchip g) = head (findIndices
+ (\fl -> (Microchip g) `elem` fl)
+ floors)
+ pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
+
+
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+
+part1 :: IO ()
+part1 = print $ length $ trail $ hillClimb (initAgenda building1) []
+
+part2 :: IO ()
+part2 = print $ length $ trail $ hillClimb (initAgenda building2) []
+
+initAgenda :: Building -> [Agendum]
+initAgenda b = [Agendum {current = b, trail=[], cost = estimateCost b}]
+
+hillClimb :: [Agendum] -> [CBuilding] -> Agendum
+hillClimb [] _ = Agendum {current=buildingTest, trail=[], cost=0}
+hillClimb (currentAgendum:agenda) closed =
+ if isGoal reached then currentAgendum
+ else if creached `elem` closed
+ then hillClimb agenda closed
+ else hillClimb newAgenda (creached:closed)
+ where
+ reached = current currentAgendum
+ creached = canonical reached
+ newAgenda =
+ sortOn (cost) $
+ agenda ++ (candidates currentAgendum closed)
+
+
+candidates :: Agendum -> [CBuilding] -> [Agendum]
+candidates agendum closed = newCandidates
+ where
+ candidate = current agendum
+ previous = trail agendum
+ succs = legalSuccessors $ successors candidate
+ excludable = previous ++ closed
+ nonloops = filter (\s -> not $ (canonical s) `elem` excludable) succs
+ newCandidates = map (\n -> makeAgendum n) nonloops
+ makeAgendum new = Agendum {current = new,
+ trail = (canonical candidate):previous,
+ cost = estimateCost new}
+
+isGoal :: Building -> Bool
+isGoal (Building f floors) =
+ f+1 == height && (all (null) $ take f floors)
+ where height = length floors
+
+isLegal :: Building -> Bool
+isLegal (Building f floors) =
+ null floor
+ ||
+ not (any (isGenerator) floor)
+ ||
+ any (safePair) pairs
+ where floor = floors!!f
+ pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
+ safePair (Generator e, Microchip f) = e == f
+ safePair (Generator _, Generator _) = False
+
+isGenerator :: Item -> Bool
+isGenerator (Generator _) = True
+isGenerator (Microchip _) = False
+
+successors :: Building -> [Building]
+successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
+ where
+ floor = floors!!f
+ items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
+ nextFloors = if f == 0 then [1]
+ else if f+1 == length floors then [f-1]
+ else [f+1, f-1]
+
+legalSuccessors :: [Building] -> [Building]
+legalSuccessors = filter (isLegal)
+
+updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
+updateBuilding oldF oldFloors newF items = Building newF newFloors
+ where newFloors = map (updateFloor) $ zip [0..] oldFloors
+ updateFloor (f, fl)
+ | f == oldF = sort $ fl \\ items
+ | f == newF = sort $ items ++ fl
+ | otherwise = fl
+
+estimateCost :: Building -> Int
+estimateCost (Building _ floors) =
+ sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
+
--- /dev/null
+-- Using the idea of canonical representation of buildings from
+-- https://andars.github.io/aoc_day11.html by Andrew Foote,
+-- plus my extension of represening the pairs as an integer.
+
+-- This version is A* search, using a priority queue for the agenda.
+
+module Main(main) where
+
+import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
+import Data.Ord (comparing)
+import Data.Char (isDigit)
+import Data.Maybe (fromMaybe)
+import qualified Data.PQueue.Prio.Min as P
+
+data Item = Generator String | Microchip String deriving (Show, Eq)
+type Floor = [Item]
+data Building = Building Int [Floor] deriving (Show, Eq)
+data CBuilding = CBuilding Int Integer deriving (Show, Eq)
+data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int}
+type Agenda = P.MinPQueue Int Agendum
+
+instance Ord Item where
+ compare (Generator a) (Generator b) = compare a b
+ compare (Microchip a) (Microchip b) = compare a b
+ compare (Generator _) (Microchip _) = LT
+ compare (Microchip _) (Generator _) = GT
+
+instance Ord Building where
+ compare b1 b2 = comparing estimateCost b1 b2
+
+building1 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+building0 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+building2 = Building 0 [
+ (sort [Generator "polonium", Generator "thulium",
+ Microchip "thulium", Generator "promethium", Generator "ruthenium",
+ Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
+ Generator "elerium", Microchip "elerium",
+ Generator "dilithium", Microchip "dilithium"]),
+ (sort [Microchip "polonium", Microchip "promethium"]),
+ [],
+ []
+ ]
+
+
+buildingTest = Building 0 [
+ sort([Microchip "hydrogen", Microchip "lithium"]),
+ [Generator "hydrogen"],
+ [Generator "lithium"],
+ []]
+
+canonical :: Building -> CBuilding
+canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
+ where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
+ floorOf (Generator g) = head (findIndices
+ (\fl -> (Generator g) `elem` fl)
+ floors)
+ floorOf (Microchip g) = head (findIndices
+ (\fl -> (Microchip g) `elem` fl)
+ floors)
+ pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
+
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building1) []
+
+part2 :: IO ()
+part2 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building2) []
+
+initAgenda :: Building -> Agenda
+initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail=[], cost = estimateCost b}
+
+
+aStar :: Agenda -> [CBuilding] -> Maybe Agendum
+-- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
+aStar agenda closed
+ | P.null agenda = Nothing
+ | otherwise =
+ if isGoal reached then Just currentAgendum
+ else if creached `elem` closed
+ then aStar (P.deleteMin agenda) closed
+ else aStar newAgenda (creached:closed)
+ where
+ (_, currentAgendum) = P.findMin agenda
+ reached = current currentAgendum
+ creached = canonical reached
+ newAgenda = P.union (P.deleteMin agenda)
+ (P.fromList $ candidates currentAgendum closed)
+
+
+candidates :: Agendum -> [CBuilding] -> [(Int, Agendum)]
+candidates agendum closed = newCandidates
+ where
+ candidate = current agendum
+ previous = trail agendum
+ succs = legalSuccessors $ successors candidate
+ nonloops = filter (\s -> not $ (canonical s) `elem` closed) succs
+ newCandidates = map (\a -> (cost a, a)) $ map (\n -> makeAgendum n) nonloops
+ makeAgendum new = Agendum {current = new,
+ trail = (canonical candidate):previous,
+ cost = estimateCost new + length previous + 1}
+
+isGoal :: Building -> Bool
+isGoal (Building f floors) =
+ f+1 == height && (all (null) $ take f floors)
+ where height = length floors
+
+isLegal :: Building -> Bool
+isLegal (Building f floors) =
+ null floor
+ ||
+ not (any (isGenerator) floor)
+ ||
+ any (safePair) pairs
+ where floor = floors!!f
+ pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
+ safePair (Generator e, Microchip f) = e == f
+ safePair (Generator _, Generator _) = False
+
+isGenerator :: Item -> Bool
+isGenerator (Generator _) = True
+isGenerator (Microchip _) = False
+
+successors :: Building -> [Building]
+successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
+ where
+ floor = floors!!f
+ items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
+ nextFloors = if f == 0 then [1]
+ else if f+1 == length floors then [f-1]
+ else [f+1, f-1]
+
+legalSuccessors :: [Building] -> [Building]
+legalSuccessors = filter (isLegal)
+
+updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
+updateBuilding oldF oldFloors newF items = Building newF newFloors
+ where newFloors = map (updateFloor) $ zip [0..] oldFloors
+ updateFloor (f, fl)
+ | f == oldF = sort $ fl \\ items
+ | f == newF = sort $ items ++ fl
+ | otherwise = fl
+
+estimateCost :: Building -> Int
+estimateCost (Building _ floors) =
+ sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
+
--- /dev/null
+module Main(main) where
+
+import Text.Parsec hiding (State)
+import Text.ParserCombinators.Parsec.Number
+import Data.List (partition, union, intersect, tails)
+import Data.Char (isDigit)
+import Control.Monad.State.Lazy
+
+data Location = Literal Int | Register Char deriving (Show)
+data Instruction = Cpy Location Location |
+ Inc Location |
+ Dec Location |
+ Jnz Location Int
+ deriving (Show)
+
+data Machine = Machine { a :: Int
+ , b :: Int
+ , c :: Int
+ , d :: Int
+ , pc :: Int
+ , instructions :: [Instruction]}
+ deriving (Show)
+
+emptyMachine :: Machine
+emptyMachine = Machine {a=0, b=0, c=0, d=0, pc=0, instructions=[]}
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent12.txt"
+ let instructions = successfulParse $ parseIfile text
+ part1 instructions
+ part2 instructions
+
+
+part1 :: [Instruction] -> IO ()
+part1 instrs =
+ do let m0 = emptyMachine {instructions=instrs}
+ let mf = snd $ runState runMachine m0
+ print (a mf)
+
+part2 :: [Instruction] -> IO ()
+part2 instrs =
+ do let m0 = emptyMachine {instructions=instrs, c=1}
+ let mf = snd $ runState runMachine m0
+ print (a mf)
+
+
+
+runMachine :: State Machine ()
+runMachine =
+ do m <- get
+ if (pc m) >= (length $ instructions m)
+ then return ()
+ else do executeStep
+ runMachine
+
+executeStep :: State Machine ()
+executeStep =
+ do m <- get
+ let i = (instructions m)!!(pc m)
+ put (executeInstruction i m)
+
+executeInstruction :: Instruction -> Machine -> Machine
+executeInstruction (Inc (Register r)) m = m' {pc=pc1}
+ where pc1 = (pc m) + 1
+ v = evaluate m (Register r)
+ m' = writeValue m (Register r) (v+1)
+executeInstruction (Dec (Register r)) m = m' {pc=pc1}
+ where pc1 = (pc m) + 1
+ v = evaluate m (Register r)
+ m' = writeValue m (Register r) (v-1)
+executeInstruction (Cpy s d) m = m' {pc=pc1}
+ where pc1 = (pc m) + 1
+ v = evaluate m s
+ m' = writeValue m d v
+executeInstruction (Jnz s d) m
+ | v == 0 = m {pc=pc1}
+ | otherwise = m {pc=pcj}
+ where pc1 = (pc m) + 1
+ pcj = (pc m) + d
+ v = evaluate m s
+
+
+evaluate :: Machine -> Location -> Int
+evaluate _ (Literal i) = i
+evaluate m (Register r) =
+ case r of
+ 'a' -> (a m)
+ 'b' -> (b m)
+ 'c' -> (c m)
+ 'd' -> (d m)
+
+writeValue :: Machine -> Location -> Int -> Machine
+writeValue m (Literal i) _ = m
+writeValue m (Register r) v =
+ case r of
+ 'a' -> m {a=v}
+ 'b' -> m {b=v}
+ 'c' -> m {c=v}
+ 'd' -> m {d=v}
+
+
+instructionFile = instructionLine `endBy` newline
+-- instructionLine = choice [cpyL, incL, decL, jnzL]
+instructionLine = incL <|> decL <|> cpyL <|> jnzL
+
+incL = incify <$> (string "inc" *> spaces *> (oneOf "abcd"))
+ where incify r = Inc (Register r)
+decL = decify <$> (string "dec" *> spaces *> (oneOf "abcd"))
+ where decify r = Dec (Register r)
+cpyL = cpyify <$> (string "cpy" *> spaces *> ((many1 letter) <|> (many1 digit)))
+ <*> (spaces *> (oneOf "abcd"))
+ where cpyify s r = Cpy (readLocation s) (Register r)
+jnzL = jnzify <$> (string "jnz" *> spaces *> ((many1 letter) <|> (many1 digit)))
+ <*> (spaces *> int)
+ where jnzify r d = Jnz (readLocation r) d
+
+
+readLocation :: String -> Location
+readLocation l
+ | all (isDigit) l = Literal (read l)
+ | otherwise = Register (head l)
+
+
+
+parseIfile :: String -> Either ParseError [Instruction]
+parseIfile input = parse instructionFile "(unknown)" input
+
+parseIline :: String -> Either ParseError Instruction
+parseIline input = parse instructionLine "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
\ No newline at end of file
--- /dev/null
+module Main(main) where
+
+import Data.List ((\\), nub, sortOn)
+import Data.Bits (popCount)
+import Data.Maybe (fromMaybe)
+
+type Pos = (Int, Int)
+
+seed = 1362
+
+goal1 = (31, 39)
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+
+part1 :: IO ()
+part1 = print $ length $ tail $ fromMaybe [] $ aStar [[(1, 1)]] []
+
+part2 :: IO ()
+part2 = do print $ length $ tail $ edl 50 [[(1, 1)]] []
+ putStrLn $ showRoomR 30 25 $ edl 50 [[(1, 1)]] []
+
+
+-- extractJust :: Maybe [a] -> [a]
+-- extractJust Nothing = []
+-- extractJust (Just x) = x
+
+isWall :: Int -> Int -> Bool
+isWall x y = odd $ popCount n
+ where
+ n = x*x + 3*x + 2*x*y + y + y*y + seed
+
+
+showRoom w h = showRoomR w h []
+
+showRoomR w h reached = unlines rows
+ where
+ rows = [row x | x <- [0..h]]
+ row x = [showCell x y | y <- [0..w]]
+ showCell x y = if (isWall x y)
+ then '#'
+ else if (x, y) `elem` reached
+ then 'O'
+ else '.'
+
+
+aStar :: [[Pos]] -> [Pos] -> Maybe [Pos]
+aStar [] _ = Nothing
+aStar (currentTrail:trails) closed =
+ if isGoal (head currentTrail) then Just currentTrail
+ else if (head currentTrail) `elem` closed then aStar trails closed
+ else aStar newAgenda ((head currentTrail): closed)
+ where newAgenda =
+ sortOn (\a -> trailCost a) $
+ trails ++ (candidates currentTrail closed)
+ trailCost t = estimateCost (head t) + length t - 1
+
+
+-- exhaustive depth-limited
+edl :: Int -> [[Pos]] -> [Pos] -> [Pos]
+edl _ [] closed = nub closed
+edl limit (currentTrail:trails) closed =
+ if (length currentTrail) > (limit+1) then edl limit trails ((head currentTrail):closed)
+ else if (head currentTrail) `elem` closed then edl limit trails closed
+ else edl limit newAgenda ((head currentTrail):closed)
+ where newAgenda = trails ++ (candidates currentTrail closed)
+
+candidates :: [Pos] -> [Pos] -> [[Pos]]
+candidates currentTrail closed = newCandidates
+ where
+ (candidate:trail) = currentTrail
+ succs = legalSuccessors $ successors candidate
+ nonloops = (succs \\ trail) \\ closed
+ newCandidates = map (\n -> n:candidate:trail) nonloops
+
+isGoal :: Pos -> Bool
+isGoal p = p == goal1
+
+isLegal :: Pos -> Bool
+isLegal (x, y) =
+ x >= 0 && y >= 0 && (not $ isWall x y)
+
+successors :: Pos -> [Pos]
+successors (x, y) = [(x-1, y), (x+1, y), (x, y-1), (x, y+1)]
+
+legalSuccessors :: [Pos] -> [Pos]
+legalSuccessors = filter (isLegal)
+
+estimateCost :: Pos -> Int
+estimateCost (x, y) = abs (x - gx) + abs (y - gy)
+ where (gx, gy) = goal1
+
--- /dev/null
+module Main(main) where
+
+import Data.List (nub, tails, null)
+import Data.Hash.MD5 (md5s, Str(..))
+
+salt = "yjdafjpo"
+-- salt = "abc"
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
+ where sq = md5sequence
+
+part2 :: IO ()
+part2 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
+ where sq = md5sequenceS
+
+md5sequence :: [String]
+md5sequence = [makeMd5 i | i <- [0..]]
+ where makeMd5 i = md5s (Str (salt ++ show i))
+
+md5sequenceS :: [String]
+md5sequenceS = [makeMd5 i | i <- [0..]]
+ where makeMd5 i = stretch $ md5s (Str (salt ++ show i))
+ stretch h0 = foldr (\_ h -> md5s (Str h)) h0 [1..2016]
+
+possibleKey :: [String] -> Int-> Bool
+possibleKey s = not . null . repeats 3 . ((!!) s)
+
+confirmKey :: [String] -> Int -> Bool
+confirmKey s i = any (confirmation) $ take 1000 $ drop (i+1) s
+ where c = head $ repeats 3 $ s!!i
+ confirmation m = c `elem` (repeats 5 m)
+
+repeats :: Int -> String -> [String]
+repeats n = filter (null . tail) . map (nub) . substrings n
+
+substrings :: Int -> [a] -> [[a]]
+substrings l = filter (\s -> (length s) == l) . map (take l) . tails
--- /dev/null
+module Main(main) where
+
+import Data.List (nub, tails)
+import Data.ByteString.Char8 (pack)
+import Crypto.Hash (hash, Digest, MD5)
+
+salt = "yjdafjpo"
+-- salt = "abc"
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
+ where sq = md5sequence
+
+part2 :: IO ()
+part2 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
+ where sq = md5sequenceS
+
+getHash :: String -> String
+getHash bs = show (hash $ pack bs :: Digest MD5)
+
+md5sequence :: [String]
+md5sequence = [makeMd5 i | i <- [0..]]
+ where makeMd5 i = getHash (salt ++ show i)
+
+md5sequenceS :: [String]
+md5sequenceS = [makeMd5 i | i <- [0..]]
+ where makeMd5 i = stretch $ getHash (salt ++ show i)
+ stretch h0 = foldr (\_ h -> getHash h) h0 [1..2016]
+
+possibleKey :: [String] -> Int-> Bool
+possibleKey s = not . null . repeats 3 . ((!!) s)
+
+confirmKey :: [String] -> Int -> Bool
+confirmKey s i = any (confirmation) $ take 1000 $ drop (i+1) s
+ where c = head $ repeats 3 $ s!!i
+ confirmation m = c `elem` (repeats 5 m)
+
+repeats :: Int -> String -> [String]
+repeats n = filter (null . tail) . map (nub) . substrings n
+
+substrings :: Int -> [a] -> [[a]]
+substrings l = filter (\s -> (length s) == l) . map (take l) . tails
--- /dev/null
+module Main(main) where
+
+import Data.List (nub, tails)
+import Data.ByteString.Char8 (pack)
+import Crypto.Hash (hash, Digest, MD5)
+import Control.Parallel.Strategies (withStrategy, parBuffer, rdeepseq)
+
+salt = "yjdafjpo"
+-- salt = "abc"
+
+stretch_factor = [1..2016]
+-- stretch_factor = [1..100]
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
+ where sq = md5sequence
+
+part2 :: IO ()
+part2 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
+ where sq = md5sequenceS
+
+getHash :: String -> String
+getHash bs = show (hash $ pack bs :: Digest MD5)
+
+md5sequence :: [String]
+-- md5sequence = [makeMd5 i | i <- [0..]]
+md5sequence = withStrategy (parBuffer 100 rdeepseq) $ map (makeMd5) [0..]
+ where makeMd5 i = getHash (salt ++ show i)
+
+md5sequenceS :: [String]
+-- md5sequenceS = [makeMd5 i | i <- [0..]]
+md5sequenceS = withStrategy (parBuffer 100 rdeepseq) $ map (makeMd5) [0..]
+ where makeMd5 i = stretch $ getHash (salt ++ show i)
+ stretch h0 = foldr (\_ h -> getHash h) h0 stretch_factor
+
+possibleKey :: [String] -> Int-> Bool
+possibleKey s = not . null . repeats 3 . ((!!) s)
+
+confirmKey :: [String] -> Int -> Bool
+confirmKey s i = any (confirmation) $ take 1000 $ drop (i+1) s
+ where c = head $ repeats 3 $ s!!i
+ confirmation m = c `elem` (repeats 5 m)
+
+repeats :: Int -> String -> [String]
+repeats n = filter (null . tail) . map (nub) . substrings n
+
+substrings :: Int -> [a] -> [[a]]
+substrings l = filter (\s -> (length s) == l) . map (take l) . tails
--- /dev/null
+module Main(main) where
+
+import Text.Parsec
+import Text.ParserCombinators.Parsec.Number
+
+type Disk = (Int -> Bool)
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent15.txt"
+ let disks = successfulParse $ parseIfile text
+ part1 disks
+ part2 disks
+
+part1 :: [Disk] -> IO ()
+part1 disks = print $ head $ filter (canFall disks) [0..]
+
+part2 :: [Disk] -> IO ()
+part2 disks = print $ head $ filter (canFall disks2) [0..]
+ where disks2 = disks ++ [diskify 7 11 0]
+
+canFall :: [Disk] -> Int -> Bool
+canFall ds i = all (\d -> (d i)) ds
+
+
+instructionFile = instructionLine `endBy` newline
+instructionLine = diskify <$> (string "Disc #" *> int)
+ <*> (string " has " *> int)
+ <*> (string " positions; at time=0, it is at position " *> int)
+ <* (string ".")
+
+diskify :: Int -> Int -> Int -> (Int -> Bool)
+diskify n size pos0 = (\i -> (size + n + pos0 + i) `mod` size == 0)
+
+parseIfile :: String -> Either ParseError [Disk]
+parseIfile input = parse instructionFile "(unknown)" input
+
+parseIline :: String -> Either ParseError Disk
+parseIline input = parse instructionLine "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
--- /dev/null
+module Main(main) where
+
+import Text.Parsec
+import Text.ParserCombinators.Parsec.Number
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent15.txt"
+ let disks = successfulParse $ parseIfile text
+ part1 disks
+ part2 disks
+
+part1 :: [[Int]] -> IO ()
+part1 disks = print $ head $ filter (canFall disks) [0..]
+
+part2 :: [[Int]] -> IO ()
+part2 disks = print $ head $ filter (canFall disks2) [0..]
+ where disks2 = disks ++ [drop 7 $ drop 0 $ cycle [0..(11-1)]]
+
+canFall :: [[Int]] -> Int -> Bool
+canFall ds i = all (\d -> (d!!i) == 0) ds
+
+
+instructionFile = instructionLine `endBy` newline
+instructionLine = diskify <$> (string "Disc #" *> int)
+ <*> (string " has " *> int)
+ <*> (string " positions; at time=0, it is at position " *> int)
+ <* (string ".")
+ where diskify n size pos0 = drop n $ drop pos0 $ cycle [0..(size-1)]
+
+parseIfile :: String -> Either ParseError [[Int]]
+parseIfile input = parse instructionFile "(unknown)" input
+
+parseIline :: String -> Either ParseError [Int]
+parseIline input = parse instructionLine "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
--- /dev/null
+module Main(main) where
+
+import Data.List (nub)
+
+input = "11100010111110100"
+disk1length = 272
+disk2length = 35651584
+
+-- input = "10000"
+-- disk1length = 20
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = putStrLn $ checksum $ take disk1length $ expand disk1length input
+
+part2 :: IO ()
+part2 = putStrLn $ checksum $ take disk2length $ expand disk2length input
+
+
+expand :: Int -> String -> String
+expand len a
+ | length a >= len = a
+ | otherwise = expand len $ a ++ "0" ++ b
+ where b = map (invert) $ reverse a
+ invert '0' = '1'
+ invert '1' = '0'
+
+checksum :: String -> String
+checksum digits
+ | odd $ length digits = digits
+ | otherwise = checksum $ map (checksumPair) $ pairs digits
+ where checksumPair p = if (length $ nub p) == 1 then '1' else '0'
+
+
+pairs :: [a] -> [[a]]
+pairs [] = []
+pairs xs = [p] ++ (pairs ys)
+ where (p, ys) = splitAt 2 xs
--- /dev/null
+module Main(main) where
+
+input = "11100010111110100"
+disk1length = 272
+disk2length = 35651584
+
+-- input = "10000"
+-- disk1length = 20
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = print $ fill disk1length input
+
+part2 :: IO ()
+part2 = print $ fill disk2length input
+
+fill :: Int -> String -> String
+fill len filler = deBool $ checksum $ take len $ expand len $ enBool filler
+
+enBool :: String -> [Bool]
+enBool = map (== '1')
+
+deBool :: [Bool] -> String
+deBool = map (\b -> if b then '1' else '0')
+
+
+expand :: Int -> [Bool] -> [Bool]
+expand len = head . dropWhile ((<= len) . length) . iterate expandStep
+
+expandStep :: [Bool] -> [Bool]
+expandStep a = a ++ [False] ++ b
+ where b = map (not) $ reverse a
+
+checksum :: [Bool] -> [Bool]
+checksum = head . dropWhile (even . length) . iterate checksumStep
+
+checksumStep :: [Bool] -> [Bool]
+checksumStep [] = []
+checksumStep [x] = [x]
+checksumStep (x:y:xs) = (x==y):(checksumStep xs)
+
--- /dev/null
+module Main(main) where
+
+import Data.ByteString.Char8 (pack)
+import qualified Crypto.Hash as C
+
+type Position = (Int, Int)
+data Agendum = Agendum {position :: Position, path :: String, hash :: String} deriving (Show, Eq)
+type Agenda = [Agendum]
+
+-- input = "hijkl"
+-- input = "ihgpwlah"
+
+input = "qljzarfv" -- my input
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = putStrLn $ path $ extractJust $ bfs initialAgenda
+
+part2 :: IO ()
+part2 = print $ bfs2 initialAgenda 0
+
+initialAgenda :: Agenda
+initialAgenda = [Agendum {position=(1, 1), path="", hash=(getHash "")}]
+
+getHash :: String -> String
+getHash path = show (C.hash $ pack (input ++ path) :: C.Digest C.MD5)
+
+extractJust :: Maybe Agendum -> Agendum
+extractJust Nothing = head initialAgenda
+extractJust (Just x) = x
+
+bfs :: Agenda -> Maybe Agendum
+bfs [] = Nothing
+bfs (current:agenda) =
+ if isGoal current then Just current
+ else bfs (agenda ++ (successors current))
+
+bfs2 :: Agenda -> Int -> Int
+bfs2 [] l = l
+bfs2 (current:agenda) l =
+ if isGoal current then bfs2 agenda (length $ path $ current)
+ else bfs2 (agenda ++ (successors current)) l
+
+isGoal :: Agendum -> Bool
+isGoal agendum = (position agendum) == (4, 4)
+
+isLegalPos :: Position -> Bool
+isLegalPos p = fst p >= 1 && fst p <= 4 && snd p >= 1 && snd p <= 4
+
+successors :: Agendum -> Agenda
+successors state = [Agendum {position = step p0 ld,
+ path = path0 ++ [ld],
+ hash = getHash (path0 ++ [ld])} | ld <- legalDoors ]
+ where
+ p0 = position state
+ path0 = path state
+ h0 = hash state
+ doors = openDoors h0
+ legalDoors = filter (isLegalPos . (step p0)) doors
+
+openDoors :: String -> String
+openDoors h = up ++ down ++ left ++ right
+ where
+ up = if h!!0 `elem` "bcdef" then "U" else ""
+ down = if h!!1 `elem` "bcdef" then "D" else ""
+ left = if h!!2 `elem` "bcdef" then "L" else ""
+ right = if h!!3 `elem` "bcdef" then "R" else ""
+
+step :: Position -> Char -> Position
+step (r, c) 'U' = (r-1, c)
+step (r, c) 'D' = (r+1, c)
+step (r, c) 'L' = (r, c-1)
+step (r, c) 'R' = (r, c+1)
--- /dev/null
+module Main(main) where
+
+import Data.List (tails)
+
+-- input = "..^^."
+-- input = ".^^.^.^^^^"
+input = "^.^^^.^..^....^^....^^^^.^^.^...^^.^.^^.^^.^^..^.^...^.^..^.^^.^..^.....^^^.^.^^^..^^...^^^...^...^."
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+-- part1 = putStrLn $ unlines $ map (showRow) $ take 10 $ iterate nextRow $ readRow input
+part1 = print $ length $ filter (not) $ concat $ take 40 $ iterate nextRow $ readRow input
+
+part2 :: IO ()
+part2 = print $ length $ filter (not) $ concat $ take 400000 $ iterate nextRow $ readRow input
+
+readRow :: String -> [Bool]
+readRow = map (=='^')
+
+showRow :: [Bool] -> String
+showRow = map (\c -> if c then '^' else '.')
+
+extended :: [Bool] -> [Bool]
+extended row = [False] ++ row ++ [False]
+
+nextRow :: [Bool] -> [Bool]
+nextRow = map (isTrap) . segments . extended
+
+segments :: [a] -> [[a]]
+segments = filter ((==3) . length) . map (take 3) . tails
+
+isTrap :: [Bool] -> Bool
+isTrap segment
+ | segment == [True, True, False] = True
+ | segment == [False, True, True] = True
+ | segment == [True, False, False] = True
+ | segment == [False, False, True] = True
+ | otherwise = False
--- /dev/null
+module Main(main) where
+
+import Data.List (tails, foldl')
+
+-- input = "..^^."
+-- input = ".^^.^.^^^^"
+input = "^.^^^.^..^....^^....^^^^.^^.^...^^.^.^^.^^.^^..^.^...^.^..^.^^.^..^.....^^^.^.^^^..^^...^^^...^...^."
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = print $ fst $ foldl' nextRowFold (countSafe row, row) [2..40]
+ where row = readRow input
+
+part2 :: IO ()
+part2 = print $ fst $ foldl' nextRowFold (countSafe row, row) [2..400000]
+ where row = readRow input
+
+readRow :: String -> [Bool]
+readRow = map (=='^')
+
+showRow :: [Bool] -> String
+showRow = map (\c -> if c then '^' else '.')
+
+extended :: [Bool] -> [Bool]
+extended row = [False] ++ row ++ [False]
+
+nextRow :: [Bool] -> [Bool]
+nextRow = map (isTrap) . segments . extended
+
+nextRowFold :: (Int, [Bool]) -> Int -> (Int, [Bool])
+nextRowFold (n, row) _ = (n + countSafe newRow, newRow)
+ where newRow = nextRow row
+
+countSafe :: [Bool] -> Int
+countSafe = length . filter (not)
+
+segments :: [a] -> [[a]]
+segments = filter ((==3) . length) . map (take 3) . tails
+
+isTrap :: [Bool] -> Bool
+isTrap segment
+ | segment == [True, True, False] = True
+ | segment == [False, True, True] = True
+ | segment == [True, False, False] = True
+ | segment == [False, False, True] = True
+ | otherwise = False
--- /dev/null
+module Main(main) where
+
+import Prelude hiding (length, take, drop)
+import Data.Sequence
+
+-- input = 5
+input = 3012210
+
+main :: IO ()
+main = do
+ part1
+ part2
+
+part1 :: IO ()
+part1 = print $ 2 * (input - 2 ^ (toInteger (floor $ logBase 2 (fromIntegral input)))) + 1
+
+part2 :: IO ()
+part2 = print $ flip index 0 $ presentSteps initial
+
+presentSteps :: Seq Int -> Seq Int
+presentSteps elves
+ | isFinished elves = elves
+ | otherwise = presentSteps $ next elves
+
+initial :: Seq Int
+initial = fromList [1..input]
+
+isFinished :: Seq Int -> Bool
+isFinished elves = length elves == 1
+
+next :: Seq Int -> Seq Int
+next elves = prefix >< (midfix |> suffix)
+ where
+ target = length elves `quot` 2
+ prefix = drop 1 $ take target elves
+ midfix = drop (target+1) elves
+ suffix = index elves 0
--- /dev/null
+module Main(main) where
+
+import Text.Parsec
+import Text.ParserCombinators.Parsec.Number
+import Data.List (foldl')
+
+data Interval = Interval Int Int deriving (Show, Eq)
+
+low :: Interval -> Int
+low (Interval l _) = l
+
+high :: Interval -> Int
+high (Interval _ h) = h
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent20.txt"
+ let intervals = successfulParse $ parseIfile text
+ part1 intervals
+ part2 intervals
+
+part1 :: [Interval] -> IO ()
+part1 intervals = print $ (+1) $ high $ head $ foldl' (mergeAdjacent) [] $ foldl' (merge) [] intervals
+
+part2 :: [Interval] -> IO ()
+part2 intervals = do
+ let ints = foldl' (mergeAdjacent) [] $ foldl' (merge) [] intervals
+ let gapCount = gaps ints
+ let lowGap = low $ head ints
+ let highGap = 4294967295 - (high $ last ints)
+ print (lowGap + gapCount + highGap)
+
+disjoint :: Interval -> Interval -> Bool
+disjoint (Interval a b) (Interval c d)
+ | b < c = True
+ | d < a = True
+ | a > d = True
+ | c > b = True
+ | otherwise = False
+
+intersect :: Interval -> Interval -> Bool
+intersect a b = not $ disjoint a b
+
+merge :: [Interval] -> Interval -> [Interval]
+merge [] i0 = [i0]
+merge (i1:intervals) i0
+ | (high i0) < (low i1) = i0:i1:intervals
+ | intersect i0 i1 = merge intervals (Interval a' b')
+ | otherwise = i1:(merge intervals i0)
+ where a' = minimum [low i0, low i1]
+ b' = maximum [high i0, high i1]
+
+mergeAdjacent :: [Interval] -> Interval -> [Interval]
+mergeAdjacent [] i0 = [i0]
+mergeAdjacent (i1:intervals) i0
+ | high i0 + 1 == low i1 = (Interval (low i0) (high i1)):intervals
+ | low i0 == high i1 + 1 = (Interval (low i1) (high i0)):intervals
+ | otherwise = i1:(mergeAdjacent intervals i0)
+
+gaps :: [Interval] -> Int
+gaps [] = 0
+gaps [_] = 0
+gaps ((Interval _ b):(Interval c d):intervals) =
+ (c - b - 1) + gaps ((Interval c d):intervals)
+
+intervalFile = intervalLine `endBy` newline
+intervalLine = Interval <$> int <*> (string "-" *> int)
+
+parseIfile :: String -> Either ParseError [Interval]
+parseIfile input = parse intervalFile "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
--- /dev/null
+module Main(main) where
+
+import Text.Parsec hiding (State)
+import Text.ParserCombinators.Parsec.Number
+import Data.Maybe (fromJust)
+import Data.List (elemIndex)
+
+import Control.Monad.Identity
+import Control.Monad.State
+import Control.Monad.Writer
+
+data Instruction = SwapPosition Int Int
+ | SwapLetter Char Char
+ | RotateSteps Int
+ | RotateLetter Char
+ | Reverse Int Int
+ | Move Int Int
+ deriving (Show, Eq)
+
+data Log = Log {
+ action :: String
+ } deriving (Show)
+
+data Password = Password {
+ password :: String
+ } deriving (Show)
+
+
+type App = WriterT [Log] (StateT Password Identity)
+
+infixl 9 ??
+
+(??) :: Eq a => [a] -> a -> Int
+(??) items item = fromJust $ elemIndex item items
+
+
+initial = "abcdefgh"
+final = "fbgdceah"
+
+testInstructions = "\
+\swap position 4 with position 0\n\
+\swap letter d with letter b\n\
+\reverse positions 0 through 4\n\
+\rotate left 1 step\n\
+\move position 1 to position 4\n\
+\move position 3 to position 0\n\
+\rotate based on position of letter b\n\
+\rotate based on position of letter d\n"
+
+main :: IO ()
+main = do
+ -- let ti = successfulParse $ parseIfile testInstructions
+ -- part1 ti "abcde"
+ -- part2 (reverse ti) "decab"
+ text <- readFile "data/advent21.txt"
+ let instructions = successfulParse $ parseIfile text
+ part1 instructions initial
+ part2 (reverse instructions) final
+
+part1 :: [Instruction] -> String -> IO ()
+part1 instructions start =
+ let st = Password {password = start}
+ ((_, log), st') = runIdentity (runStateT (runWriterT (apply instructions)) st)
+ in do
+ -- putStrLn $ unlines $ map (action) log
+ putStrLn $ password st'
+
+part2 :: [Instruction] -> String -> IO ()
+part2 instructions end =
+ let st = Password {password = end}
+ ((_, log), st') = runIdentity (runStateT (runWriterT (unApply instructions)) st)
+ in do
+ -- putStrLn $ unlines $ map (action) log
+ putStrLn $ password st'
+
+
+apply :: [Instruction] -> App ()
+apply [] = return ()
+apply (i:is) =
+ do st <- get
+ let p0 = password st
+ let p1 = applyInstruction i p0
+ put st {password = p1}
+ tell [Log (p0 ++ " -> " ++ p1 ++ " : " ++ (show i))]
+ apply is
+
+
+applyInstruction :: Instruction -> String -> String
+applyInstruction (SwapPosition from to) p0
+ | from == to = p0
+ | otherwise = prefix ++ [p0!!end] ++ midfix ++ [p0!!start] ++ suffix
+ where start = minimum [from, to]
+ end = maximum [from, to]
+ prefix = take start p0
+ midfix = take (end-start-1) $ drop (start+1) p0
+ suffix = drop (end+1) p0
+
+applyInstruction (SwapLetter l0 l1) p0 = applyInstruction (SwapPosition (p0??l0) (p0??l1)) p0
+
+applyInstruction (RotateSteps n) p0 = (drop n' p0) ++ (take n' p0)
+ where n' = if n < 0
+ then (-1 * n)
+ else (length p0) - n
+
+applyInstruction (RotateLetter l) p0 = applyInstruction (RotateSteps n) p0
+ where n = (1 + (p0??l) + if (p0??l) >= 4 then 1 else 0) `mod` (length p0)
+
+applyInstruction (Reverse from to) p0
+ | from == to = p0
+ | otherwise = prefix ++ (reverse midfix) ++ suffix
+ where start = minimum [from, to]
+ end = maximum [from, to]
+ prefix = take start p0
+ midfix = take (end-start+1) $ drop start p0
+ suffix = drop (end+1) p0
+
+applyInstruction (Move from to) p0
+ | from == to = p0
+ | otherwise = prefix ++ [p0!!from] ++ suffix
+ where without = take from p0 ++ drop (from+1) p0
+ prefix = take to without
+ suffix = drop (to) without
+
+
+unApply :: [Instruction] -> App ()
+unApply [] = return ()
+unApply (i:is) =
+ do st <- get
+ let p0 = password st
+ let p1 = unApplyInstruction i p0
+ put st {password = p1}
+ tell [Log (p1 ++ " <- " ++ p0 ++ " : " ++ (show i))]
+ unApply is
+
+unApplyInstruction :: Instruction -> String -> String
+unApplyInstruction (SwapPosition from to) p0 = applyInstruction (SwapPosition from to) p0
+unApplyInstruction (SwapLetter l0 l1) p0 = applyInstruction (SwapLetter l0 l1) p0
+unApplyInstruction (RotateSteps n) p0 = applyInstruction (RotateSteps (-1 * n)) p0
+unApplyInstruction (Reverse from to) p0 = applyInstruction (Reverse from to) p0
+unApplyInstruction (Move from to) p0 = applyInstruction (Move to from) p0
+unApplyInstruction (RotateLetter l) p0 = applyInstruction (RotateSteps n) p0
+ where n = case (p0??l) of
+ 0 -> -1
+ 1 -> -1
+ 2 -> 2
+ 3 -> -2
+ 4 -> 1
+ 5 -> -3
+ 6 -> 0
+ 7 -> -4
+ -- where n = case (p0??l) of
+ -- 0 -> -1
+ -- 1 -> -1
+ -- 2 -> 1
+ -- 3 -> -2
+ -- 4 -> 1
+
+
+instructionFile = instructionLine `endBy` newline
+instructionLine = choice [ swapL
+ , rotateL
+ , reverseL
+ , moveL
+ ]
+
+swapL = (try (string "swap ")) *> (swapPosL <|> swapLetterL)
+
+swapPosL = SwapPosition <$> (string "position" *> spaces *> int)
+ <*> (spaces *> string "with position" *> spaces *> int)
+
+swapLetterL = SwapLetter <$> (string "letter" *> spaces *> letter)
+ <*> (spaces *> string "with letter" *> spaces *> letter)
+
+rotateL = (try (string "rotate ")) *> (rotateDirL <|> rotateLetterL)
+
+rotateDirL = rotateStepify <$> ((string "left") <|> (string "right"))
+ <*> (spaces *> int <* spaces <* skipMany letter)
+ where rotateStepify dir n = case dir of
+ "left" -> (RotateSteps (-1 * n))
+ "right" -> (RotateSteps n)
+rotateLetterL = RotateLetter <$> (string "based on position of letter " *> letter)
+
+reverseL = Reverse <$> (string "reverse positions" *> spaces *> int)
+ <*> (spaces *> (string "through") *> spaces *> int)
+
+moveL = Move <$> (string "move position" *> spaces *> int)
+ <*> (spaces *> (string "to position") *> spaces *> int)
+
+
+parseIfile :: String -> Either ParseError [Instruction]
+parseIfile input = parse instructionFile "(unknown)" input
+
+parseIline :: String -> Either ParseError Instruction
+parseIline input = parse instructionLine "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
--- /dev/null
+module Main(main) where
+
+import GHC.Generics (Generic)
+import Text.Parsec
+import Text.ParserCombinators.Parsec.Number
+import Data.Maybe (catMaybes, fromJust)
+import Data.List (find, delete, sort, sortOn, reverse)
+
+data Node = Node { x :: Int
+ , y :: Int
+ , size :: Int
+ , used :: Int
+ , available :: Int
+ , use_pc :: Int
+ } deriving (Show, Eq, Ord)
+
+data SearchState = SearchState { cx :: Int
+ , cy :: Int
+ , grid :: [Node]
+ } deriving (Show)
+instance Ord SearchState where
+ s1 `compare` s2 = (heuristic s1) `compare` (heuristic s2)
+instance Eq SearchState where
+ s1 == s2 = equivalentState s1 s2
+
+equivalentState :: SearchState -> SearchState -> Bool
+equivalentState s1 s2 =
+ let h1 = fromJust $ find (\n -> used n == 0) $ grid s1
+ h2 = fromJust $ find (\n -> used n == 0) $ grid s2
+ in
+ cx s1 == cx s2 && cy s1 == cy s2 &&
+ x h1 == x h2 && y h1 == y h2
+
+
+testGrid = "\
+\Filesystem Size Used Avail Use%\n\
+\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
+\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
+\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
+\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
+\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
+\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
+\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
+\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
+\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
+\"
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent22.txt"
+ let sizes = successfulParse $ parseFile text
+ part1 sizes
+ part2 sizes
+
+part1 :: [Node] -> IO ()
+part1 sizes = print $ length viable
+ where viable = [(a, b) | a <- sizes,
+ b <- sizes,
+ a /= b,
+ (used a) > 0,
+ (used a) <= (available b)]
+
+
+part2 :: [Node] -> IO ()
+part2 sizes =
+ -- do let testSizes = successfulParse $ parseFile testGrid
+ -- putStrLn $ searchTraceH $ reverse $ aStar [[startSt testSizes]] []
+ print (26 + 26 + 29 + 5 * 36)
+
+
+aStar :: [[SearchState]] -> [SearchState] -> [SearchState]
+aStar [] _ = []
+aStar (currentPath:agenda) closed =
+ if isGoal reached then currentPath
+ else if reached `elem` closed
+ then aStar agenda closed
+ else aStar newAgenda (reached:closed)
+ where
+ reached = head currentPath
+ successorPaths = map (:currentPath) $ successors reached
+ newAgenda = sortOn (cost) $ successorPaths ++ agenda
+
+
+searchTrace :: [SearchState] -> String
+searchTrace ss = unlines $ map (sst) ss
+ where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ")"
+
+searchTraceH :: [SearchState] -> String
+searchTraceH ss = unlines $ map (sst) ss
+ where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ") :: " ++ holeS s
+ hole sk = fromJust $ find (\n -> used n == 0) $ grid sk
+ holeS sk = "(" ++ show (x $ hole sk) ++ ", " ++ show (y $ hole sk) ++ ")"
+
+startSt :: [Node] -> SearchState
+startSt nodes = SearchState {cx = maximum xs, cy = 0, grid = nodes}
+ where xs = map (\n -> x n) nodes
+
+isGoal :: SearchState -> Bool
+isGoal st = cx st == 0 && cy st == 0
+
+adjacent :: Node -> Node -> Bool
+adjacent n1 n2 = abs ((x n1) - (x n2)) + abs ((y n1) - (y n2)) == 1
+
+-- A move of data from n1 to n2 is legal.
+legal :: Node -> Node -> Bool
+legal n1 n2 = adjacent n1 n2 && used n1 > 0 && used n1 <= available n2
+
+heuristic :: SearchState -> Int
+heuristic st = (cx st) + (cy st)
+
+successors :: SearchState -> [SearchState]
+successors st = map (newState st current) possibleMoves
+ where nodes = grid st
+ current = fromJust $ find (\n -> (x n) == (cx st) && (y n) == (cy st)) nodes
+ possibleMoves = [(n1, n2) | n1 <- nodes, n2 <- nodes, legal n1 n2]
+
+
+-- Moving data from n1 to n2
+newState :: SearchState -> Node -> (Node, Node) -> SearchState
+newState st current (n1, n2) = st {cx = cx', cy = cy', grid = grid'}
+ where cx' = if current == n1 then x n2 else x current
+ cy' = if current == n1 then y n2 else y current
+ grid' = sort $ (n2 {used = (used n2 + used n1), available = (available n2 - used n1)}):
+ (n1 {used = 0, available = (size n1)}):
+ (delete n1 $ delete n2 (grid st))
+
+cost :: [SearchState] -> Int
+cost p = (heuristic $ head p) + (length p)
+
+
+
+duFile = duLine `sepEndBy` newline
+-- duLine = (optionMaybe nodeL)
+
+duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
+
+headerL = (many (noneOf "\r\n"))
+
+nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
+ <*> (string "-y" *> int)
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "%")
+ where nodeify x y size used available use_pc =
+ Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
+
+parseFile :: String -> Either ParseError [Maybe Node]
+parseFile input = parse duFile "(unknown)" input
+
+parseLine :: String -> Either ParseError (Maybe Node)
+parseLine input = parse duLine "(unknown)" input
+
+successfulParse :: Either ParseError [Maybe a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = catMaybes a
--- /dev/null
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main(main) where
+
+import GHC.Generics (Generic)
+import Text.Parsec
+import Text.ParserCombinators.Parsec.Number
+import Data.Maybe (catMaybes, fromJust)
+import Data.List (find, delete, sort)
+import Data.Graph.AStar
+import Data.Hashable
+import qualified Data.HashSet
+
+data Node = Node { x :: Int
+ , y :: Int
+ , size :: Int
+ , used :: Int
+ , available :: Int
+ , use_pc :: Int
+ } deriving (Show, Eq, Ord, Generic)
+instance Hashable Node
+
+data SearchState = SearchState { cx :: Int
+ , cy :: Int
+ , grid :: [Node]
+ } deriving (Show, Eq, Generic)
+instance Hashable SearchState
+instance Ord SearchState where
+ s1 `compare` s2 = (heuristic s1) `compare` (heuristic s2)
+
+
+testGrid = "\
+\Filesystem Size Used Avail Use%\n\
+\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
+\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
+\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
+\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
+\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
+\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
+\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
+\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
+\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
+\"
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent22.txt"
+ let sizes = successfulParse $ parseFile text
+ part1 sizes
+ part2 sizes
+
+part1 :: [Node] -> IO ()
+part1 sizes = print $ length viable
+ where viable = [(a, b) | a <- sizes,
+ b <- sizes,
+ a /= b,
+ (used a) > 0,
+ (used a) <= (available b)]
+
+
+part2 :: [Node] -> IO ()
+part2 sizes =
+ -- do let testSizes = successfulParse $ parseFile testGrid
+ -- putStrLn $ searchTrace $ fromJust $
+ -- aStar successors
+ -- (\_ _ -> 1)
+ -- heuristic
+ -- isGoal
+ -- (startSt testSizes)
+ putStrLn $ searchTrace $ fromJust $
+ aStar successors
+ (\_ _ -> 1)
+ heuristic
+ isGoal
+ (startSt sizes)
+
+
+
+searchTrace :: [SearchState] -> String
+searchTrace ss = unlines $ map (sst) ss
+ where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ") :: " ++ holeS s
+ hole sk = fromJust $ find (\n -> used n == 0) $ grid sk
+ holeS sk = "(" ++ show (x $ hole sk) ++ ", " ++ show (y $ hole sk) ++ ")"
+
+startSt :: [Node] -> SearchState
+startSt nodes = SearchState {cx = maximum xs, cy = 0, grid = nodes}
+ where xs = map (\n -> x n) nodes
+
+isGoal :: SearchState -> Bool
+isGoal st = cx st == 0 && cy st == 0
+
+adjacent :: Node -> Node -> Bool
+adjacent n1 n2 = abs ((x n1) - (x n2)) + abs ((y n1) - (y n2)) == 1
+
+-- A move of data from n1 to n2 is legal.
+legal :: Node -> Node -> Bool
+legal n1 n2 = adjacent n1 n2 && used n1 > 0 && used n1 <= available n2
+
+heuristic :: SearchState -> Int
+heuristic st = (cx st) + (cy st)
+
+successors :: SearchState -> Data.HashSet.HashSet SearchState
+successors st = Data.HashSet.fromList $ map (newState st current) possibleMoves
+ where nodes = grid st
+ current = fromJust $ find (\n -> (x n) == (cx st) && (y n) == (cy st)) nodes
+ possibleMoves = [(n1, n2) | n1 <- nodes, n2 <- nodes, legal n1 n2]
+
+
+-- Moving data from n1 to n2
+newState :: SearchState -> Node -> (Node, Node) -> SearchState
+newState st current (n1, n2) = st {cx = cx', cy = cy', grid = grid'}
+ where cx' = if current == n1 then x n2 else x current
+ cy' = if current == n1 then y n2 else y current
+ grid' = sort $ (n2 {used = (used n2 + used n1), available = (available n2 - used n1)}):
+ (n1 {used = 0, available = (size n1)}):
+ (delete n1 $ delete n2 (grid st))
+
+
+duFile = duLine `sepEndBy` newline
+-- duLine = (optionMaybe nodeL)
+
+duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
+
+headerL = (many (noneOf "\r\n"))
+
+nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
+ <*> (string "-y" *> int)
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "%")
+ where nodeify x y size used available use_pc =
+ Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
+
+parseFile :: String -> Either ParseError [Maybe Node]
+parseFile input = parse duFile "(unknown)" input
+
+parseLine :: String -> Either ParseError (Maybe Node)
+parseLine input = parse duLine "(unknown)" input
+
+successfulParse :: Either ParseError [Maybe a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = catMaybes a
--- /dev/null
+module Main(main) where
+
+import GHC.Generics (Generic)
+import Text.Parsec
+import Text.ParserCombinators.Parsec.Number
+import Data.Maybe (catMaybes, fromJust)
+import Data.List (find, delete, sort, sortOn, reverse)
+
+data Node = Node { x :: Int
+ , y :: Int
+ , size :: Int
+ , used :: Int
+ , available :: Int
+ , use_pc :: Int
+ } deriving (Show, Eq, Ord)
+
+data SearchState = SearchState { cx :: Int
+ , cy :: Int
+ , grid :: [Node]
+ } deriving (Show)
+instance Ord SearchState where
+ s1 `compare` s2 = (heuristic s1) `compare` (heuristic s2)
+instance Eq SearchState where
+ s1 == s2 = equivalentState s1 s2
+
+equivalentState :: SearchState -> SearchState -> Bool
+equivalentState s1 s2 =
+ let h1 = fromJust $ find (\n -> used n == 0) $ grid s1
+ h2 = fromJust $ find (\n -> used n == 0) $ grid s2
+ in
+ cx s1 == cx s2 && cy s1 == cy s2 &&
+ x h1 == x h2 && y h1 == y h2
+
+
+testGrid = "\
+\Filesystem Size Used Avail Use%\n\
+\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
+\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
+\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
+\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
+\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
+\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
+\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
+\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
+\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
+\"
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent22.txt"
+ let sizes = successfulParse $ parseFile text
+ part1 sizes
+ part2 sizes
+
+part1 :: [Node] -> IO ()
+part1 sizes = print $ length viable
+ where viable = [(a, b) | a <- sizes,
+ b <- sizes,
+ a /= b,
+ (used a) > 0,
+ (used a) <= (available b)]
+
+
+part2 :: [Node] -> IO ()
+part2 sizes =
+ -- do let testSizes = successfulParse $ parseFile testGrid
+ -- putStrLn $ searchTraceH $ reverse $ aStar [[startSt testSizes]] []
+ print $ length $ aStar [[startSt sizes]] []
+
+
+aStar :: [[SearchState]] -> [SearchState] -> [SearchState]
+aStar [] _ = []
+aStar (currentPath:agenda) closed =
+ if isGoal reached then currentPath
+ else if reached `elem` closed
+ then aStar agenda closed
+ else aStar newAgenda (reached:closed)
+ where
+ reached = head currentPath
+ successorPaths = map (:currentPath) $ successors reached
+ newAgenda = sortOn (cost) $ successorPaths ++ agenda
+
+
+searchTrace :: [SearchState] -> String
+searchTrace ss = unlines $ map (sst) ss
+ where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ")"
+
+searchTraceH :: [SearchState] -> String
+searchTraceH ss = unlines $ map (sst) ss
+ where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ") :: " ++ holeS s
+ hole sk = fromJust $ find (\n -> used n == 0) $ grid sk
+ holeS sk = "(" ++ show (x $ hole sk) ++ ", " ++ show (y $ hole sk) ++ ")"
+
+startSt :: [Node] -> SearchState
+startSt nodes = SearchState {cx = maximum xs, cy = 0, grid = nodes}
+ where xs = map (\n -> x n) nodes
+
+isGoal :: SearchState -> Bool
+isGoal st = cx st == 0 && cy st == 0
+
+adjacent :: Node -> Node -> Bool
+adjacent n1 n2 = abs ((x n1) - (x n2)) + abs ((y n1) - (y n2)) == 1
+
+-- A move of data from n1 to n2 is legal.
+legal :: Node -> Node -> Bool
+legal n1 n2 = adjacent n1 n2 && used n1 > 0 && used n1 <= available n2
+
+heuristic :: SearchState -> Int
+heuristic st = (cx st) + (cy st)
+
+successors :: SearchState -> [SearchState]
+successors st = map (newState st current) possibleMoves
+ where nodes = grid st
+ current = fromJust $ find (\n -> (x n) == (cx st) && (y n) == (cy st)) nodes
+ possibleMoves = [(n1, n2) | n1 <- nodes, n2 <- nodes, legal n1 n2]
+
+
+-- Moving data from n1 to n2
+newState :: SearchState -> Node -> (Node, Node) -> SearchState
+newState st current (n1, n2) = st {cx = cx', cy = cy', grid = grid'}
+ where cx' = if current == n1 then x n2 else x current
+ cy' = if current == n1 then y n2 else y current
+ grid' = sort $ (n2 {used = (used n2 + used n1), available = (available n2 - used n1)}):
+ (n1 {used = 0, available = (size n1)}):
+ (delete n1 $ delete n2 (grid st))
+
+cost :: [SearchState] -> Int
+cost p = (heuristic $ head p) + (length p)
+
+
+
+duFile = duLine `sepEndBy` newline
+-- duLine = (optionMaybe nodeL)
+
+duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
+
+headerL = (many (noneOf "\r\n"))
+
+nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
+ <*> (string "-y" *> int)
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "%")
+ where nodeify x y size used available use_pc =
+ Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
+
+parseFile :: String -> Either ParseError [Maybe Node]
+parseFile input = parse duFile "(unknown)" input
+
+parseLine :: String -> Either ParseError (Maybe Node)
+parseLine input = parse duLine "(unknown)" input
+
+successfulParse :: Either ParseError [Maybe a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = catMaybes a
--- /dev/null
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main(main) where
+
+import GHC.Generics (Generic)
+import Text.Parsec
+import Text.ParserCombinators.Parsec.Number
+import Data.Maybe (catMaybes, fromJust)
+import Data.List (find, delete, sort, sortOn, reverse)
+
+data Node = Node { x :: Int
+ , y :: Int
+ , size :: Int
+ , used :: Int
+ , available :: Int
+ , use_pc :: Int
+ } deriving (Show, Eq, Ord)
+
+
+testGrid = "\
+\Filesystem Size Used Avail Use%\n\
+\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
+\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
+\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
+\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
+\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
+\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
+\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
+\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
+\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
+\"
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent22.txt"
+ let sizes = successfulParse $ parseFile text
+ let maxX = maximum $ map (\n -> x n) sizes
+ let maxY = maximum $ map (\n -> y n) sizes
+ putStrLn $ unlines $ map (showRow maxX sizes) [0..(maxY-1)]
+
+
+showRow maxX sizes r = map (charOf) row
+ where row = sortOn (\c -> x c) $ filter (\c -> y c == r) sizes
+ charOf c = if (used c) == 0
+ then '+'
+ else if (used c) > 100
+ then '#'
+ else '_'
+
+
+
+
+duFile = duLine `sepEndBy` newline
+-- duLine = (optionMaybe nodeL)
+
+duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
+
+headerL = (many (noneOf "\r\n"))
+
+nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
+ <*> (string "-y" *> int)
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "T")
+ <*> (spaces *> int <* string "%")
+ where nodeify x y size used available use_pc =
+ Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
+
+parseFile :: String -> Either ParseError [Maybe Node]
+parseFile input = parse duFile "(unknown)" input
+
+parseLine :: String -> Either ParseError (Maybe Node)
+parseLine input = parse duLine "(unknown)" input
+
+successfulParse :: Either ParseError [Maybe a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = catMaybes a
--- /dev/null
+module Main(main) where
+
+import Text.Parsec hiding (State)
+import Text.ParserCombinators.Parsec.Number
+import Control.Monad.State.Lazy
+-- import Debug.Trace
+
+data Location = Literal Int | Register Char deriving (Show, Eq)
+data Instruction = Cpy Location Location
+ | Inc Location
+ | Dec Location
+ | Jnz Location Location
+ | Tgl Location
+ deriving (Show, Eq)
+
+data Machine = Machine { a :: Int
+ , b :: Int
+ , c :: Int
+ , d :: Int
+ , pc :: Int
+ , instructions :: [Instruction]}
+ deriving (Show, Eq)
+
+testInstructions = "cpy 2 a\n\
+\tgl a\n\
+\tgl a\n\
+\tgl a\n\
+\cpy 1 a\n\
+\dec a\n\
+\dec a"
+
+emptyMachine :: Machine
+emptyMachine = Machine {a=0, b=0, c=0, d=0, pc=0, instructions=[]}
+
+main :: IO ()
+main = do
+ text <- readFile "data/advent23.txt"
+ let instructions = successfulParse $ parseIfile text
+ part1 instructions
+ part2 instructions
+
+
+part1 :: [Instruction] -> IO ()
+part1 instrs =
+ do let m0 = emptyMachine {instructions=instrs, a = 7}
+ let mf = snd $ runState runMachine m0
+ print (a mf)
+
+part2 :: [Instruction] -> IO ()
+part2 instrs =
+ do let m0 = emptyMachine {instructions=instrs, a = 12}
+ let mf = snd $ runState runMachine m0
+ print (a mf)
+
+
+runMachine :: State Machine ()
+runMachine =
+ do m <- get
+ if (pc m) >= (length $ instructions m)
+ then return ()
+ else do executeStep
+ runMachine
+
+executeStep :: State Machine ()
+executeStep =
+ do m <- get
+ let i = (instructions m)!!(pc m)
+ put (executeInstructionPeep i m)
+ -- put (executeInstruction i m)
+
+executeInstructionPeep :: Instruction -> Machine -> Machine
+executeInstructionPeep i m =
+ if sample1 == sample1Target
+ -- then trace ("Peeping 1 " ++ (show m) ++ " to " ++ (show m1)) m1
+ then m1
+ else if sample2 == sample2Target
+ -- then trace ("Peeping 2 " ++ (show m) ++ " to " ++ (show m2)) m2
+ then m2
+ else executeInstruction i m
+ where sample1 = take (length sample1Target) $ drop (pc m) $ instructions m
+ sample1Target = [ Cpy (Literal 0) (Register 'a')
+ , Cpy (Register 'b') (Register 'c')
+ , Inc (Register 'a')
+ , Dec (Register 'c')
+ , Jnz (Register 'c') (Literal (-2))
+ , Dec (Register 'd')
+ , Jnz (Register 'd') (Literal (-5)) ]
+ m1 = m {a = b m * d m, c = 0, d = 0, pc = pc m + (length sample1)}
+ sample2 = take (length sample2Target) $ drop (pc m) $ instructions m
+ sample2Target = [ Dec (Register 'b')
+ , Cpy (Register 'b') (Register 'c')
+ , Cpy (Register 'c') (Register 'd')
+ , Dec (Register 'd')
+ , Inc (Register 'c')
+ , Jnz (Register 'd') (Literal (-2)) ]
+ m2 = m {b = b m - 1, c = (b m - 1) * 2, d = 0, pc = pc m + (length sample2)}
+
+
+executeInstruction :: Instruction -> Machine -> Machine
+executeInstruction (Inc r@(Register _)) m = m' {pc=pc1}
+ where pc1 = (pc m) + 1
+ v = evaluate m r
+ m' = writeValue m r (v+1)
+executeInstruction (Inc (Literal _)) m = m {pc=pc1}
+ where pc1 = (pc m) + 1
+executeInstruction (Dec r@(Register _)) m = m' {pc=pc1}
+ where pc1 = (pc m) + 1
+ v = evaluate m r
+ m' = writeValue m r (v-1)
+executeInstruction (Dec (Literal _)) m = m {pc=pc1}
+ where pc1 = (pc m) + 1
+executeInstruction (Cpy s d@(Register _)) m = m' {pc=pc1}
+ where pc1 = (pc m) + 1
+ v = evaluate m s
+ m' = writeValue m d v
+executeInstruction (Cpy s (Literal _)) m = m {pc=pc1}
+ where pc1 = (pc m) + 1
+executeInstruction (Jnz s d) m
+ | v == 0 = m {pc=pc1}
+ | otherwise = m {pc=pcj}
+ where pc1 = (pc m) + 1
+ ed = evaluate m d
+ pcj = (pc m) + ed
+ v = evaluate m s
+executeInstruction (Tgl a) m
+ | v < (length $ instructions m) = m {instructions = (replace (instructions m) i' v),
+ pc=pc1}
+ | otherwise = m {pc=pc1}
+ where pc1 = pc m + 1
+ v = evaluate m a + pc m
+ i = (instructions m)!!v
+ i' = case i of
+ Inc x -> Dec x
+ Dec x -> Inc x
+ Tgl x -> Inc x
+ Cpy x y -> Jnz x y
+ Jnz x y -> Cpy x y
+ replace xs x i = take i xs ++ [x] ++ drop (i+1) xs
+
+
+evaluate :: Machine -> Location -> Int
+evaluate _ (Literal i) = i
+evaluate m (Register r) =
+ case r of
+ 'a' -> (a m)
+ 'b' -> (b m)
+ 'c' -> (c m)
+ 'd' -> (d m)
+
+writeValue :: Machine -> Location -> Int -> Machine
+writeValue m (Literal i) _ = m
+writeValue m (Register r) v =
+ case r of
+ 'a' -> m {a=v}
+ 'b' -> m {b=v}
+ 'c' -> m {c=v}
+ 'd' -> m {d=v}
+
+
+instructionFile = instructionLine `sepEndBy` newline
+instructionLine = incL <|> decL <|> cpyL <|> jnzL <|> tglL
+
+incL = Inc <$> (string "inc" *> spaces *> register)
+decL = Dec <$> (string "dec" *> spaces *> register)
+cpyL = Cpy <$> (string "cpy" *> spaces *> location) <*> (spaces *> register)
+jnzL = Jnz <$> (string "jnz" *> spaces *> location) <*> (spaces *> location)
+tglL = Tgl <$> (string "tgl" *> spaces *> location)
+
+location = (Literal <$> int) <|> register
+register = Register <$> (oneOf "abcd")
+
+parseIfile :: String -> Either ParseError [Instruction]
+parseIfile input = parse instructionFile "(unknown)" input
+
+parseIline :: String -> Either ParseError Instruction
+parseIline input = parse instructionLine "(unknown)" input
+
+successfulParse :: Either ParseError [a] -> [a]
+successfulParse (Left _) = []
+successfulParse (Right a) = a
--- /dev/null
+module Lib
+ ( someFunc
+ ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
--- /dev/null
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"
--- /dev/null
+name: adventofcode1601
+version: 0.1.0.0
+synopsis: Initial project template from stack
+description: Please see README.md
+homepage: https://github.com/neilnjae/adventofcode16#readme
+license: BSD3
+license-file: LICENSE
+author: Neil Smith
+maintainer: noone@njae.me.uk
+copyright: 2016 Neil Smith
+category: None
+build-type: Simple
+extra-source-files: README.md
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ build-depends: base >= 4.7 && < 5
+ default-language: Haskell2010
+
+executable advent01
+ hs-source-dirs: app
+ main-is: Main.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode1601
+ , adventofcode16
+ , split
+ default-language: Haskell2010
+
+test-suite adventofcode1601-test
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Spec.hs
+ build-depends: base
+ , adventofcode1601
+ , adventofcode16
+ , split
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ default-language: Haskell2010
+
+source-repository head
+ type: git
+ location: https://github.com/neilnjae/adventofcode16
--- /dev/null
+module Main(main) where
+
+import Data.List (sort)
+import Data.List.Split (splitOn)
+
+-- turn direction, number of steps
+data Step = Step Char Int deriving (Show)
+
+data Direction = North | East | South | West
+ deriving (Enum, Show, Bounded, Eq)
+
+-- direction, easting, northing
+data Position = Position Direction Int Int deriving (Show)
+-- Two positions are the same if they're in the same place,
+-- regardless of facing
+instance Eq Position where
+ Position _ e n == Position _ e' n' = e == e' && n == n'
+
+main :: IO ()
+main = do
+ instructions <- readFile "data/advent01.txt"
+ part1 instructions
+ part2 instructions
+
+part1 :: String -> IO ()
+part1 instructions = do
+ let answer = finalDistance $ last $ stepsFromStart $ steps instructions
+ print answer
+
+part2 :: String -> IO ()
+part2 instructions = do
+ let visited = finalDistance $ firstRepeat $ stepsFromStart $ expandSteps $ steps instructions
+ print visited
+
+
+-- Extract the steps from the input string.
+steps :: String -> [Step]
+steps s = map readStep $ splitOn ", " s
+ where readStep (d:l) = Step d (read l)
+
+-- Take steps from the starting position
+stepsFromStart :: [Step] -> [Position]
+stepsFromStart = takeSteps (Position North 0 0)
+
+-- Calculate manhattan distance from start to this state
+finalDistance :: Position -> Int
+finalDistance (Position _ e n) = (abs e) + (abs n)
+
+-- For part 2: convert one step of many spaces to many steps of one space each
+expandSteps :: [Step] -> [Step]
+expandSteps =
+ concatMap expandStep
+ where expandStep (Step dir d) = (Step dir 1) : replicate (d - 1) (Step 'S' 1)
+
+-- Execute a series of steps, keeping track of the positions after each step
+takeSteps :: Position -> [Step] -> [Position]
+-- takeSteps pos steps = scanl move pos steps
+takeSteps = scanl move
+
+-- Make one move, by updating direction then position
+move :: Position -> Step -> Position
+move (Position facing easting northing)
+ (Step turnInstr distance) =
+ Position facing' easting' northing'
+ where facing' = turn turnInstr facing
+ (easting', northing') = takeStep facing' distance easting northing
+
+-- Turn right, left, or straight
+turn :: Char -> Direction -> Direction
+turn 'R' direction = turnCW direction
+turn 'L' direction = turnACW direction
+turn 'S' direction = direction
+
+-- Move in the current direction
+takeStep :: Direction -> Int -> Int -> Int -> (Int, Int)
+takeStep North d e n = (e, n+d)
+takeStep South d e n = (e, n-d)
+takeStep West d e n = (e-d, n)
+takeStep East d e n = (e+d, n)
+
+
+-- | a `succ` that wraps
+turnCW :: (Bounded a, Enum a, Eq a) => a -> a
+turnCW dir | dir == maxBound = minBound
+ | otherwise = succ dir
+
+-- | a `pred` that wraps
+turnACW :: (Bounded a, Enum a, Eq a) => a -> a
+turnACW dir | dir == minBound = maxBound
+ | otherwise = pred dir
+
+-- All the prefixes of a list of items
+prefixes = scanl addTerm []
+ where addTerm ps t = ps ++ [t]
+
+-- The first item that exists in a prefix of the list to that point
+firstRepeat positions =
+ last $ head $ dropWhile (\p -> (last p) `notElem` (tail $ reverse p))
+ (tail $ prefixes positions)
--- /dev/null
+name: adventofcode1602
+version: 0.1.0.0
+synopsis: Initial project template from stack
+description: Please see README.md
+homepage: https://github.com/neilnjae/adventofcode16#readme
+license: BSD3
+license-file: LICENSE
+author: Neil Smith
+maintainer: noone@njae.me.uk
+copyright: 2016 Neil Smith
+category: None
+build-type: Simple
+extra-source-files: README.md
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ build-depends: base >= 4.7 && < 5
+ default-language: Haskell2010
+
+executable advent02
+ hs-source-dirs: app
+ main-is: Main.hs
+ ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+ build-depends: base
+ , adventofcode1602
+ , adventofcode16
+ , array
+ default-language: Haskell2010
+
+test-suite adventofcode1602-test
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Spec.hs
+ build-depends: base
+ , adventofcode1602
+ , adventofcode16
+ , array
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ default-language: Haskell2010
+
+source-repository head
+ type: git
+ location: https://github.com/neilnjae/adventofcode16
--- /dev/null
+module Main(main) where
+
+import Data.Array.IArray
+
+-- Row 1 is top, column 1 is left
+type Position = (Int, Int)
+type Keyboard = Array Position Char
+
+kb1 = ["xxxxx",
+ "x123x",
+ "x456x",
+ "x789x",
+ "xxxxx"]
+
+kb2 = ["xxxxxxx",
+ "xxx1xxx",
+ "xx234xx",
+ "x56789x",
+ "xxABCxx",
+ "xxxDxxx",
+ "xxxxxxx"]
+
+enumerate = zip [0..]
+
+mkKeyboard :: [String] -> Keyboard
+mkKeyboard kb = array ((0, 0), (length kb - 1, length (kb!!0) - 1))
+ [((i, j), c) | (i, r) <- enumerate kb, (j, c) <- enumerate r]
+
+keyboard1 = mkKeyboard kb1
+keyboard2 = mkKeyboard kb2
+
+findKey :: Keyboard -> Char-> Position
+findKey kb c = fst $ head $ filter (\a -> (snd a) == c) $ assocs kb
+
+-- data Coord = One | Two | Three
+-- deriving (Read, Show, Eq, Ord, Enum, Bounded)
+-- -- instance Bounded Coord where
+-- -- minBound = Coord 1
+-- -- maxBound = Coord 3
+
+-- data Position = Position Coord Coord
+-- deriving (Show, Eq)
+
+main :: IO ()
+main = do
+ instrText <- readFile "data/advent02.txt"
+ let instructions = lines instrText
+ part1 instructions
+ part2 instructions
+
+part1 :: [String] -> IO ()
+part1 instructions = do
+ putStrLn $ followInstructions keyboard1 instructions
+
+
+part2 :: [String] -> IO ()
+part2 instructions = do
+ putStrLn $ followInstructions keyboard2 instructions
+
+
+followInstructions :: Keyboard -> [String] -> String
+followInstructions kb instr = moveSeries kb (startPosition kb) instr
+
+
+startPosition :: Keyboard -> Position
+startPosition kb = findKey kb '5'
+
+moveSeries :: Keyboard -> Position -> [String] -> String
+moveSeries _ _ [] = []
+moveSeries kb p (i:is) = (n:ns)
+ where p' = makeMoves kb p i
+ n = kb ! p'
+ ns = moveSeries kb p' is
+
+makeMoves :: Keyboard -> Position -> [Char] -> Position
+makeMoves kb p ms = foldl (safeMove kb) p ms
+
+safeMove :: Keyboard -> Position -> Char -> Position
+safeMove kb pos dir = maybeRevert kb pos (move pos dir)
+
+move :: Position -> Char -> Position
+move (r, c) 'U' = (r-1, c)
+move (r, c) 'D' = (r+1, c)
+move (r, c) 'L' = (r, c-1)
+move (r, c) 'R' = (r, c+1)
+
+maybeRevert :: Keyboard -> Position -> Position -> Position
+maybeRevert kb oldPos newPos
+ | kb ! newPos == 'x' = oldPos
+ | otherwise = newPos
+++ /dev/null
-module Main where
-
-import Lib
-
-main :: IO ()
-main = someFunc
+++ /dev/null
-module Main(main) where
-
-import Data.List (sort)
-import Data.List.Split (splitOn)
-
--- turn direction, number of steps
-data Step = Step Char Int deriving (Show)
-
-data Direction = North | East | South | West
- deriving (Enum, Show, Bounded, Eq)
-
--- direction, easting, northing
-data Position = Position Direction Int Int deriving (Show)
--- Two positions are the same if they're in the same place,
--- regardless of facing
-instance Eq Position where
- Position _ e n == Position _ e' n' = e == e' && n == n'
-
-main :: IO ()
-main = do
- instructions <- readFile "data/advent01.txt"
- part1 instructions
- part2 instructions
-
-part1 :: String -> IO ()
-part1 instructions = do
- let answer = finalDistance $ last $ stepsFromStart $ steps instructions
- print answer
-
-part2 :: String -> IO ()
-part2 instructions = do
- let visited = finalDistance $ firstRepeat $ stepsFromStart $ expandSteps $ steps instructions
- print visited
-
-
--- Extract the steps from the input string.
-steps :: String -> [Step]
-steps s = map readStep $ splitOn ", " s
- where readStep (d:l) = Step d (read l)
-
--- Take steps from the starting position
-stepsFromStart :: [Step] -> [Position]
-stepsFromStart = takeSteps (Position North 0 0)
-
--- Calculate manhattan distance from start to this state
-finalDistance :: Position -> Int
-finalDistance (Position _ e n) = (abs e) + (abs n)
-
--- For part 2: convert one step of many spaces to many steps of one space each
-expandSteps :: [Step] -> [Step]
-expandSteps =
- concatMap expandStep
- where expandStep (Step dir d) = (Step dir 1) : replicate (d - 1) (Step 'S' 1)
-
--- Execute a series of steps, keeping track of the positions after each step
-takeSteps :: Position -> [Step] -> [Position]
--- takeSteps pos steps = scanl move pos steps
-takeSteps = scanl move
-
--- Make one move, by updating direction then position
-move :: Position -> Step -> Position
-move (Position facing easting northing)
- (Step turnInstr distance) =
- Position facing' easting' northing'
- where facing' = turn turnInstr facing
- (easting', northing') = takeStep facing' distance easting northing
-
--- Turn right, left, or straight
-turn :: Char -> Direction -> Direction
-turn 'R' direction = turnCW direction
-turn 'L' direction = turnACW direction
-turn 'S' direction = direction
-
--- Move in the current direction
-takeStep :: Direction -> Int -> Int -> Int -> (Int, Int)
-takeStep North d e n = (e, n+d)
-takeStep South d e n = (e, n-d)
-takeStep West d e n = (e-d, n)
-takeStep East d e n = (e+d, n)
-
-
--- | a `succ` that wraps
-turnCW :: (Bounded a, Enum a, Eq a) => a -> a
-turnCW dir | dir == maxBound = minBound
- | otherwise = succ dir
-
--- | a `pred` that wraps
-turnACW :: (Bounded a, Enum a, Eq a) => a -> a
-turnACW dir | dir == minBound = maxBound
- | otherwise = pred dir
-
--- All the prefixes of a list of items
-prefixes = scanl addTerm []
- where addTerm ps t = ps ++ [t]
-
--- The first item that exists in a prefix of the list to that point
-firstRepeat positions =
- last $ head $ dropWhile (\p -> (last p) `notElem` (tail $ reverse p))
- (tail $ prefixes positions)
+++ /dev/null
-module Main(main) where
-
-import Data.Array.IArray
-
--- Row 1 is top, column 1 is left
-type Position = (Int, Int)
-type Keyboard = Array Position Char
-
-kb1 = ["xxxxx",
- "x123x",
- "x456x",
- "x789x",
- "xxxxx"]
-
-kb2 = ["xxxxxxx",
- "xxx1xxx",
- "xx234xx",
- "x56789x",
- "xxABCxx",
- "xxxDxxx",
- "xxxxxxx"]
-
-enumerate = zip [0..]
-
-mkKeyboard :: [String] -> Keyboard
-mkKeyboard kb = array ((0, 0), (length kb - 1, length (kb!!0) - 1))
- [((i, j), c) | (i, r) <- enumerate kb, (j, c) <- enumerate r]
-
-keyboard1 = mkKeyboard kb1
-keyboard2 = mkKeyboard kb2
-
-findKey :: Keyboard -> Char-> Position
-findKey kb c = fst $ head $ filter (\a -> (snd a) == c) $ assocs kb
-
--- data Coord = One | Two | Three
--- deriving (Read, Show, Eq, Ord, Enum, Bounded)
--- -- instance Bounded Coord where
--- -- minBound = Coord 1
--- -- maxBound = Coord 3
-
--- data Position = Position Coord Coord
--- deriving (Show, Eq)
-
-main :: IO ()
-main = do
- instrText <- readFile "data/advent02.txt"
- let instructions = lines instrText
- part1 instructions
- part2 instructions
-
-part1 :: [String] -> IO ()
-part1 instructions = do
- putStrLn $ followInstructions keyboard1 instructions
-
-
-part2 :: [String] -> IO ()
-part2 instructions = do
- putStrLn $ followInstructions keyboard2 instructions
-
-
-followInstructions :: Keyboard -> [String] -> String
-followInstructions kb instr = moveSeries kb (startPosition kb) instr
-
-
-startPosition :: Keyboard -> Position
-startPosition kb = findKey kb '5'
-
-moveSeries :: Keyboard -> Position -> [String] -> String
-moveSeries _ _ [] = []
-moveSeries kb p (i:is) = (n:ns)
- where p' = makeMoves kb p i
- n = kb ! p'
- ns = moveSeries kb p' is
-
-makeMoves :: Keyboard -> Position -> [Char] -> Position
-makeMoves kb p ms = foldl (safeMove kb) p ms
-
-safeMove :: Keyboard -> Position -> Char -> Position
-safeMove kb pos dir = maybeRevert kb pos (move pos dir)
-
-move :: Position -> Char -> Position
-move (r, c) 'U' = (r-1, c)
-move (r, c) 'D' = (r+1, c)
-move (r, c) 'L' = (r, c-1)
-move (r, c) 'R' = (r, c+1)
-
-maybeRevert :: Keyboard -> Position -> Position -> Position
-maybeRevert kb oldPos newPos
- | kb ! newPos == 'x' = oldPos
- | otherwise = newPos
+++ /dev/null
-module Main(main) where
-
-import Data.List (transpose, sort)
-import Data.List.Split (splitOn, chunksOf)
-
-type Triple = [Integer]
-
-main :: IO ()
-main = do
- instrText <- readFile "data/advent03.txt"
- let triangles = map (parseLine) $ lines instrText
- part1 triangles
- part2 triangles
-
-
-part1 :: [Triple] -> IO ()
-part1 triangles = do
- print $ length $ filter (validTriangle) triangles
-
-part2 :: [Triple] -> IO ()
-part2 triangles = do
- print $ length $ filter (validTriangle) $ byColumns triangles
-
-
-parseLine :: String -> Triple
-parseLine = map (read) . filter (not . null) . splitOn " "
-
-validTriangle :: Triple -> Bool
-validTriangle triple = sortedTriple!!0 + sortedTriple!!1 > sortedTriple!!2
- where sortedTriple = sort triple
-
-byColumns :: [[Integer]] -> [Triple]
-byColumns = chunksOf 3 . concat . transpose
+++ /dev/null
-module Main(main) where
-
-import Data.List (last, intersperse, sortBy, intercalate, isInfixOf, init)
-import Data.List.Split (splitOn)
-import Data.Char (isLetter, ord, chr)
-import qualified Data.Map.Lazy as Map
-
-data Room = Room { name :: String
- , sector :: Int
- , checksum :: String
- } deriving (Show)
-
-main :: IO ()
-main = do
- instrText <- readFile "data/advent04.txt"
- let rooms = map (parseLine) $ lines instrText
- part1 rooms
- part2 rooms
-
-
-part1 :: [Room] -> IO ()
-part1 rooms = do
- print $ sum $ map (sector) validRooms
- where
- validChecksum room = (checksum room) == makeChecksum (name room)
- validRooms = filter (validChecksum) rooms
-
-part2 :: [Room] -> IO ()
-part2 rooms = do
- print $ fst $ head $ filter (\sn -> isInfixOf "north" (snd sn)) sectorNames
- where
- validChecksum room = (checksum room) == makeChecksum (name room)
- validRooms = filter (validChecksum) rooms
- sectorNames = [((sector r),
- shiftWord (sector r) (name r)) | r <- validRooms]
-
-
-parseLine :: String -> Room
-parseLine line = Room {name=name, sector=sector, checksum=checksum}
- where components = splitOn "-" line
- name = intercalate "-" $ init components
- sector = read $ head $ splitOn "[" $ last components
- checksum = filter (isLetter) $ last components
-
-countedLetters :: String -> [(Char, Int)]
-countedLetters name = sortBy sortCLetter $ unsortedCountedLetters name
- where unsortedCountedLetters name =
- Map.toList $ Map.fromListWith (+) [(c, 1) | c <- filter (isLetter) name]
-
-sortCLetter :: (Char, Int) -> (Char, Int) -> Ordering
-sortCLetter (l1, n1) (l2, n2)
- | n1 < n2 = GT
- | n1 > n2 = LT
- | n1 == n2 = compare l1 l2
-
-makeChecksum :: String -> String
-makeChecksum name = [l | (l, _) <- take 5 $ countedLetters name]
-
-
-shiftWord :: Int -> String -> String
-shiftWord shift letters = map (shiftLetter shift) letters
-
-shiftLetter :: Int -> Char -> Char
-shiftLetter shift letter
- | isLetter letter = chr $ (ord letter - ord 'a' + shift) `mod` 26 + ord 'a'
- | otherwise = ' '
+++ /dev/null
-module Main(main) where
-
-import Data.Hash.MD5 (md5s, Str(..))
-import Data.List (isPrefixOf)
-import qualified Data.Map.Lazy as Map
-
-type Password = Map.Map Integer Char
-
-input = "cxdnnyjw"
-
-main :: IO ()
-main = do
- part1
- part2
-
-
-part1 :: IO ()
-part1 = do
- putStrLn $ take 8 [h!!5 | h <- filter (interesting) $ md5sequence input 0]
-
-part2 :: IO ()
-part2 = do
- putStrLn $ Map.foldr (:) [] password
- where interestingHashes =
- [(read [h!!5], h!!6) |
- h <- filter (interesting) (md5sequence input 0),
- h!!5 `elem` "01234567"]
- password = findPassword Map.empty interestingHashes
-
-
-md5sequence :: String -> Integer -> [String]
-md5sequence key i = (md5s (Str (key ++ show i))) : (md5sequence key (i+1))
-
-interesting :: String -> Bool
-interesting hash = "00000" `isPrefixOf` hash
-
-dontReplace :: (Integer, Char) -> Password -> Password
-dontReplace (k, v) = Map.insertWith (\_ v -> v) k v
-
-findPassword :: Password -> [(Integer, Char)] -> Password
-findPassword p (c:cs)
- | Map.size p == 8 = p
- | otherwise = findPassword p' cs
- where p' = dontReplace c p
+++ /dev/null
-module Main(main) where
-
-import Data.List (transpose)
-import Data.Char (isLetter)
-import qualified Data.Map.Lazy as Map
-
-main :: IO ()
-main = do
- text <- readFile "advent06.txt"
- let message = lines text
- part1 message
- part2 message
-
-part1 :: [String] -> IO ()
-part1 message = do
- print $ map (fst) $ map (mostCommon) $ map (countedLetters) $ transpose message
-
-part2 :: [String] -> IO ()
-part2 message = do
- print $ map (fst) $ map (leastCommon) $ map (countedLetters) $ transpose message
-
-
-countedLetters :: String -> Map.Map Char Int
-countedLetters name = Map.fromListWith (+) [(c, 1) | c <- filter (isLetter) name]
-
-mostCommon = Map.foldlWithKey (mostCommonP) ('a', 0)
-
-mostCommonP (letter0, count0) letter count
- | count > count0 = (letter, count)
- | otherwise = (letter0, count0)
-
-leastCommon = Map.foldlWithKey (leastCommonP) ('a', maxBound :: Int)
-
-leastCommonP (letter0, count0) letter count
- | count < count0 = (letter, count)
- | otherwise = (letter0, count0)
\ No newline at end of file
+++ /dev/null
-module Main(main) where
-
-import Data.List (transpose, maximum, minimum, sort, group)
-import Data.Tuple (swap)
-
-main :: IO ()
-main = do
- text <- readFile "data/advent06.txt"
- let message = lines text
- part1 message
- part2 message
-
-part1 :: [String] -> IO ()
-part1 message = do
- putStrLn $ map (snd . maximum . counts) $ transpose message
-
-part2 :: [String] -> IO ()
-part2 message = do
- putStrLn $ map (snd . minimum . counts) $ transpose message
-
-counts :: (Eq a, Ord a) => [a] -> [(Int, a)]
-counts = map (\g -> (length g, head g)) . group . sort
\ No newline at end of file
+++ /dev/null
-module Main(main) where
-
-import Text.Parsec
-import Data.List (partition, union, intersect, tails)
-import Data.Char (isAlphaNum)
-
-data Chunk = Include String | Exclude String deriving (Show)
-data ChunkV = Includev Bool | Excludev Bool deriving (Show)
-
-chunkValue :: Chunk -> String
-chunkValue (Include v) = v
-chunkValue (Exclude v) = v
-
-isInclude :: Chunk -> Bool
-isInclude (Include _) = True
-isInclude (Exclude _) = False
-
-chunkValueV :: ChunkV -> Bool
-chunkValueV (Includev v) = v
-chunkValueV (Excludev v) = v
-
-isIncludeV :: ChunkV -> Bool
-isIncludeV (Includev _) = True
-isIncludeV (Excludev _) = False
-
-
-main :: IO ()
-main = do
- text <- readFile "data/advent07.txt"
- part1 text
- part2 text
-
-
-part1 :: String -> IO ()
-part1 text = do
- print $ length $ filter (allowsAbba) $ successfulParse $ parseI7vf text
-
-
-part2 :: String -> IO ()
-part2 text = do
- print $ length $ filter (supportsSSL) $ successfulParse $ parseI7f text
-
-allowsAbba :: [ChunkV] -> Bool
-allowsAbba chunks = (any (chunkValueV) includeChunks) && (not (any (chunkValueV) excludeChunks))
- where (includeChunks, excludeChunks) = partition (isIncludeV) chunks
-
-i7file = i7line `endBy` newline
-i7line = many1 (includeChunk <|> excludeChunk)
-
-chunk = many1 alphaNum
-
-excludeChunk = Exclude <$> (between (char '[') (char ']') $ chunk)
-includeChunk = Include <$> chunk
-
-hasABBA = preambleAbba <* (many alphaNum)
-preambleAbba = (try abba) <|> (alphaNum >> preambleAbba)
-
--- abba =
--- do a <- alphaNum
--- b <- alphaNum
--- if a == b then
--- fail "Identical"
--- else do char b
--- char a
--- return [a, b, b, a]
-
-abba =
- do a <- alphaNum
- b <- noneOf [a]
- char b
- char a
- return [a, b, b, a]
-
--- where
--- firstChar = satisfy (\a -> isLetter a || a == '_')
--- nonFirstChar = satisfy (\a -> isDigit a || isLetter a || a == '_')
-
- -- b <- bChar
--- where bChar = satisfy (\l -> lsLetter l && l /= a)
-
-
-
-i7filev = i7linev `endBy` newline
-i7linev = many1 (includeChunkv <|> excludeChunkv)
-
-excludeChunkv = Excludev <$> (between (char '[') (char ']') $ hasABBAv)
-includeChunkv = Includev <$> hasABBAv
-
-hasABBAv =
- (try (id True <$ preambleAbba <* (many alphaNum)))
- <|>
- (id False <$ (many1 alphaNum))
-
-
-parseI7f :: String -> Either ParseError [[Chunk]]
-parseI7f input = parse i7file "(unknown)" input
-
-parseI7 :: String -> Either ParseError [Chunk]
-parseI7 input = parse i7line "(unknown)" input
-
-parseAbba :: String -> Either ParseError String
-parseAbba input = parse hasABBA "(unknown)" input
-
-parseI7v :: String -> Either ParseError [ChunkV]
-parseI7v input = parse i7linev "(unknown)" input
-
-parseI7vf :: String -> Either ParseError [[ChunkV]]
-parseI7vf input = parse i7filev "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
-
-
-allSubstrings :: Int -> [a] -> [[a]]
--- allSubstrings n es
--- | length es < n = []
--- | otherwise = (take n es) : (allSubstrings n $ tail es)
-allSubstrings n e = filter (\s -> length s == n) $ map (take n) $ tails e
-
-
-ieCandidates :: [Chunk] -> ([String], [String])
-ieCandidates chunks = (includeCandidates, excludeCandidates)
- where (includeChunks, excludeChunks) = partition (isInclude) chunks
- isABA s = (s!!0 == s!!2) && (s!!0 /= s!!1)
- candidates = (filter (isABA)) . (foldl (union) []) . (map ((allSubstrings 3) . chunkValue))
- includeCandidates = candidates includeChunks
- excludeCandidates = candidates excludeChunks
-
-inverseABA :: String -> String
-inverseABA s = [s!!1, s!!0, s!!1]
-
-supportsSSL :: [Chunk] -> Bool
-supportsSSL chunks = not $ null $ intersect abas eabas
- where (abas, babs) = ieCandidates chunks
- eabas = map (inverseABA) babs
+++ /dev/null
-module Main(main) where
-
-import Data.Array.IArray
-import Text.Parsec
-import Control.Monad (liftM, ap)
-
--- Row 1 is top, column 1 is left
-type Position = (Int, Int)
-type Screen = Array Position Bool
-
-data Direction = Row | Column deriving (Show)
-data Command = Rect Int Int | Rotate Direction Int Int deriving (Show)
-
-data ScState a = ScState (Screen -> (Screen, a))
-
-mkScreen :: Int -> Int -> Screen
-mkScreen w h = array ((0, 0), (h - 1, w - 1))
- [((i, j), False) | i <- [0..(h-1)], j <- [0..(w-1)]]
-
-showScreen :: Screen -> String
-showScreen screen = unlines [showRow r | r <- [minRow..maxRow]]
- where ((minRow, minCol), (maxRow, maxCol)) = bounds screen
- showCell True = '*'
- showCell False = ' '
- showRow r = [showCell (screen!(r, c)) | c <- [minCol..maxCol]]
-
-countLights :: Screen -> Int
-countLights screen = length $ filter (id) $ elems screen
-
-screen0 :: Screen
-screen0 = mkScreen 50 6
-
-
-main :: IO ()
-main = do
- text <- readFile "data/advent08.txt"
- let instrs = successfulParse $ parseCommands text
- part1 instrs
- part2 instrs
-
-part1 :: [Command] -> IO ()
-part1 commands =
- print $ countLights $ (extractScreen . doCommands) commands
-
-part2 :: [Command] -> IO ()
-part2 commands =
- putStrLn $ showScreen $ (extractScreen . doCommands) commands
-
-
-instance Functor ScState where
- fmap = liftM
-
-instance Applicative ScState where
- pure = return
- (<*>) = ap
-
-instance Monad ScState where
- return x = ScState (\screen -> (screen, x))
-
- (ScState st) >>= f
- = ScState (\screen -> let
- (newScreen, y) = st screen
- (ScState transformer) = f y
- in
- transformer newScreen)
-
-doCommands :: [Command] -> ScState (Int)
-doCommands [] = return 0
-doCommands (i:is) =
- do doCommand i
- doCommands is
- return 0
-
-doCommand :: Command -> ScState Int
-doCommand i = ScState (execute i)
-
-execute :: Command -> (Screen -> (Screen, Int))
-execute (Rect w h) screen = (rect screen w h, 0)
-execute (Rotate Column c n) screen = (rotateColumn screen c n, 0)
-execute (Rotate Row r n) screen = (rotateRow screen r n, 0)
-
-extractScreen :: ScState Int -> Screen
-extractScreen (ScState st) = fst (st screen0)
-
-
-
-parseCommands :: String -> Either ParseError [Command]
-parseCommands input = parse commandFile "(unknown)" input
-
-commandFile = commandLine `endBy` newline
-commandLine = (try rectCommand) <|> rotateCommand
-
-rectCommand =
- do string "rect"
- spaces
- w <- (many1 digit)
- char 'x'
- h <- (many1 digit)
- return (Rect (read w) (read h))
-
-rotateCommand =
- do string "rotate"
- spaces
- direction <- (string "row" <|> string "column")
- spaces
- string "x=" <|> string "y="
- index <- (many1 digit)
- spaces
- string "by"
- spaces
- distance <- (many1 digit)
- return (buildCommand direction index distance)
-
-buildCommand "row" i d = Rotate Row (read i) (read d)
-buildCommand "column" i d = Rotate Column (read i) (read d)
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
-
-
-
-
-rect :: Screen -> Int -> Int -> Screen
-rect screen w h = screen // newBits
- where newBits = [((i, j), True) | i <- [0..(h-1)], j <- [0..(w-1)]]
-
-rotateColumn :: Screen -> Int -> Int -> Screen
-rotateColumn screen column givenShift = screen // newCells
- where
- ((minRow, minCol), (maxRow, maxCol)) = bounds screen
- colLength = 1 + maxRow - minRow
- shift = givenShift `mod` colLength
- offset = colLength - shift
- column0 = [screen!(r, column) | r <- [minRow..maxRow]]
- newColumn = (drop offset column0) ++ (take offset column0)
- newCells = [((r, column), cell) | (r, cell) <- zip [minRow..maxRow] newColumn]
-
-rotateRow :: Screen -> Int -> Int -> Screen
-rotateRow screen row givenShift = screen // newCells
- where
- ((minRow, minCol), (maxRow, maxCol)) = bounds screen
- rowLength = 1 + maxCol - minCol
- shift = givenShift `mod` rowLength
- offset = rowLength - shift
- row0 = [screen!(row, c) | c <- [minCol..maxCol]]
- newRow = (drop offset row0) ++ (take offset row0)
- newCells = [((row, c), cell) | (c, cell) <- zip [minCol..maxCol] newRow]
+++ /dev/null
-module Main(main) where
-
-import Data.List.Split (splitOn)
-import Data.Char (isSpace)
-
-type Chunk = (Int, String)
-
-main :: IO ()
-main = do
- textL <- readFile "data/advent09.txt"
- let text = filter (not . isSpace) textL
- part1 text
- part2 text
-
-part1 :: String -> IO ()
-part1 text = do
- print $ cLength $ decompress text
-
-part2 :: String -> IO ()
-part2 text = do
- print $ cLength $ decompress2 text
-
-
-decompress :: String -> [Chunk]
-decompress text =
- if not (null msuf)
- then (1, pre):(num, chunk):drest
- else [(1, pre)]
- where
- (pre, msuf) = span ('(' /= ) text
- (marker, suf) = span (')' /= ) msuf
- ln = splitOn "x" (tail marker)
- len = read (ln!!0) :: Int
- num = read (ln!!1) :: Int
- (chunk, remainder) = splitAt len (tail suf)
- drest = decompress remainder
-
-decompress2 :: String -> [Chunk]
-decompress2 text =
- if not (null msuf)
- then [(1, pre)] ++ mulDchunks ++ drest
- else [(1, pre)]
- where
- (pre, msuf) = span ('(' /= ) text
- (marker, suf) = span (')' /= ) msuf
- ln = splitOn "x" (tail marker)
- len = read (ln!!0) :: Int
- num = read (ln!!1) :: Int
- (chunk, remainder) = splitAt len (tail suf)
- dchunks = decompress2 chunk
- mulDchunks = [(dl * num, ds) | (dl, ds) <- dchunks]
- drest = decompress2 remainder
-
-cLength :: [Chunk] -> Int
-cLength = sum . map (clen)
- where clen (n, t) = n * (length t)
-
+++ /dev/null
-import Text.Parsec hiding (State)
-import Data.Text (pack, unpack, toTitle)
-import Control.Monad.State.Lazy
-import Data.List (partition, findIndices, sort, find)
-import Data.Maybe (fromJust)
-
-data Destination = Bot | Output deriving (Show, Read, Eq)
--- Rule bot low-destination high-destination
--- Gift bot value
-data Instruction = Rule { ruleId :: Int
- , lowDestType :: Destination
- , lowDestId :: Int
- , highDestType :: Destination
- , highDestId :: Int
- } |
- Gift { giftId :: Int
- , value :: Int
- }
- deriving (Show)
-
--- bod id [item1, item2]
-data Place = Place { placeId :: Int
- , placeType :: Destination
- , items :: [Int]}
- deriving (Show)
-
--- delivery by bot of low-value and high-value
-data Event = Delivery { deliveryId :: Int
- , lowDelivery :: Int
- , highDelivery :: Int
- } |
- Update { updateId :: Int
- , updateType :: Destination
- , updateItem :: Int
- } deriving (Show)
-
-type Factory = ([Place], [Instruction], [Event])
--- data FactorySt History = FactorySt (Factory -> (Factory, History))
-
-emptyFactory :: Factory
-emptyFactory = ([], [], [])
-
-main :: IO ()
-main = do
- text <- readFile "data/advent10.txt"
- let instructions = successfulParse $ parseIfile text
- part1 instructions
- part2 instructions
-
-
-part1 :: [Instruction] -> IO ()
-part1 instructions =
- do let (_, _, events) = snd $ runState (runFactory instructions) emptyFactory
- -- let (places, instructions, events) = snd finalFactory
- print $ deliveryId $ fromJust $ findDelivery events 17 61
-
-part2 :: [Instruction] -> IO ()
-part2 instructions =
- do let (places, _, _) = snd $ runState (runFactory instructions) emptyFactory
- let outs = findOutputs places [0, 1, 2]
- let product = foldl1 (*) $ concatMap (items) outs
- print $ product
-
-
-findDelivery :: [Event] -> Int -> Int -> Maybe Event
-findDelivery events lowItem highItem = find (delivery) events
- where delivery Update {} = False
- delivery Delivery {deliveryId = bot, lowDelivery = l, highDelivery = h}
- | l == lowItem && h == highItem = True
- | otherwise = False
-
-findOutputs :: [Place] -> [Int] -> [Place]
-findOutputs outputs ids = filter (interesting) outputs
- where interesting Place {placeId = p, placeType = t, items = i}
- | (p `elem` ids) && t == Output = True
- | otherwise = False
-
-
-runFactory :: [Instruction] -> State Factory ()
-runFactory instructions = do
- addInstructions instructions
- runInstructions instructions
-
-
-
-instructionFile = instructionLine `endBy` newline
-instructionLine = ruleL <|> giftL
-
-
-ruleL =
- do (string "bot" >> spaces)
- bot <- many1 digit
- (spaces >> string "gives low to" >> spaces)
- lowDestType <- (string "output" <|> string "bot")
- spaces
- lowDest <- many1 digit
- (spaces >> string "and high to" >> spaces)
- highDestType <- (string "output" <|> string "bot")
- spaces
- highDest <- many1 digit
- let rule = Rule (read bot)
- (read $ unpack $ toTitle $ pack lowDestType)
- (read lowDest)
- (read $ unpack $ toTitle $ pack highDestType)
- (read highDest)
- return rule
-
-giftL =
- do (string "value" >> spaces)
- value <- many1 digit
- (spaces >> string "goes to bot" >> spaces)
- bot <- many1 digit
- let gift = Gift (read bot) (read value)
- return gift
-
-
-parseIfile :: String -> Either ParseError [Instruction]
-parseIfile input = parse instructionFile "(unknown)" input
-
-parseIline :: String -> Either ParseError Instruction
-parseIline input = parse instructionLine "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
-
-
-
-
-addInstructions :: [Instruction] -> State Factory ()
-addInstructions [] = return ()
-addInstructions (i:is) = do
- addInstruction i
- addInstructions is
-
-
-addInstruction :: Instruction -> State Factory ()
-addInstruction r@(Rule {lowDestType = ld, lowDestId = li,
- highDestType = hd, highDestId = hi}) =
- do (places, rules, history) <- get
- put (places, r:rules, history)
- addPlace (Place {placeType = ld, placeId = li, items = []})
- addPlace (Place {placeType = hd, placeId = hi, items = []})
-addInstruction Gift {giftId = g} =
- do addPlace (Place {placeType = Bot, placeId = g, items = []})
-
-
-addPlace :: Place -> State Factory ()
-addPlace place =
- do (places, rules, history) <- get
- if not $ placeElem place places
- then put ((place:places), rules, history)
- else return ()
-
-
-runInstructions :: [Instruction] -> State Factory ()
-runInstructions [] = return ()
-runInstructions (i:is) =
- do runInstruction i
- runInstructions is
-
-
-runInstruction :: Instruction -> State Factory ()
-runInstruction Rule {} = return ()
-runInstruction g@(Gift {}) =
- do updatePlace (giftId g) Bot (value g)
- propogateUpdates
-
-updatePlace :: Int -> Destination -> Int -> State Factory ()
-updatePlace b d i =
- do (places, instructions, events) <- get
- let (place0s, otherPlaces) = partition (samePlace (Place {placeId = b, placeType = d, items = []})) places
- let place = head place0s
- let place' = place {items = i:(items place)}
- let update = Update {updateId = b, updateType = d, updateItem = i}
- put (place':otherPlaces, instructions, update:events)
-
-
-propogateUpdates :: State Factory ()
-propogateUpdates =
- do (places, instructions, events) <- get
- let (fullBots, otherPlaces) = fullRobots places
- if (not . null) fullBots
- then do let fullBot = head fullBots
- let maybeRule = findRule instructions (placeId fullBot)
- case maybeRule of
- Nothing -> propogateUpdates
- Just rule -> do let small:large:_ = sort $ items fullBot
- let emptyBot = fullBot {items = []}
- let delivery = Delivery { deliveryId = placeId fullBot
- , lowDelivery = small
- , highDelivery = large
- }
- put (emptyBot:(tail fullBots) ++ otherPlaces,
- instructions,
- delivery:events)
- updatePlace (lowDestId rule) (lowDestType rule) small
- updatePlace (highDestId rule) (highDestType rule) large
- propogateUpdates
- else return ()
-
-
-placeElem :: Place -> [Place] -> Bool
-placeElem place places = (not . null) $ findIndices (samePlace place) places
-
-samePlace :: Place -> Place -> Bool
-samePlace p1 p2 = (placeId p1 == placeId p2) && (placeType p1 == placeType p2)
-
-fullRobots :: [Place] -> ([Place], [Place])
-fullRobots places = partition (\p -> placeType p == Bot && length (items p) >= 2) places
-
-findRule :: [Instruction] -> Int -> Maybe Instruction
-findRule instructions bot = find ruleForBot instructions
- where ruleForBot Gift {} = False
- ruleForBot Rule {ruleId = b}
- | b == bot = True
- | otherwise = False
+++ /dev/null
-module Main(main) where
-
-import Data.List (subsequences, (\\), sort, sortBy)
-import Data.Ord (comparing)
-
-data Item = Generator String | Microchip String deriving (Show, Eq)
-type Floor = [Item]
-data Building = Building Int [Floor] deriving (Show, Eq)
-
-instance Ord Item where
- compare (Generator a) (Generator b) = compare a b
- compare (Microchip a) (Microchip b) = compare a b
- compare (Generator _) (Microchip _) = LT
- compare (Microchip _) (Generator _) = GT
-
-instance Ord Building where
- compare b1 b2 = comparing estimateCost b1 b2
-
-building1 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-building2 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
- Generator "elerium", Microchip "elerium",
- Generator "dilithium", Microchip "dilithium"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-
-buildingTest = Building 0 [
- sort([Microchip "hydrogen", Microchip "lithium"]),
- [Generator "hydrogen"],
- [Generator "lithium"],
- []]
-
-main :: IO ()
-main = do
- part1
- part2
-
-
-part1 :: IO ()
--- part1 = print $ length $ init $ extractJust $ hillClimb [[buildingTest]] []
-part1 = print $ length $ init $ extractJust $ hillClimb [[building1]] []
--- part1 = print $ length $ init $ extractJust $ aStar [[building1]] []
-
-part2 :: IO ()
-part2 = print $ length $ init $ extractJust $ hillClimb [[building2]] []
-
-
-extractJust :: Maybe [a] -> [a]
-extractJust Nothing = []
-extractJust (Just x) = x
-
-hillClimb :: [[Building]] -> [Building] -> Maybe [Building]
-hillClimb [] _ = Nothing
-hillClimb (currentTrail:trails) closed =
- if isGoal (head currentTrail) then Just currentTrail
- else hillClimb newAgenda ((head currentTrail): closed)
- where newAgenda =
- sortBy (\t1 t2 -> (head t1) `compare` (head t2)) $
- trails ++ (candidates currentTrail closed)
-
-aStar :: [[Building]] -> [Building] -> Maybe [Building]
-aStar [] _ = Nothing
-aStar (currentTrail:trails) closed =
- if isGoal (head currentTrail) then Just currentTrail
- else aStar newAgenda ((head currentTrail): closed)
- where newAgenda =
- sortBy (\t1 t2 -> (trailCost t1) `compare` (trailCost t2)) $
- trails ++ (candidates currentTrail closed)
- trailCost t = estimateCost (head t) + length t - 1
-
-
-candidates :: [Building] -> [Building] -> [[Building]]
-candidates currentTrail closed = newCandidates
- where
- (candidate:trail) = currentTrail
- succs = legalSuccessors $ successors candidate
- nonloops = (succs \\ trail) \\ closed
- newCandidates = map (\n -> n:candidate:trail) nonloops
-
-isGoal :: Building -> Bool
-isGoal (Building f floors) =
- f+1 == height && (all (null) $ take f floors)
- where height = length floors
-
-isLegal :: Building -> Bool
-isLegal (Building f floors) =
- null floor
- ||
- not (any (isGenerator) floor)
- ||
- any (safePair) pairs
- where floor = floors!!f
- pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
- safePair (Generator e, Microchip f) = e == f
- safePair (Generator _, Generator _) = False
-
-isGenerator :: Item -> Bool
-isGenerator (Generator _) = True
-isGenerator (Microchip _) = False
-
-successors :: Building -> [Building]
-successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
- where
- floor = floors!!f
- items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
- nextFloors = if f == 0 then [1]
- else if f+1 == length floors then [f-1]
- else [f+1, f-1]
-
-legalSuccessors :: [Building] -> [Building]
-legalSuccessors = filter (isLegal)
-
-updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
-updateBuilding oldF oldFloors newF items = Building newF newFloors
- where newFloors = map (updateFloor) $ zip [0..] oldFloors
- updateFloor (f, fl)
- | f == oldF = sort $ fl \\ items
- | f == newF = sort $ items ++ fl
- | otherwise = fl
-
-estimateCost :: Building -> Int
-estimateCost (Building _ floors) =
- sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
-
+++ /dev/null
--- Using the idea of canonical representation of buildings from
--- https://andars.github.io/aoc_day11.html by Andrew Foote,
--- plus my extension of represening the pairs as an integer.
-
--- This version is A* search, using a list for the agenda.
-
-module Main(main) where
-
-import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
-import Data.Ord (comparing)
-import Data.Char (isDigit)
-
-data Item = Generator String | Microchip String deriving (Show, Eq)
-type Floor = [Item]
-data Building = Building Int [Floor] deriving (Show, Eq)
-data CBuilding = CBuilding Int Integer deriving (Show, Eq)
-data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int}
-
-instance Ord Item where
- compare (Generator a) (Generator b) = compare a b
- compare (Microchip a) (Microchip b) = compare a b
- compare (Generator _) (Microchip _) = LT
- compare (Microchip _) (Generator _) = GT
-
-instance Ord Building where
- compare b1 b2 = comparing estimateCost b1 b2
-
-building1 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-building0 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-building2 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
- Generator "elerium", Microchip "elerium",
- Generator "dilithium", Microchip "dilithium"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-
-buildingTest = Building 0 [
- sort([Microchip "hydrogen", Microchip "lithium"]),
- [Generator "hydrogen"],
- [Generator "lithium"],
- []]
-
-canonical :: Building -> CBuilding
-canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
- where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
- floorOf (Generator g) = head (findIndices
- (\fl -> (Generator g) `elem` fl)
- floors)
- floorOf (Microchip g) = head (findIndices
- (\fl -> (Microchip g) `elem` fl)
- floors)
- pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
-
-
-
-main :: IO ()
-main = do
- part1
- part2
-
-
-part1 :: IO ()
-part1 = print $ length $ trail $ aStar (initAgenda building1) []
-
-part2 :: IO ()
-part2 = print $ length $ trail $aStar (initAgenda building2) []
-
-initAgenda :: Building -> [Agendum]
-initAgenda b = [Agendum {current = b, trail=[], cost = estimateCost b}]
-
-
-aStar :: [Agendum] -> [CBuilding] -> Agendum
-aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
-aStar (currentAgendum:agenda) closed =
- if isGoal reached then currentAgendum
- else if creached `elem` closed
- then aStar agenda closed
- else aStar newAgenda (creached:closed)
- where
- reached = current currentAgendum
- creached = canonical reached
- newAgenda =
- sortOn (cost) $
- agenda ++ (candidates currentAgendum closed)
-
-
-candidates :: Agendum -> [CBuilding] -> [Agendum]
-candidates agendum closed = newCandidates
- where
- candidate = current agendum
- previous = trail agendum
- succs = legalSuccessors $ successors candidate
- excludable = previous ++ closed
- nonloops = filter (\s -> not $ (canonical s) `elem` excludable) succs
- newCandidates = map (\n -> makeAgendum n) nonloops
- makeAgendum new = Agendum {current = new,
- trail = (canonical candidate):previous,
- cost = estimateCost new + length previous + 1}
-
-isGoal :: Building -> Bool
-isGoal (Building f floors) =
- f+1 == height && (all (null) $ take f floors)
- where height = length floors
-
-isLegal :: Building -> Bool
-isLegal (Building f floors) =
- null floor
- ||
- not (any (isGenerator) floor)
- ||
- any (safePair) pairs
- where floor = floors!!f
- pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
- safePair (Generator e, Microchip f) = e == f
- safePair (Generator _, Generator _) = False
-
-isGenerator :: Item -> Bool
-isGenerator (Generator _) = True
-isGenerator (Microchip _) = False
-
-successors :: Building -> [Building]
-successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
- where
- floor = floors!!f
- items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
- nextFloors = if f == 0 then [1]
- else if f+1 == length floors then [f-1]
- else [f+1, f-1]
-
-legalSuccessors :: [Building] -> [Building]
-legalSuccessors = filter (isLegal)
-
-updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
-updateBuilding oldF oldFloors newF items = Building newF newFloors
- where newFloors = map (updateFloor) $ zip [0..] oldFloors
- updateFloor (f, fl)
- | f == oldF = sort $ fl \\ items
- | f == newF = sort $ items ++ fl
- | otherwise = fl
-
-estimateCost :: Building -> Int
-estimateCost (Building _ floors) =
- sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
-
+++ /dev/null
--- Using the idea of canonical representation of buildings from
--- https://andars.github.io/aoc_day11.html by Andrew Foote,
--- plus my extension of represening the pairs as an integer.
-
--- This version is hillclimbing search, using a list for the agenda.
-module Main(main) where
-
-import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
-import Data.Ord (comparing)
-import Data.Char (isDigit)
-
-data Item = Generator String | Microchip String deriving (Show, Eq)
-type Floor = [Item]
-data Building = Building Int [Floor] deriving (Show, Eq)
-data CBuilding = CBuilding Int Integer deriving (Show, Eq)
-data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int}
-
-instance Ord Item where
- compare (Generator a) (Generator b) = compare a b
- compare (Microchip a) (Microchip b) = compare a b
- compare (Generator _) (Microchip _) = LT
- compare (Microchip _) (Generator _) = GT
-
-instance Ord Building where
- compare b1 b2 = comparing estimateCost b1 b2
-
-building1 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-building0 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-building2 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
- Generator "elerium", Microchip "elerium",
- Generator "dilithium", Microchip "dilithium"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-
-buildingTest = Building 0 [
- sort([Microchip "hydrogen", Microchip "lithium"]),
- [Generator "hydrogen"],
- [Generator "lithium"],
- []]
-
-canonical :: Building -> CBuilding
-canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
- where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
- floorOf (Generator g) = head (findIndices
- (\fl -> (Generator g) `elem` fl)
- floors)
- floorOf (Microchip g) = head (findIndices
- (\fl -> (Microchip g) `elem` fl)
- floors)
- pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
-
-
-
-main :: IO ()
-main = do
- part1
- part2
-
-
-part1 :: IO ()
-part1 = print $ length $ trail $ hillClimb (initAgenda building1) []
-
-part2 :: IO ()
-part2 = print $ length $ trail $ hillClimb (initAgenda building2) []
-
-initAgenda :: Building -> [Agendum]
-initAgenda b = [Agendum {current = b, trail=[], cost = estimateCost b}]
-
-hillClimb :: [Agendum] -> [CBuilding] -> Agendum
-hillClimb [] _ = Agendum {current=buildingTest, trail=[], cost=0}
-hillClimb (currentAgendum:agenda) closed =
- if isGoal reached then currentAgendum
- else if creached `elem` closed
- then hillClimb agenda closed
- else hillClimb newAgenda (creached:closed)
- where
- reached = current currentAgendum
- creached = canonical reached
- newAgenda =
- sortOn (cost) $
- agenda ++ (candidates currentAgendum closed)
-
-
-candidates :: Agendum -> [CBuilding] -> [Agendum]
-candidates agendum closed = newCandidates
- where
- candidate = current agendum
- previous = trail agendum
- succs = legalSuccessors $ successors candidate
- excludable = previous ++ closed
- nonloops = filter (\s -> not $ (canonical s) `elem` excludable) succs
- newCandidates = map (\n -> makeAgendum n) nonloops
- makeAgendum new = Agendum {current = new,
- trail = (canonical candidate):previous,
- cost = estimateCost new}
-
-isGoal :: Building -> Bool
-isGoal (Building f floors) =
- f+1 == height && (all (null) $ take f floors)
- where height = length floors
-
-isLegal :: Building -> Bool
-isLegal (Building f floors) =
- null floor
- ||
- not (any (isGenerator) floor)
- ||
- any (safePair) pairs
- where floor = floors!!f
- pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
- safePair (Generator e, Microchip f) = e == f
- safePair (Generator _, Generator _) = False
-
-isGenerator :: Item -> Bool
-isGenerator (Generator _) = True
-isGenerator (Microchip _) = False
-
-successors :: Building -> [Building]
-successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
- where
- floor = floors!!f
- items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
- nextFloors = if f == 0 then [1]
- else if f+1 == length floors then [f-1]
- else [f+1, f-1]
-
-legalSuccessors :: [Building] -> [Building]
-legalSuccessors = filter (isLegal)
-
-updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
-updateBuilding oldF oldFloors newF items = Building newF newFloors
- where newFloors = map (updateFloor) $ zip [0..] oldFloors
- updateFloor (f, fl)
- | f == oldF = sort $ fl \\ items
- | f == newF = sort $ items ++ fl
- | otherwise = fl
-
-estimateCost :: Building -> Int
-estimateCost (Building _ floors) =
- sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
-
+++ /dev/null
--- Using the idea of canonical representation of buildings from
--- https://andars.github.io/aoc_day11.html by Andrew Foote,
--- plus my extension of represening the pairs as an integer.
-
--- This version is A* search, using a priority queue for the agenda.
-
-module Main(main) where
-
-import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
-import Data.Ord (comparing)
-import Data.Char (isDigit)
-import Data.Maybe (fromMaybe)
-import qualified Data.PQueue.Prio.Min as P
-
-data Item = Generator String | Microchip String deriving (Show, Eq)
-type Floor = [Item]
-data Building = Building Int [Floor] deriving (Show, Eq)
-data CBuilding = CBuilding Int Integer deriving (Show, Eq)
-data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int}
-type Agenda = P.MinPQueue Int Agendum
-
-instance Ord Item where
- compare (Generator a) (Generator b) = compare a b
- compare (Microchip a) (Microchip b) = compare a b
- compare (Generator _) (Microchip _) = LT
- compare (Microchip _) (Generator _) = GT
-
-instance Ord Building where
- compare b1 b2 = comparing estimateCost b1 b2
-
-building1 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-building0 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-building2 = Building 0 [
- (sort [Generator "polonium", Generator "thulium",
- Microchip "thulium", Generator "promethium", Generator "ruthenium",
- Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
- Generator "elerium", Microchip "elerium",
- Generator "dilithium", Microchip "dilithium"]),
- (sort [Microchip "polonium", Microchip "promethium"]),
- [],
- []
- ]
-
-
-buildingTest = Building 0 [
- sort([Microchip "hydrogen", Microchip "lithium"]),
- [Generator "hydrogen"],
- [Generator "lithium"],
- []]
-
-canonical :: Building -> CBuilding
-canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
- where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
- floorOf (Generator g) = head (findIndices
- (\fl -> (Generator g) `elem` fl)
- floors)
- floorOf (Microchip g) = head (findIndices
- (\fl -> (Microchip g) `elem` fl)
- floors)
- pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
-
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building1) []
-
-part2 :: IO ()
-part2 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building2) []
-
-initAgenda :: Building -> Agenda
-initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail=[], cost = estimateCost b}
-
-
-aStar :: Agenda -> [CBuilding] -> Maybe Agendum
--- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
-aStar agenda closed
- | P.null agenda = Nothing
- | otherwise =
- if isGoal reached then Just currentAgendum
- else if creached `elem` closed
- then aStar (P.deleteMin agenda) closed
- else aStar newAgenda (creached:closed)
- where
- (_, currentAgendum) = P.findMin agenda
- reached = current currentAgendum
- creached = canonical reached
- newAgenda = P.union (P.deleteMin agenda)
- (P.fromList $ candidates currentAgendum closed)
-
-
-candidates :: Agendum -> [CBuilding] -> [(Int, Agendum)]
-candidates agendum closed = newCandidates
- where
- candidate = current agendum
- previous = trail agendum
- succs = legalSuccessors $ successors candidate
- nonloops = filter (\s -> not $ (canonical s) `elem` closed) succs
- newCandidates = map (\a -> (cost a, a)) $ map (\n -> makeAgendum n) nonloops
- makeAgendum new = Agendum {current = new,
- trail = (canonical candidate):previous,
- cost = estimateCost new + length previous + 1}
-
-isGoal :: Building -> Bool
-isGoal (Building f floors) =
- f+1 == height && (all (null) $ take f floors)
- where height = length floors
-
-isLegal :: Building -> Bool
-isLegal (Building f floors) =
- null floor
- ||
- not (any (isGenerator) floor)
- ||
- any (safePair) pairs
- where floor = floors!!f
- pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
- safePair (Generator e, Microchip f) = e == f
- safePair (Generator _, Generator _) = False
-
-isGenerator :: Item -> Bool
-isGenerator (Generator _) = True
-isGenerator (Microchip _) = False
-
-successors :: Building -> [Building]
-successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
- where
- floor = floors!!f
- items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
- nextFloors = if f == 0 then [1]
- else if f+1 == length floors then [f-1]
- else [f+1, f-1]
-
-legalSuccessors :: [Building] -> [Building]
-legalSuccessors = filter (isLegal)
-
-updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
-updateBuilding oldF oldFloors newF items = Building newF newFloors
- where newFloors = map (updateFloor) $ zip [0..] oldFloors
- updateFloor (f, fl)
- | f == oldF = sort $ fl \\ items
- | f == newF = sort $ items ++ fl
- | otherwise = fl
-
-estimateCost :: Building -> Int
-estimateCost (Building _ floors) =
- sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
-
+++ /dev/null
-module Main(main) where
-
-import Text.Parsec hiding (State)
-import Text.ParserCombinators.Parsec.Number
-import Data.List (partition, union, intersect, tails)
-import Data.Char (isDigit)
-import Control.Monad.State.Lazy
-
-data Location = Literal Int | Register Char deriving (Show)
-data Instruction = Cpy Location Location |
- Inc Location |
- Dec Location |
- Jnz Location Int
- deriving (Show)
-
-data Machine = Machine { a :: Int
- , b :: Int
- , c :: Int
- , d :: Int
- , pc :: Int
- , instructions :: [Instruction]}
- deriving (Show)
-
-emptyMachine :: Machine
-emptyMachine = Machine {a=0, b=0, c=0, d=0, pc=0, instructions=[]}
-
-main :: IO ()
-main = do
- text <- readFile "data/advent12.txt"
- let instructions = successfulParse $ parseIfile text
- part1 instructions
- part2 instructions
-
-
-part1 :: [Instruction] -> IO ()
-part1 instrs =
- do let m0 = emptyMachine {instructions=instrs}
- let mf = snd $ runState runMachine m0
- print (a mf)
-
-part2 :: [Instruction] -> IO ()
-part2 instrs =
- do let m0 = emptyMachine {instructions=instrs, c=1}
- let mf = snd $ runState runMachine m0
- print (a mf)
-
-
-
-runMachine :: State Machine ()
-runMachine =
- do m <- get
- if (pc m) >= (length $ instructions m)
- then return ()
- else do executeStep
- runMachine
-
-executeStep :: State Machine ()
-executeStep =
- do m <- get
- let i = (instructions m)!!(pc m)
- put (executeInstruction i m)
-
-executeInstruction :: Instruction -> Machine -> Machine
-executeInstruction (Inc (Register r)) m = m' {pc=pc1}
- where pc1 = (pc m) + 1
- v = evaluate m (Register r)
- m' = writeValue m (Register r) (v+1)
-executeInstruction (Dec (Register r)) m = m' {pc=pc1}
- where pc1 = (pc m) + 1
- v = evaluate m (Register r)
- m' = writeValue m (Register r) (v-1)
-executeInstruction (Cpy s d) m = m' {pc=pc1}
- where pc1 = (pc m) + 1
- v = evaluate m s
- m' = writeValue m d v
-executeInstruction (Jnz s d) m
- | v == 0 = m {pc=pc1}
- | otherwise = m {pc=pcj}
- where pc1 = (pc m) + 1
- pcj = (pc m) + d
- v = evaluate m s
-
-
-evaluate :: Machine -> Location -> Int
-evaluate _ (Literal i) = i
-evaluate m (Register r) =
- case r of
- 'a' -> (a m)
- 'b' -> (b m)
- 'c' -> (c m)
- 'd' -> (d m)
-
-writeValue :: Machine -> Location -> Int -> Machine
-writeValue m (Literal i) _ = m
-writeValue m (Register r) v =
- case r of
- 'a' -> m {a=v}
- 'b' -> m {b=v}
- 'c' -> m {c=v}
- 'd' -> m {d=v}
-
-
-instructionFile = instructionLine `endBy` newline
--- instructionLine = choice [cpyL, incL, decL, jnzL]
-instructionLine = incL <|> decL <|> cpyL <|> jnzL
-
-incL = incify <$> (string "inc" *> spaces *> (oneOf "abcd"))
- where incify r = Inc (Register r)
-decL = decify <$> (string "dec" *> spaces *> (oneOf "abcd"))
- where decify r = Dec (Register r)
-cpyL = cpyify <$> (string "cpy" *> spaces *> ((many1 letter) <|> (many1 digit)))
- <*> (spaces *> (oneOf "abcd"))
- where cpyify s r = Cpy (readLocation s) (Register r)
-jnzL = jnzify <$> (string "jnz" *> spaces *> ((many1 letter) <|> (many1 digit)))
- <*> (spaces *> int)
- where jnzify r d = Jnz (readLocation r) d
-
-
-readLocation :: String -> Location
-readLocation l
- | all (isDigit) l = Literal (read l)
- | otherwise = Register (head l)
-
-
-
-parseIfile :: String -> Either ParseError [Instruction]
-parseIfile input = parse instructionFile "(unknown)" input
-
-parseIline :: String -> Either ParseError Instruction
-parseIline input = parse instructionLine "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
\ No newline at end of file
+++ /dev/null
-module Main(main) where
-
-import Data.List ((\\), nub, sortOn)
-import Data.Bits (popCount)
-import Data.Maybe (fromMaybe)
-
-type Pos = (Int, Int)
-
-seed = 1362
-
-goal1 = (31, 39)
-
-main :: IO ()
-main = do
- part1
- part2
-
-
-part1 :: IO ()
-part1 = print $ length $ tail $ fromMaybe [] $ aStar [[(1, 1)]] []
-
-part2 :: IO ()
-part2 = do print $ length $ tail $ edl 50 [[(1, 1)]] []
- putStrLn $ showRoomR 30 25 $ edl 50 [[(1, 1)]] []
-
-
--- extractJust :: Maybe [a] -> [a]
--- extractJust Nothing = []
--- extractJust (Just x) = x
-
-isWall :: Int -> Int -> Bool
-isWall x y = odd $ popCount n
- where
- n = x*x + 3*x + 2*x*y + y + y*y + seed
-
-
-showRoom w h = showRoomR w h []
-
-showRoomR w h reached = unlines rows
- where
- rows = [row x | x <- [0..h]]
- row x = [showCell x y | y <- [0..w]]
- showCell x y = if (isWall x y)
- then '#'
- else if (x, y) `elem` reached
- then 'O'
- else '.'
-
-
-aStar :: [[Pos]] -> [Pos] -> Maybe [Pos]
-aStar [] _ = Nothing
-aStar (currentTrail:trails) closed =
- if isGoal (head currentTrail) then Just currentTrail
- else if (head currentTrail) `elem` closed then aStar trails closed
- else aStar newAgenda ((head currentTrail): closed)
- where newAgenda =
- sortOn (\a -> trailCost a) $
- trails ++ (candidates currentTrail closed)
- trailCost t = estimateCost (head t) + length t - 1
-
-
--- exhaustive depth-limited
-edl :: Int -> [[Pos]] -> [Pos] -> [Pos]
-edl _ [] closed = nub closed
-edl limit (currentTrail:trails) closed =
- if (length currentTrail) > (limit+1) then edl limit trails ((head currentTrail):closed)
- else if (head currentTrail) `elem` closed then edl limit trails closed
- else edl limit newAgenda ((head currentTrail):closed)
- where newAgenda = trails ++ (candidates currentTrail closed)
-
-candidates :: [Pos] -> [Pos] -> [[Pos]]
-candidates currentTrail closed = newCandidates
- where
- (candidate:trail) = currentTrail
- succs = legalSuccessors $ successors candidate
- nonloops = (succs \\ trail) \\ closed
- newCandidates = map (\n -> n:candidate:trail) nonloops
-
-isGoal :: Pos -> Bool
-isGoal p = p == goal1
-
-isLegal :: Pos -> Bool
-isLegal (x, y) =
- x >= 0 && y >= 0 && (not $ isWall x y)
-
-successors :: Pos -> [Pos]
-successors (x, y) = [(x-1, y), (x+1, y), (x, y-1), (x, y+1)]
-
-legalSuccessors :: [Pos] -> [Pos]
-legalSuccessors = filter (isLegal)
-
-estimateCost :: Pos -> Int
-estimateCost (x, y) = abs (x - gx) + abs (y - gy)
- where (gx, gy) = goal1
-
+++ /dev/null
-module Main(main) where
-
-import Data.List (nub, tails, null)
-import Data.Hash.MD5 (md5s, Str(..))
-
-salt = "yjdafjpo"
--- salt = "abc"
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
- where sq = md5sequence
-
-part2 :: IO ()
-part2 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
- where sq = md5sequenceS
-
-md5sequence :: [String]
-md5sequence = [makeMd5 i | i <- [0..]]
- where makeMd5 i = md5s (Str (salt ++ show i))
-
-md5sequenceS :: [String]
-md5sequenceS = [makeMd5 i | i <- [0..]]
- where makeMd5 i = stretch $ md5s (Str (salt ++ show i))
- stretch h0 = foldr (\_ h -> md5s (Str h)) h0 [1..2016]
-
-possibleKey :: [String] -> Int-> Bool
-possibleKey s = not . null . repeats 3 . ((!!) s)
-
-confirmKey :: [String] -> Int -> Bool
-confirmKey s i = any (confirmation) $ take 1000 $ drop (i+1) s
- where c = head $ repeats 3 $ s!!i
- confirmation m = c `elem` (repeats 5 m)
-
-repeats :: Int -> String -> [String]
-repeats n = filter (null . tail) . map (nub) . substrings n
-
-substrings :: Int -> [a] -> [[a]]
-substrings l = filter (\s -> (length s) == l) . map (take l) . tails
+++ /dev/null
-module Main(main) where
-
-import Data.List (nub, tails)
-import Data.ByteString.Char8 (pack)
-import Crypto.Hash (hash, Digest, MD5)
-
-salt = "yjdafjpo"
--- salt = "abc"
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
- where sq = md5sequence
-
-part2 :: IO ()
-part2 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
- where sq = md5sequenceS
-
-getHash :: String -> String
-getHash bs = show (hash $ pack bs :: Digest MD5)
-
-md5sequence :: [String]
-md5sequence = [makeMd5 i | i <- [0..]]
- where makeMd5 i = getHash (salt ++ show i)
-
-md5sequenceS :: [String]
-md5sequenceS = [makeMd5 i | i <- [0..]]
- where makeMd5 i = stretch $ getHash (salt ++ show i)
- stretch h0 = foldr (\_ h -> getHash h) h0 [1..2016]
-
-possibleKey :: [String] -> Int-> Bool
-possibleKey s = not . null . repeats 3 . ((!!) s)
-
-confirmKey :: [String] -> Int -> Bool
-confirmKey s i = any (confirmation) $ take 1000 $ drop (i+1) s
- where c = head $ repeats 3 $ s!!i
- confirmation m = c `elem` (repeats 5 m)
-
-repeats :: Int -> String -> [String]
-repeats n = filter (null . tail) . map (nub) . substrings n
-
-substrings :: Int -> [a] -> [[a]]
-substrings l = filter (\s -> (length s) == l) . map (take l) . tails
+++ /dev/null
-module Main(main) where
-
-import Data.List (nub, tails)
-import Data.ByteString.Char8 (pack)
-import Crypto.Hash (hash, Digest, MD5)
-import Control.Parallel.Strategies (withStrategy, parBuffer, rdeepseq)
-
-salt = "yjdafjpo"
--- salt = "abc"
-
-stretch_factor = [1..2016]
--- stretch_factor = [1..100]
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
- where sq = md5sequence
-
-part2 :: IO ()
-part2 = print $ head $ drop 63 $ filter (\i -> possibleKey sq i && confirmKey sq i) [0..]
- where sq = md5sequenceS
-
-getHash :: String -> String
-getHash bs = show (hash $ pack bs :: Digest MD5)
-
-md5sequence :: [String]
--- md5sequence = [makeMd5 i | i <- [0..]]
-md5sequence = withStrategy (parBuffer 100 rdeepseq) $ map (makeMd5) [0..]
- where makeMd5 i = getHash (salt ++ show i)
-
-md5sequenceS :: [String]
--- md5sequenceS = [makeMd5 i | i <- [0..]]
-md5sequenceS = withStrategy (parBuffer 100 rdeepseq) $ map (makeMd5) [0..]
- where makeMd5 i = stretch $ getHash (salt ++ show i)
- stretch h0 = foldr (\_ h -> getHash h) h0 stretch_factor
-
-possibleKey :: [String] -> Int-> Bool
-possibleKey s = not . null . repeats 3 . ((!!) s)
-
-confirmKey :: [String] -> Int -> Bool
-confirmKey s i = any (confirmation) $ take 1000 $ drop (i+1) s
- where c = head $ repeats 3 $ s!!i
- confirmation m = c `elem` (repeats 5 m)
-
-repeats :: Int -> String -> [String]
-repeats n = filter (null . tail) . map (nub) . substrings n
-
-substrings :: Int -> [a] -> [[a]]
-substrings l = filter (\s -> (length s) == l) . map (take l) . tails
+++ /dev/null
-module Main(main) where
-
-import Text.Parsec
-import Text.ParserCombinators.Parsec.Number
-
-type Disk = (Int -> Bool)
-
-main :: IO ()
-main = do
- text <- readFile "data/advent15.txt"
- let disks = successfulParse $ parseIfile text
- part1 disks
- part2 disks
-
-part1 :: [Disk] -> IO ()
-part1 disks = print $ head $ filter (canFall disks) [0..]
-
-part2 :: [Disk] -> IO ()
-part2 disks = print $ head $ filter (canFall disks2) [0..]
- where disks2 = disks ++ [diskify 7 11 0]
-
-canFall :: [Disk] -> Int -> Bool
-canFall ds i = all (\d -> (d i)) ds
-
-
-instructionFile = instructionLine `endBy` newline
-instructionLine = diskify <$> (string "Disc #" *> int)
- <*> (string " has " *> int)
- <*> (string " positions; at time=0, it is at position " *> int)
- <* (string ".")
-
-diskify :: Int -> Int -> Int -> (Int -> Bool)
-diskify n size pos0 = (\i -> (size + n + pos0 + i) `mod` size == 0)
-
-parseIfile :: String -> Either ParseError [Disk]
-parseIfile input = parse instructionFile "(unknown)" input
-
-parseIline :: String -> Either ParseError Disk
-parseIline input = parse instructionLine "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
+++ /dev/null
-module Main(main) where
-
-import Text.Parsec
-import Text.ParserCombinators.Parsec.Number
-
-main :: IO ()
-main = do
- text <- readFile "data/advent15.txt"
- let disks = successfulParse $ parseIfile text
- part1 disks
- part2 disks
-
-part1 :: [[Int]] -> IO ()
-part1 disks = print $ head $ filter (canFall disks) [0..]
-
-part2 :: [[Int]] -> IO ()
-part2 disks = print $ head $ filter (canFall disks2) [0..]
- where disks2 = disks ++ [drop 7 $ drop 0 $ cycle [0..(11-1)]]
-
-canFall :: [[Int]] -> Int -> Bool
-canFall ds i = all (\d -> (d!!i) == 0) ds
-
-
-instructionFile = instructionLine `endBy` newline
-instructionLine = diskify <$> (string "Disc #" *> int)
- <*> (string " has " *> int)
- <*> (string " positions; at time=0, it is at position " *> int)
- <* (string ".")
- where diskify n size pos0 = drop n $ drop pos0 $ cycle [0..(size-1)]
-
-parseIfile :: String -> Either ParseError [[Int]]
-parseIfile input = parse instructionFile "(unknown)" input
-
-parseIline :: String -> Either ParseError [Int]
-parseIline input = parse instructionLine "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
+++ /dev/null
-module Main(main) where
-
-import Data.List (nub)
-
-input = "11100010111110100"
-disk1length = 272
-disk2length = 35651584
-
--- input = "10000"
--- disk1length = 20
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = putStrLn $ checksum $ take disk1length $ expand disk1length input
-
-part2 :: IO ()
-part2 = putStrLn $ checksum $ take disk2length $ expand disk2length input
-
-
-expand :: Int -> String -> String
-expand len a
- | length a >= len = a
- | otherwise = expand len $ a ++ "0" ++ b
- where b = map (invert) $ reverse a
- invert '0' = '1'
- invert '1' = '0'
-
-checksum :: String -> String
-checksum digits
- | odd $ length digits = digits
- | otherwise = checksum $ map (checksumPair) $ pairs digits
- where checksumPair p = if (length $ nub p) == 1 then '1' else '0'
-
-
-pairs :: [a] -> [[a]]
-pairs [] = []
-pairs xs = [p] ++ (pairs ys)
- where (p, ys) = splitAt 2 xs
+++ /dev/null
-module Main(main) where
-
-input = "11100010111110100"
-disk1length = 272
-disk2length = 35651584
-
--- input = "10000"
--- disk1length = 20
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = print $ fill disk1length input
-
-part2 :: IO ()
-part2 = print $ fill disk2length input
-
-fill :: Int -> String -> String
-fill len filler = deBool $ checksum $ take len $ expand len $ enBool filler
-
-enBool :: String -> [Bool]
-enBool = map (== '1')
-
-deBool :: [Bool] -> String
-deBool = map (\b -> if b then '1' else '0')
-
-
-expand :: Int -> [Bool] -> [Bool]
-expand len = head . dropWhile ((<= len) . length) . iterate expandStep
-
-expandStep :: [Bool] -> [Bool]
-expandStep a = a ++ [False] ++ b
- where b = map (not) $ reverse a
-
-checksum :: [Bool] -> [Bool]
-checksum = head . dropWhile (even . length) . iterate checksumStep
-
-checksumStep :: [Bool] -> [Bool]
-checksumStep [] = []
-checksumStep [x] = [x]
-checksumStep (x:y:xs) = (x==y):(checksumStep xs)
-
+++ /dev/null
-module Main(main) where
-
-import Data.ByteString.Char8 (pack)
-import qualified Crypto.Hash as C
-
-type Position = (Int, Int)
-data Agendum = Agendum {position :: Position, path :: String, hash :: String} deriving (Show, Eq)
-type Agenda = [Agendum]
-
--- input = "hijkl"
--- input = "ihgpwlah"
-
-input = "qljzarfv" -- my input
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = putStrLn $ path $ extractJust $ bfs initialAgenda
-
-part2 :: IO ()
-part2 = print $ bfs2 initialAgenda 0
-
-initialAgenda :: Agenda
-initialAgenda = [Agendum {position=(1, 1), path="", hash=(getHash "")}]
-
-getHash :: String -> String
-getHash path = show (C.hash $ pack (input ++ path) :: C.Digest C.MD5)
-
-extractJust :: Maybe Agendum -> Agendum
-extractJust Nothing = head initialAgenda
-extractJust (Just x) = x
-
-bfs :: Agenda -> Maybe Agendum
-bfs [] = Nothing
-bfs (current:agenda) =
- if isGoal current then Just current
- else bfs (agenda ++ (successors current))
-
-bfs2 :: Agenda -> Int -> Int
-bfs2 [] l = l
-bfs2 (current:agenda) l =
- if isGoal current then bfs2 agenda (length $ path $ current)
- else bfs2 (agenda ++ (successors current)) l
-
-isGoal :: Agendum -> Bool
-isGoal agendum = (position agendum) == (4, 4)
-
-isLegalPos :: Position -> Bool
-isLegalPos p = fst p >= 1 && fst p <= 4 && snd p >= 1 && snd p <= 4
-
-successors :: Agendum -> Agenda
-successors state = [Agendum {position = step p0 ld,
- path = path0 ++ [ld],
- hash = getHash (path0 ++ [ld])} | ld <- legalDoors ]
- where
- p0 = position state
- path0 = path state
- h0 = hash state
- doors = openDoors h0
- legalDoors = filter (isLegalPos . (step p0)) doors
-
-openDoors :: String -> String
-openDoors h = up ++ down ++ left ++ right
- where
- up = if h!!0 `elem` "bcdef" then "U" else ""
- down = if h!!1 `elem` "bcdef" then "D" else ""
- left = if h!!2 `elem` "bcdef" then "L" else ""
- right = if h!!3 `elem` "bcdef" then "R" else ""
-
-step :: Position -> Char -> Position
-step (r, c) 'U' = (r-1, c)
-step (r, c) 'D' = (r+1, c)
-step (r, c) 'L' = (r, c-1)
-step (r, c) 'R' = (r, c+1)
+++ /dev/null
-module Main(main) where
-
-import Data.List (tails)
-
--- input = "..^^."
--- input = ".^^.^.^^^^"
-input = "^.^^^.^..^....^^....^^^^.^^.^...^^.^.^^.^^.^^..^.^...^.^..^.^^.^..^.....^^^.^.^^^..^^...^^^...^...^."
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
--- part1 = putStrLn $ unlines $ map (showRow) $ take 10 $ iterate nextRow $ readRow input
-part1 = print $ length $ filter (not) $ concat $ take 40 $ iterate nextRow $ readRow input
-
-part2 :: IO ()
-part2 = print $ length $ filter (not) $ concat $ take 400000 $ iterate nextRow $ readRow input
-
-readRow :: String -> [Bool]
-readRow = map (=='^')
-
-showRow :: [Bool] -> String
-showRow = map (\c -> if c then '^' else '.')
-
-extended :: [Bool] -> [Bool]
-extended row = [False] ++ row ++ [False]
-
-nextRow :: [Bool] -> [Bool]
-nextRow = map (isTrap) . segments . extended
-
-segments :: [a] -> [[a]]
-segments = filter ((==3) . length) . map (take 3) . tails
-
-isTrap :: [Bool] -> Bool
-isTrap segment
- | segment == [True, True, False] = True
- | segment == [False, True, True] = True
- | segment == [True, False, False] = True
- | segment == [False, False, True] = True
- | otherwise = False
+++ /dev/null
-module Main(main) where
-
-import Data.List (tails, foldl')
-
--- input = "..^^."
--- input = ".^^.^.^^^^"
-input = "^.^^^.^..^....^^....^^^^.^^.^...^^.^.^^.^^.^^..^.^...^.^..^.^^.^..^.....^^^.^.^^^..^^...^^^...^...^."
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = print $ fst $ foldl' nextRowFold (countSafe row, row) [2..40]
- where row = readRow input
-
-part2 :: IO ()
-part2 = print $ fst $ foldl' nextRowFold (countSafe row, row) [2..400000]
- where row = readRow input
-
-readRow :: String -> [Bool]
-readRow = map (=='^')
-
-showRow :: [Bool] -> String
-showRow = map (\c -> if c then '^' else '.')
-
-extended :: [Bool] -> [Bool]
-extended row = [False] ++ row ++ [False]
-
-nextRow :: [Bool] -> [Bool]
-nextRow = map (isTrap) . segments . extended
-
-nextRowFold :: (Int, [Bool]) -> Int -> (Int, [Bool])
-nextRowFold (n, row) _ = (n + countSafe newRow, newRow)
- where newRow = nextRow row
-
-countSafe :: [Bool] -> Int
-countSafe = length . filter (not)
-
-segments :: [a] -> [[a]]
-segments = filter ((==3) . length) . map (take 3) . tails
-
-isTrap :: [Bool] -> Bool
-isTrap segment
- | segment == [True, True, False] = True
- | segment == [False, True, True] = True
- | segment == [True, False, False] = True
- | segment == [False, False, True] = True
- | otherwise = False
+++ /dev/null
-module Main(main) where
-
-import Prelude hiding (length, take, drop)
-import Data.Sequence
-
--- input = 5
-input = 3012210
-
-main :: IO ()
-main = do
- part1
- part2
-
-part1 :: IO ()
-part1 = print $ 2 * (input - 2 ^ (toInteger (floor $ logBase 2 (fromIntegral input)))) + 1
-
-part2 :: IO ()
-part2 = print $ flip index 0 $ presentSteps initial
-
-presentSteps :: Seq Int -> Seq Int
-presentSteps elves
- | isFinished elves = elves
- | otherwise = presentSteps $ next elves
-
-initial :: Seq Int
-initial = fromList [1..input]
-
-isFinished :: Seq Int -> Bool
-isFinished elves = length elves == 1
-
-next :: Seq Int -> Seq Int
-next elves = prefix >< (midfix |> suffix)
- where
- target = length elves `quot` 2
- prefix = drop 1 $ take target elves
- midfix = drop (target+1) elves
- suffix = index elves 0
+++ /dev/null
-module Main(main) where
-
-import Text.Parsec
-import Text.ParserCombinators.Parsec.Number
-import Data.List (foldl')
-
-data Interval = Interval Int Int deriving (Show, Eq)
-
-low :: Interval -> Int
-low (Interval l _) = l
-
-high :: Interval -> Int
-high (Interval _ h) = h
-
-main :: IO ()
-main = do
- text <- readFile "data/advent20.txt"
- let intervals = successfulParse $ parseIfile text
- part1 intervals
- part2 intervals
-
-part1 :: [Interval] -> IO ()
-part1 intervals = print $ (+1) $ high $ head $ foldl' (mergeAdjacent) [] $ foldl' (merge) [] intervals
-
-part2 :: [Interval] -> IO ()
-part2 intervals = do
- let ints = foldl' (mergeAdjacent) [] $ foldl' (merge) [] intervals
- let gapCount = gaps ints
- let lowGap = low $ head ints
- let highGap = 4294967295 - (high $ last ints)
- print (lowGap + gapCount + highGap)
-
-disjoint :: Interval -> Interval -> Bool
-disjoint (Interval a b) (Interval c d)
- | b < c = True
- | d < a = True
- | a > d = True
- | c > b = True
- | otherwise = False
-
-intersect :: Interval -> Interval -> Bool
-intersect a b = not $ disjoint a b
-
-merge :: [Interval] -> Interval -> [Interval]
-merge [] i0 = [i0]
-merge (i1:intervals) i0
- | (high i0) < (low i1) = i0:i1:intervals
- | intersect i0 i1 = merge intervals (Interval a' b')
- | otherwise = i1:(merge intervals i0)
- where a' = minimum [low i0, low i1]
- b' = maximum [high i0, high i1]
-
-mergeAdjacent :: [Interval] -> Interval -> [Interval]
-mergeAdjacent [] i0 = [i0]
-mergeAdjacent (i1:intervals) i0
- | high i0 + 1 == low i1 = (Interval (low i0) (high i1)):intervals
- | low i0 == high i1 + 1 = (Interval (low i1) (high i0)):intervals
- | otherwise = i1:(mergeAdjacent intervals i0)
-
-gaps :: [Interval] -> Int
-gaps [] = 0
-gaps [_] = 0
-gaps ((Interval _ b):(Interval c d):intervals) =
- (c - b - 1) + gaps ((Interval c d):intervals)
-
-intervalFile = intervalLine `endBy` newline
-intervalLine = Interval <$> int <*> (string "-" *> int)
-
-parseIfile :: String -> Either ParseError [Interval]
-parseIfile input = parse intervalFile "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
+++ /dev/null
-module Main(main) where
-
-import Text.Parsec hiding (State)
-import Text.ParserCombinators.Parsec.Number
-import Data.Maybe (fromJust)
-import Data.List (elemIndex)
-
-import Control.Monad.Identity
-import Control.Monad.State
-import Control.Monad.Writer
-
-data Instruction = SwapPosition Int Int
- | SwapLetter Char Char
- | RotateSteps Int
- | RotateLetter Char
- | Reverse Int Int
- | Move Int Int
- deriving (Show, Eq)
-
-data Log = Log {
- action :: String
- } deriving (Show)
-
-data Password = Password {
- password :: String
- } deriving (Show)
-
-
-type App = WriterT [Log] (StateT Password Identity)
-
-infixl 9 ??
-
-(??) :: Eq a => [a] -> a -> Int
-(??) items item = fromJust $ elemIndex item items
-
-
-initial = "abcdefgh"
-final = "fbgdceah"
-
-testInstructions = "\
-\swap position 4 with position 0\n\
-\swap letter d with letter b\n\
-\reverse positions 0 through 4\n\
-\rotate left 1 step\n\
-\move position 1 to position 4\n\
-\move position 3 to position 0\n\
-\rotate based on position of letter b\n\
-\rotate based on position of letter d\n"
-
-main :: IO ()
-main = do
- -- let ti = successfulParse $ parseIfile testInstructions
- -- part1 ti "abcde"
- -- part2 (reverse ti) "decab"
- text <- readFile "data/advent21.txt"
- let instructions = successfulParse $ parseIfile text
- part1 instructions initial
- part2 (reverse instructions) final
-
-part1 :: [Instruction] -> String -> IO ()
-part1 instructions start =
- let st = Password {password = start}
- ((_, log), st') = runIdentity (runStateT (runWriterT (apply instructions)) st)
- in do
- -- putStrLn $ unlines $ map (action) log
- putStrLn $ password st'
-
-part2 :: [Instruction] -> String -> IO ()
-part2 instructions end =
- let st = Password {password = end}
- ((_, log), st') = runIdentity (runStateT (runWriterT (unApply instructions)) st)
- in do
- -- putStrLn $ unlines $ map (action) log
- putStrLn $ password st'
-
-
-apply :: [Instruction] -> App ()
-apply [] = return ()
-apply (i:is) =
- do st <- get
- let p0 = password st
- let p1 = applyInstruction i p0
- put st {password = p1}
- tell [Log (p0 ++ " -> " ++ p1 ++ " : " ++ (show i))]
- apply is
-
-
-applyInstruction :: Instruction -> String -> String
-applyInstruction (SwapPosition from to) p0
- | from == to = p0
- | otherwise = prefix ++ [p0!!end] ++ midfix ++ [p0!!start] ++ suffix
- where start = minimum [from, to]
- end = maximum [from, to]
- prefix = take start p0
- midfix = take (end-start-1) $ drop (start+1) p0
- suffix = drop (end+1) p0
-
-applyInstruction (SwapLetter l0 l1) p0 = applyInstruction (SwapPosition (p0??l0) (p0??l1)) p0
-
-applyInstruction (RotateSteps n) p0 = (drop n' p0) ++ (take n' p0)
- where n' = if n < 0
- then (-1 * n)
- else (length p0) - n
-
-applyInstruction (RotateLetter l) p0 = applyInstruction (RotateSteps n) p0
- where n = (1 + (p0??l) + if (p0??l) >= 4 then 1 else 0) `mod` (length p0)
-
-applyInstruction (Reverse from to) p0
- | from == to = p0
- | otherwise = prefix ++ (reverse midfix) ++ suffix
- where start = minimum [from, to]
- end = maximum [from, to]
- prefix = take start p0
- midfix = take (end-start+1) $ drop start p0
- suffix = drop (end+1) p0
-
-applyInstruction (Move from to) p0
- | from == to = p0
- | otherwise = prefix ++ [p0!!from] ++ suffix
- where without = take from p0 ++ drop (from+1) p0
- prefix = take to without
- suffix = drop (to) without
-
-
-unApply :: [Instruction] -> App ()
-unApply [] = return ()
-unApply (i:is) =
- do st <- get
- let p0 = password st
- let p1 = unApplyInstruction i p0
- put st {password = p1}
- tell [Log (p1 ++ " <- " ++ p0 ++ " : " ++ (show i))]
- unApply is
-
-unApplyInstruction :: Instruction -> String -> String
-unApplyInstruction (SwapPosition from to) p0 = applyInstruction (SwapPosition from to) p0
-unApplyInstruction (SwapLetter l0 l1) p0 = applyInstruction (SwapLetter l0 l1) p0
-unApplyInstruction (RotateSteps n) p0 = applyInstruction (RotateSteps (-1 * n)) p0
-unApplyInstruction (Reverse from to) p0 = applyInstruction (Reverse from to) p0
-unApplyInstruction (Move from to) p0 = applyInstruction (Move to from) p0
-unApplyInstruction (RotateLetter l) p0 = applyInstruction (RotateSteps n) p0
- where n = case (p0??l) of
- 0 -> -1
- 1 -> -1
- 2 -> 2
- 3 -> -2
- 4 -> 1
- 5 -> -3
- 6 -> 0
- 7 -> -4
- -- where n = case (p0??l) of
- -- 0 -> -1
- -- 1 -> -1
- -- 2 -> 1
- -- 3 -> -2
- -- 4 -> 1
-
-
-instructionFile = instructionLine `endBy` newline
-instructionLine = choice [ swapL
- , rotateL
- , reverseL
- , moveL
- ]
-
-swapL = (try (string "swap ")) *> (swapPosL <|> swapLetterL)
-
-swapPosL = SwapPosition <$> (string "position" *> spaces *> int)
- <*> (spaces *> string "with position" *> spaces *> int)
-
-swapLetterL = SwapLetter <$> (string "letter" *> spaces *> letter)
- <*> (spaces *> string "with letter" *> spaces *> letter)
-
-rotateL = (try (string "rotate ")) *> (rotateDirL <|> rotateLetterL)
-
-rotateDirL = rotateStepify <$> ((string "left") <|> (string "right"))
- <*> (spaces *> int <* spaces <* skipMany letter)
- where rotateStepify dir n = case dir of
- "left" -> (RotateSteps (-1 * n))
- "right" -> (RotateSteps n)
-rotateLetterL = RotateLetter <$> (string "based on position of letter " *> letter)
-
-reverseL = Reverse <$> (string "reverse positions" *> spaces *> int)
- <*> (spaces *> (string "through") *> spaces *> int)
-
-moveL = Move <$> (string "move position" *> spaces *> int)
- <*> (spaces *> (string "to position") *> spaces *> int)
-
-
-parseIfile :: String -> Either ParseError [Instruction]
-parseIfile input = parse instructionFile "(unknown)" input
-
-parseIline :: String -> Either ParseError Instruction
-parseIline input = parse instructionLine "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
+++ /dev/null
-module Main(main) where
-
-import GHC.Generics (Generic)
-import Text.Parsec
-import Text.ParserCombinators.Parsec.Number
-import Data.Maybe (catMaybes, fromJust)
-import Data.List (find, delete, sort, sortOn, reverse)
-
-data Node = Node { x :: Int
- , y :: Int
- , size :: Int
- , used :: Int
- , available :: Int
- , use_pc :: Int
- } deriving (Show, Eq, Ord)
-
-data SearchState = SearchState { cx :: Int
- , cy :: Int
- , grid :: [Node]
- } deriving (Show)
-instance Ord SearchState where
- s1 `compare` s2 = (heuristic s1) `compare` (heuristic s2)
-instance Eq SearchState where
- s1 == s2 = equivalentState s1 s2
-
-equivalentState :: SearchState -> SearchState -> Bool
-equivalentState s1 s2 =
- let h1 = fromJust $ find (\n -> used n == 0) $ grid s1
- h2 = fromJust $ find (\n -> used n == 0) $ grid s2
- in
- cx s1 == cx s2 && cy s1 == cy s2 &&
- x h1 == x h2 && y h1 == y h2
-
-
-testGrid = "\
-\Filesystem Size Used Avail Use%\n\
-\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
-\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
-\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
-\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
-\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
-\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
-\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
-\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
-\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
-\"
-
-main :: IO ()
-main = do
- text <- readFile "data/advent22.txt"
- let sizes = successfulParse $ parseFile text
- part1 sizes
- part2 sizes
-
-part1 :: [Node] -> IO ()
-part1 sizes = print $ length viable
- where viable = [(a, b) | a <- sizes,
- b <- sizes,
- a /= b,
- (used a) > 0,
- (used a) <= (available b)]
-
-
-part2 :: [Node] -> IO ()
-part2 sizes =
- -- do let testSizes = successfulParse $ parseFile testGrid
- -- putStrLn $ searchTraceH $ reverse $ aStar [[startSt testSizes]] []
- print (26 + 26 + 29 + 5 * 36)
-
-
-aStar :: [[SearchState]] -> [SearchState] -> [SearchState]
-aStar [] _ = []
-aStar (currentPath:agenda) closed =
- if isGoal reached then currentPath
- else if reached `elem` closed
- then aStar agenda closed
- else aStar newAgenda (reached:closed)
- where
- reached = head currentPath
- successorPaths = map (:currentPath) $ successors reached
- newAgenda = sortOn (cost) $ successorPaths ++ agenda
-
-
-searchTrace :: [SearchState] -> String
-searchTrace ss = unlines $ map (sst) ss
- where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ")"
-
-searchTraceH :: [SearchState] -> String
-searchTraceH ss = unlines $ map (sst) ss
- where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ") :: " ++ holeS s
- hole sk = fromJust $ find (\n -> used n == 0) $ grid sk
- holeS sk = "(" ++ show (x $ hole sk) ++ ", " ++ show (y $ hole sk) ++ ")"
-
-startSt :: [Node] -> SearchState
-startSt nodes = SearchState {cx = maximum xs, cy = 0, grid = nodes}
- where xs = map (\n -> x n) nodes
-
-isGoal :: SearchState -> Bool
-isGoal st = cx st == 0 && cy st == 0
-
-adjacent :: Node -> Node -> Bool
-adjacent n1 n2 = abs ((x n1) - (x n2)) + abs ((y n1) - (y n2)) == 1
-
--- A move of data from n1 to n2 is legal.
-legal :: Node -> Node -> Bool
-legal n1 n2 = adjacent n1 n2 && used n1 > 0 && used n1 <= available n2
-
-heuristic :: SearchState -> Int
-heuristic st = (cx st) + (cy st)
-
-successors :: SearchState -> [SearchState]
-successors st = map (newState st current) possibleMoves
- where nodes = grid st
- current = fromJust $ find (\n -> (x n) == (cx st) && (y n) == (cy st)) nodes
- possibleMoves = [(n1, n2) | n1 <- nodes, n2 <- nodes, legal n1 n2]
-
-
--- Moving data from n1 to n2
-newState :: SearchState -> Node -> (Node, Node) -> SearchState
-newState st current (n1, n2) = st {cx = cx', cy = cy', grid = grid'}
- where cx' = if current == n1 then x n2 else x current
- cy' = if current == n1 then y n2 else y current
- grid' = sort $ (n2 {used = (used n2 + used n1), available = (available n2 - used n1)}):
- (n1 {used = 0, available = (size n1)}):
- (delete n1 $ delete n2 (grid st))
-
-cost :: [SearchState] -> Int
-cost p = (heuristic $ head p) + (length p)
-
-
-
-duFile = duLine `sepEndBy` newline
--- duLine = (optionMaybe nodeL)
-
-duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
-
-headerL = (many (noneOf "\r\n"))
-
-nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
- <*> (string "-y" *> int)
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "%")
- where nodeify x y size used available use_pc =
- Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
-
-parseFile :: String -> Either ParseError [Maybe Node]
-parseFile input = parse duFile "(unknown)" input
-
-parseLine :: String -> Either ParseError (Maybe Node)
-parseLine input = parse duLine "(unknown)" input
-
-successfulParse :: Either ParseError [Maybe a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = catMaybes a
+++ /dev/null
-{-# LANGUAGE DeriveGeneric #-}
-
-module Main(main) where
-
-import GHC.Generics (Generic)
-import Text.Parsec
-import Text.ParserCombinators.Parsec.Number
-import Data.Maybe (catMaybes, fromJust)
-import Data.List (find, delete, sort)
-import Data.Graph.AStar
-import Data.Hashable
-import qualified Data.HashSet
-
-data Node = Node { x :: Int
- , y :: Int
- , size :: Int
- , used :: Int
- , available :: Int
- , use_pc :: Int
- } deriving (Show, Eq, Ord, Generic)
-instance Hashable Node
-
-data SearchState = SearchState { cx :: Int
- , cy :: Int
- , grid :: [Node]
- } deriving (Show, Eq, Generic)
-instance Hashable SearchState
-instance Ord SearchState where
- s1 `compare` s2 = (heuristic s1) `compare` (heuristic s2)
-
-
-testGrid = "\
-\Filesystem Size Used Avail Use%\n\
-\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
-\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
-\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
-\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
-\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
-\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
-\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
-\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
-\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
-\"
-
-main :: IO ()
-main = do
- text <- readFile "data/advent22.txt"
- let sizes = successfulParse $ parseFile text
- part1 sizes
- part2 sizes
-
-part1 :: [Node] -> IO ()
-part1 sizes = print $ length viable
- where viable = [(a, b) | a <- sizes,
- b <- sizes,
- a /= b,
- (used a) > 0,
- (used a) <= (available b)]
-
-
-part2 :: [Node] -> IO ()
-part2 sizes =
- -- do let testSizes = successfulParse $ parseFile testGrid
- -- putStrLn $ searchTrace $ fromJust $
- -- aStar successors
- -- (\_ _ -> 1)
- -- heuristic
- -- isGoal
- -- (startSt testSizes)
- putStrLn $ searchTrace $ fromJust $
- aStar successors
- (\_ _ -> 1)
- heuristic
- isGoal
- (startSt sizes)
-
-
-
-searchTrace :: [SearchState] -> String
-searchTrace ss = unlines $ map (sst) ss
- where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ") :: " ++ holeS s
- hole sk = fromJust $ find (\n -> used n == 0) $ grid sk
- holeS sk = "(" ++ show (x $ hole sk) ++ ", " ++ show (y $ hole sk) ++ ")"
-
-startSt :: [Node] -> SearchState
-startSt nodes = SearchState {cx = maximum xs, cy = 0, grid = nodes}
- where xs = map (\n -> x n) nodes
-
-isGoal :: SearchState -> Bool
-isGoal st = cx st == 0 && cy st == 0
-
-adjacent :: Node -> Node -> Bool
-adjacent n1 n2 = abs ((x n1) - (x n2)) + abs ((y n1) - (y n2)) == 1
-
--- A move of data from n1 to n2 is legal.
-legal :: Node -> Node -> Bool
-legal n1 n2 = adjacent n1 n2 && used n1 > 0 && used n1 <= available n2
-
-heuristic :: SearchState -> Int
-heuristic st = (cx st) + (cy st)
-
-successors :: SearchState -> Data.HashSet.HashSet SearchState
-successors st = Data.HashSet.fromList $ map (newState st current) possibleMoves
- where nodes = grid st
- current = fromJust $ find (\n -> (x n) == (cx st) && (y n) == (cy st)) nodes
- possibleMoves = [(n1, n2) | n1 <- nodes, n2 <- nodes, legal n1 n2]
-
-
--- Moving data from n1 to n2
-newState :: SearchState -> Node -> (Node, Node) -> SearchState
-newState st current (n1, n2) = st {cx = cx', cy = cy', grid = grid'}
- where cx' = if current == n1 then x n2 else x current
- cy' = if current == n1 then y n2 else y current
- grid' = sort $ (n2 {used = (used n2 + used n1), available = (available n2 - used n1)}):
- (n1 {used = 0, available = (size n1)}):
- (delete n1 $ delete n2 (grid st))
-
-
-duFile = duLine `sepEndBy` newline
--- duLine = (optionMaybe nodeL)
-
-duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
-
-headerL = (many (noneOf "\r\n"))
-
-nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
- <*> (string "-y" *> int)
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "%")
- where nodeify x y size used available use_pc =
- Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
-
-parseFile :: String -> Either ParseError [Maybe Node]
-parseFile input = parse duFile "(unknown)" input
-
-parseLine :: String -> Either ParseError (Maybe Node)
-parseLine input = parse duLine "(unknown)" input
-
-successfulParse :: Either ParseError [Maybe a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = catMaybes a
+++ /dev/null
-module Main(main) where
-
-import GHC.Generics (Generic)
-import Text.Parsec
-import Text.ParserCombinators.Parsec.Number
-import Data.Maybe (catMaybes, fromJust)
-import Data.List (find, delete, sort, sortOn, reverse)
-
-data Node = Node { x :: Int
- , y :: Int
- , size :: Int
- , used :: Int
- , available :: Int
- , use_pc :: Int
- } deriving (Show, Eq, Ord)
-
-data SearchState = SearchState { cx :: Int
- , cy :: Int
- , grid :: [Node]
- } deriving (Show)
-instance Ord SearchState where
- s1 `compare` s2 = (heuristic s1) `compare` (heuristic s2)
-instance Eq SearchState where
- s1 == s2 = equivalentState s1 s2
-
-equivalentState :: SearchState -> SearchState -> Bool
-equivalentState s1 s2 =
- let h1 = fromJust $ find (\n -> used n == 0) $ grid s1
- h2 = fromJust $ find (\n -> used n == 0) $ grid s2
- in
- cx s1 == cx s2 && cy s1 == cy s2 &&
- x h1 == x h2 && y h1 == y h2
-
-
-testGrid = "\
-\Filesystem Size Used Avail Use%\n\
-\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
-\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
-\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
-\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
-\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
-\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
-\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
-\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
-\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
-\"
-
-main :: IO ()
-main = do
- text <- readFile "data/advent22.txt"
- let sizes = successfulParse $ parseFile text
- part1 sizes
- part2 sizes
-
-part1 :: [Node] -> IO ()
-part1 sizes = print $ length viable
- where viable = [(a, b) | a <- sizes,
- b <- sizes,
- a /= b,
- (used a) > 0,
- (used a) <= (available b)]
-
-
-part2 :: [Node] -> IO ()
-part2 sizes =
- -- do let testSizes = successfulParse $ parseFile testGrid
- -- putStrLn $ searchTraceH $ reverse $ aStar [[startSt testSizes]] []
- print $ length $ aStar [[startSt sizes]] []
-
-
-aStar :: [[SearchState]] -> [SearchState] -> [SearchState]
-aStar [] _ = []
-aStar (currentPath:agenda) closed =
- if isGoal reached then currentPath
- else if reached `elem` closed
- then aStar agenda closed
- else aStar newAgenda (reached:closed)
- where
- reached = head currentPath
- successorPaths = map (:currentPath) $ successors reached
- newAgenda = sortOn (cost) $ successorPaths ++ agenda
-
-
-searchTrace :: [SearchState] -> String
-searchTrace ss = unlines $ map (sst) ss
- where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ")"
-
-searchTraceH :: [SearchState] -> String
-searchTraceH ss = unlines $ map (sst) ss
- where sst s = "(" ++ show (cx s) ++ ", " ++ show (cy s) ++ ") :: " ++ holeS s
- hole sk = fromJust $ find (\n -> used n == 0) $ grid sk
- holeS sk = "(" ++ show (x $ hole sk) ++ ", " ++ show (y $ hole sk) ++ ")"
-
-startSt :: [Node] -> SearchState
-startSt nodes = SearchState {cx = maximum xs, cy = 0, grid = nodes}
- where xs = map (\n -> x n) nodes
-
-isGoal :: SearchState -> Bool
-isGoal st = cx st == 0 && cy st == 0
-
-adjacent :: Node -> Node -> Bool
-adjacent n1 n2 = abs ((x n1) - (x n2)) + abs ((y n1) - (y n2)) == 1
-
--- A move of data from n1 to n2 is legal.
-legal :: Node -> Node -> Bool
-legal n1 n2 = adjacent n1 n2 && used n1 > 0 && used n1 <= available n2
-
-heuristic :: SearchState -> Int
-heuristic st = (cx st) + (cy st)
-
-successors :: SearchState -> [SearchState]
-successors st = map (newState st current) possibleMoves
- where nodes = grid st
- current = fromJust $ find (\n -> (x n) == (cx st) && (y n) == (cy st)) nodes
- possibleMoves = [(n1, n2) | n1 <- nodes, n2 <- nodes, legal n1 n2]
-
-
--- Moving data from n1 to n2
-newState :: SearchState -> Node -> (Node, Node) -> SearchState
-newState st current (n1, n2) = st {cx = cx', cy = cy', grid = grid'}
- where cx' = if current == n1 then x n2 else x current
- cy' = if current == n1 then y n2 else y current
- grid' = sort $ (n2 {used = (used n2 + used n1), available = (available n2 - used n1)}):
- (n1 {used = 0, available = (size n1)}):
- (delete n1 $ delete n2 (grid st))
-
-cost :: [SearchState] -> Int
-cost p = (heuristic $ head p) + (length p)
-
-
-
-duFile = duLine `sepEndBy` newline
--- duLine = (optionMaybe nodeL)
-
-duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
-
-headerL = (many (noneOf "\r\n"))
-
-nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
- <*> (string "-y" *> int)
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "%")
- where nodeify x y size used available use_pc =
- Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
-
-parseFile :: String -> Either ParseError [Maybe Node]
-parseFile input = parse duFile "(unknown)" input
-
-parseLine :: String -> Either ParseError (Maybe Node)
-parseLine input = parse duLine "(unknown)" input
-
-successfulParse :: Either ParseError [Maybe a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = catMaybes a
+++ /dev/null
-{-# LANGUAGE DeriveGeneric #-}
-
-module Main(main) where
-
-import GHC.Generics (Generic)
-import Text.Parsec
-import Text.ParserCombinators.Parsec.Number
-import Data.Maybe (catMaybes, fromJust)
-import Data.List (find, delete, sort, sortOn, reverse)
-
-data Node = Node { x :: Int
- , y :: Int
- , size :: Int
- , used :: Int
- , available :: Int
- , use_pc :: Int
- } deriving (Show, Eq, Ord)
-
-
-testGrid = "\
-\Filesystem Size Used Avail Use%\n\
-\/dev/grid/node-x0-y0 10T 8T 2T 80%\n\
-\/dev/grid/node-x0-y1 11T 6T 5T 54%\n\
-\/dev/grid/node-x0-y2 32T 28T 4T 87%\n\
-\/dev/grid/node-x1-y0 9T 7T 2T 77%\n\
-\/dev/grid/node-x1-y1 8T 0T 8T 0%\n\
-\/dev/grid/node-x1-y2 11T 7T 4T 63%\n\
-\/dev/grid/node-x2-y0 10T 6T 4T 60%\n\
-\/dev/grid/node-x2-y1 9T 8T 1T 88%\n\
-\/dev/grid/node-x2-y2 9T 6T 3T 66%\n\
-\"
-
-main :: IO ()
-main = do
- text <- readFile "data/advent22.txt"
- let sizes = successfulParse $ parseFile text
- let maxX = maximum $ map (\n -> x n) sizes
- let maxY = maximum $ map (\n -> y n) sizes
- putStrLn $ unlines $ map (showRow maxX sizes) [0..(maxY-1)]
-
-
-showRow maxX sizes r = map (charOf) row
- where row = sortOn (\c -> x c) $ filter (\c -> y c == r) sizes
- charOf c = if (used c) == 0
- then '+'
- else if (used c) > 100
- then '#'
- else '_'
-
-
-
-
-duFile = duLine `sepEndBy` newline
--- duLine = (optionMaybe nodeL)
-
-duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
-
-headerL = (many (noneOf "\r\n"))
-
-nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
- <*> (string "-y" *> int)
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "T")
- <*> (spaces *> int <* string "%")
- where nodeify x y size used available use_pc =
- Node {x=x, y=y, size=size, used=used, available=available, use_pc=use_pc}
-
-parseFile :: String -> Either ParseError [Maybe Node]
-parseFile input = parse duFile "(unknown)" input
-
-parseLine :: String -> Either ParseError (Maybe Node)
-parseLine input = parse duLine "(unknown)" input
-
-successfulParse :: Either ParseError [Maybe a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = catMaybes a
+++ /dev/null
-module Main(main) where
-
-import Text.Parsec hiding (State)
-import Text.ParserCombinators.Parsec.Number
-import Control.Monad.State.Lazy
--- import Debug.Trace
-
-data Location = Literal Int | Register Char deriving (Show, Eq)
-data Instruction = Cpy Location Location
- | Inc Location
- | Dec Location
- | Jnz Location Location
- | Tgl Location
- deriving (Show, Eq)
-
-data Machine = Machine { a :: Int
- , b :: Int
- , c :: Int
- , d :: Int
- , pc :: Int
- , instructions :: [Instruction]}
- deriving (Show, Eq)
-
-testInstructions = "cpy 2 a\n\
-\tgl a\n\
-\tgl a\n\
-\tgl a\n\
-\cpy 1 a\n\
-\dec a\n\
-\dec a"
-
-emptyMachine :: Machine
-emptyMachine = Machine {a=0, b=0, c=0, d=0, pc=0, instructions=[]}
-
-main :: IO ()
-main = do
- text <- readFile "data/advent23.txt"
- let instructions = successfulParse $ parseIfile text
- part1 instructions
- part2 instructions
-
-
-part1 :: [Instruction] -> IO ()
-part1 instrs =
- do let m0 = emptyMachine {instructions=instrs, a = 7}
- let mf = snd $ runState runMachine m0
- print (a mf)
-
-part2 :: [Instruction] -> IO ()
-part2 instrs =
- do let m0 = emptyMachine {instructions=instrs, a = 12}
- let mf = snd $ runState runMachine m0
- print (a mf)
-
-
-runMachine :: State Machine ()
-runMachine =
- do m <- get
- if (pc m) >= (length $ instructions m)
- then return ()
- else do executeStep
- runMachine
-
-executeStep :: State Machine ()
-executeStep =
- do m <- get
- let i = (instructions m)!!(pc m)
- put (executeInstructionPeep i m)
- -- put (executeInstruction i m)
-
-executeInstructionPeep :: Instruction -> Machine -> Machine
-executeInstructionPeep i m =
- if sample1 == sample1Target
- -- then trace ("Peeping 1 " ++ (show m) ++ " to " ++ (show m1)) m1
- then m1
- else if sample2 == sample2Target
- -- then trace ("Peeping 2 " ++ (show m) ++ " to " ++ (show m2)) m2
- then m2
- else executeInstruction i m
- where sample1 = take (length sample1Target) $ drop (pc m) $ instructions m
- sample1Target = [ Cpy (Literal 0) (Register 'a')
- , Cpy (Register 'b') (Register 'c')
- , Inc (Register 'a')
- , Dec (Register 'c')
- , Jnz (Register 'c') (Literal (-2))
- , Dec (Register 'd')
- , Jnz (Register 'd') (Literal (-5)) ]
- m1 = m {a = b m * d m, c = 0, d = 0, pc = pc m + (length sample1)}
- sample2 = take (length sample2Target) $ drop (pc m) $ instructions m
- sample2Target = [ Dec (Register 'b')
- , Cpy (Register 'b') (Register 'c')
- , Cpy (Register 'c') (Register 'd')
- , Dec (Register 'd')
- , Inc (Register 'c')
- , Jnz (Register 'd') (Literal (-2)) ]
- m2 = m {b = b m - 1, c = (b m - 1) * 2, d = 0, pc = pc m + (length sample2)}
-
-
-executeInstruction :: Instruction -> Machine -> Machine
-executeInstruction (Inc r@(Register _)) m = m' {pc=pc1}
- where pc1 = (pc m) + 1
- v = evaluate m r
- m' = writeValue m r (v+1)
-executeInstruction (Inc (Literal _)) m = m {pc=pc1}
- where pc1 = (pc m) + 1
-executeInstruction (Dec r@(Register _)) m = m' {pc=pc1}
- where pc1 = (pc m) + 1
- v = evaluate m r
- m' = writeValue m r (v-1)
-executeInstruction (Dec (Literal _)) m = m {pc=pc1}
- where pc1 = (pc m) + 1
-executeInstruction (Cpy s d@(Register _)) m = m' {pc=pc1}
- where pc1 = (pc m) + 1
- v = evaluate m s
- m' = writeValue m d v
-executeInstruction (Cpy s (Literal _)) m = m {pc=pc1}
- where pc1 = (pc m) + 1
-executeInstruction (Jnz s d) m
- | v == 0 = m {pc=pc1}
- | otherwise = m {pc=pcj}
- where pc1 = (pc m) + 1
- ed = evaluate m d
- pcj = (pc m) + ed
- v = evaluate m s
-executeInstruction (Tgl a) m
- | v < (length $ instructions m) = m {instructions = (replace (instructions m) i' v),
- pc=pc1}
- | otherwise = m {pc=pc1}
- where pc1 = pc m + 1
- v = evaluate m a + pc m
- i = (instructions m)!!v
- i' = case i of
- Inc x -> Dec x
- Dec x -> Inc x
- Tgl x -> Inc x
- Cpy x y -> Jnz x y
- Jnz x y -> Cpy x y
- replace xs x i = take i xs ++ [x] ++ drop (i+1) xs
-
-
-evaluate :: Machine -> Location -> Int
-evaluate _ (Literal i) = i
-evaluate m (Register r) =
- case r of
- 'a' -> (a m)
- 'b' -> (b m)
- 'c' -> (c m)
- 'd' -> (d m)
-
-writeValue :: Machine -> Location -> Int -> Machine
-writeValue m (Literal i) _ = m
-writeValue m (Register r) v =
- case r of
- 'a' -> m {a=v}
- 'b' -> m {b=v}
- 'c' -> m {c=v}
- 'd' -> m {d=v}
-
-
-instructionFile = instructionLine `sepEndBy` newline
-instructionLine = incL <|> decL <|> cpyL <|> jnzL <|> tglL
-
-incL = Inc <$> (string "inc" *> spaces *> register)
-decL = Dec <$> (string "dec" *> spaces *> register)
-cpyL = Cpy <$> (string "cpy" *> spaces *> location) <*> (spaces *> register)
-jnzL = Jnz <$> (string "jnz" *> spaces *> location) <*> (spaces *> location)
-tglL = Tgl <$> (string "tgl" *> spaces *> location)
-
-location = (Literal <$> int) <|> register
-register = Register <$> (oneOf "abcd")
-
-parseIfile :: String -> Either ParseError [Instruction]
-parseIfile input = parse instructionFile "(unknown)" input
-
-parseIline :: String -> Either ParseError Instruction
-parseIline input = parse instructionLine "(unknown)" input
-
-successfulParse :: Either ParseError [a] -> [a]
-successfulParse (Left _) = []
-successfulParse (Right a) = a
+++ /dev/null
-module Lib
- ( someFunc
- ) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"
flags: {}
extra-package-dbs: []
packages:
-- '.'
+- adventofcode16
+- adventofcode1601
+- adventofcode1602
system-ghc: true
extra-deps:
- astar-0.3.0.0
+++ /dev/null
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"
projects / advent-of-code-16.git / commitdiff