summaryrefslogtreecommitdiff
path: root/2019
diff options
context:
space:
mode:
Diffstat (limited to '2019')
-rw-r--r--2019/18.hs150
-rw-r--r--2019/18.in81
-rw-r--r--2019/Makefile2
-rw-r--r--2019/SmallIntSet.hs54
4 files changed, 286 insertions, 1 deletions
diff --git a/2019/18.hs b/2019/18.hs
new file mode 100644
index 0000000..a60421a
--- /dev/null
+++ b/2019/18.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE TupleSections #-}
+module Main where
+
+import Control.Monad
+import qualified Data.Array.Unboxed as A
+import qualified Data.Array.ST as STA
+import Data.Char
+import Data.List
+import qualified Data.IntMap as IntMap
+import Data.IntMap (IntMap)
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict (Map)
+import Data.Maybe
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+-- import Debug.Trace
+
+import Input
+import qualified SmallIntSet as SIS
+import SmallIntSet (SmallIntSet)
+
+
+-- Considers a distance of '-1' to mean 'unconnected'.
+-- Applies Floyd-Warshall.
+transitiveClosure :: [Int] -> A.UArray (Int, Int) Int -> A.UArray (Int, Int) Int
+transitiveClosure nodeList initMatrix =
+ STA.runSTUArray $ do
+ arr <- STA.thaw initMatrix
+ forM_ nodeList $ \k ->
+ forM_ nodeList $ \i ->
+ forM_ nodeList $ \j -> do
+ dij <- STA.readArray arr (i, j)
+ dik <- STA.readArray arr (i, k)
+ dkj <- STA.readArray arr (k, j)
+ if dik /= -1 && dkj /= -1 && (dij == -1 || dik + dkj < dij)
+ then STA.writeArray arr (i, j) (dik + dkj)
+ else return ()
+ return arr
+
+type Pos = (Int, Int)
+type Dir = (Int, Int)
+
+reachableFrom :: Map Pos Char -> Pos -> Map Pos Int
+reachableFrom bd startPos = go 0 (Set.singleton startPos) (Set.singleton startPos) Map.empty
+ where
+ go dist seen boundary result =
+ let boundary' = [pos
+ | (x, y) <- Set.toList boundary
+ , (dx, dy) <- [(-1,0), (0,-1), (1,0), (0,1)]
+ , let pos = (x + dx, y + dy)
+ , bd Map.! pos /= '#'
+ , pos `Set.notMember` seen]
+ (things, frees) = partition (\pos -> bd Map.! pos /= '.') boundary'
+ result' = result <> Map.fromList (map (,dist+1) things)
+ in if null frees
+ then result'
+ else go (dist + 1) (seen <> Set.fromList boundary') (Set.fromList frees) result'
+
+-- [0 1 26 27 52]
+-- [@, a...z, A...Z]
+data Implicit = Implicit (A.Array Int [Int]) -- edge list
+ (A.UArray (Int, Int) Int) -- distance matrix, with closure taken
+ deriving (Show)
+
+implicitGraph :: Map Pos Char -> Pos -> Implicit
+implicitGraph bd startPos =
+ let posGraph = fst (go startPos Map.empty Set.empty)
+ mapGraph = Map.mapKeys (bd Map.!) (Map.map (Map.mapKeys (bd Map.!)) posGraph)
+ charToNode '@' = 0
+ charToNode c | isLower c = 1 + ord c - ord 'a'
+ | isUpper c = 1 + 26 + ord c - ord 'A'
+ | otherwise = undefined
+ arrGraph = A.accumArray (const id) [] (0, 2 * 26)
+ [(charToNode from, map charToNode (Map.keys tomap))
+ | (from, tomap) <- Map.assocs mapGraph]
+ distArr = A.accumArray (const id) (-1) ((0, 0), (2 * 26, 2 * 26))
+ [((charToNode from, charToNode to), dist)
+ | (from, tomap) <- Map.assocs mapGraph
+ , (to, dist) <- Map.assocs tomap]
+ nodeList = map charToNode (Map.keys mapGraph)
+ in Implicit arrGraph (transitiveClosure nodeList distArr)
+ where
+ go :: Pos -> Map Pos (Map Pos Int) -> Set Pos -> (Map Pos (Map Pos Int), Set Pos)
+ go curPos graph seen
+ | curPos `Set.member` seen = (graph, seen)
+ | otherwise =
+ let reach = reachableFrom bd curPos
+ newNodes = Map.keysSet reach Set.\\ seen
+ graph' = Map.insert curPos reach graph
+ seen' = Set.insert curPos seen
+ in Set.foldl' (\(gr, sn) node -> go node gr sn) (graph', seen') newNodes
+
+reachable :: Implicit -> SmallIntSet -> Int -> IntMap Int
+reachable (Implicit graph distarr) keys start = snd (go 0 (SIS.singleton start) start IntMap.empty)
+ where
+ go dist seen at result =
+ let nexts = filter (\c -> c `SIS.notMember` seen && (c <= 26 || (c - 26) `SIS.member` keys))
+ (graph A.! at)
+ (nextPearls, nextNonpearls) = partition (\c -> 0 < c && c <= 26 && c `SIS.notMember` keys) nexts
+ result' = result <> IntMap.fromList [(c, dist + distarr A.! (at, c)) | c <- nextPearls]
+ seen' = seen <> SIS.fromList nexts
+ in -- trace ("reachable-go at=" ++ show at ++ " dist=" ++ show dist ++ " nexts=" ++ show nexts ++ " (allnexts " ++ show (graph A.! at) ++ ")") $
+ if null nexts
+ then (seen, result')
+ else foldl (\(sn, rs) c -> go (dist + distarr A.! (at, c)) sn c rs) (seen', result') nextNonpearls
+
+searchBFS :: SmallIntSet -> Implicit -> (Int, [Int])
+searchBFS allKeys implicit@(Implicit _ distarr) = go 0 (Set.singleton (heuristic 0 SIS.empty, 0, 0, SIS.empty, [])) Map.empty
+ where
+ -- pqueue: f-val, distance, node, keys, key order
+ -- visited: node, keys => distance
+ go :: Int -> Set (Int, Int, Int, SmallIntSet, [Int]) -> Map (Int, SmallIntSet) Int -> (Int, [Int])
+ go ctr pqueue visited =
+ let ((heurval, dist, curnode, keys, keyorder), newpqueue) = Set.deleteFindMin pqueue
+ reach = reachable implicit keys curnode
+ nextStates = [(dist + stepDist + heuristic stepC stepKeys, dist + stepDist, stepC, stepKeys, stepC : keyorder)
+ | (stepC, stepDist) <- IntMap.assocs reach
+ , let stepKeys = SIS.insert stepC keys
+ -- check that this next state is actually better than we've seen before
+ , maybe True (dist + stepDist <) (Map.lookup (stepC, stepKeys) visited)]
+ visited' = Map.insert (curnode, keys) dist visited
+ pqueue' = newpqueue <> Set.fromList nextStates
+ result =
+ if IntMap.null reach
+ then if heurval == dist then (dist, keyorder) else error ("heurval - dist = " ++ show (heurval - dist) ++ " in terminal state!")
+ else go (ctr + 1) pqueue' visited'
+ in -- (if ctr `rem` 20000 == 0 || IntMap.null reach
+ -- then trace ("go #pqueue=" ++ show (Set.size pqueue) ++ " #visited=" ++ show (Map.size visited)
+ -- ++ " curnode=" ++ show curnode ++ " dist=" ++ show dist ++ " heurval=" ++ show heurval ++ " keys=" ++ show keyorder
+ -- {- ++ " next->" ++ show nextStates -})
+ -- else id)
+ result
+
+ heuristic :: Int -> SmallIntSet -> Int
+ heuristic _curnode keys =
+ let remainKeys = allKeys SIS.\\ keys
+ allDists = [distarr A.! (x, y) | x:xs <- tails (SIS.toList remainKeys), y <- xs]
+ distLowerBound = sum (take (SIS.size remainKeys - 1) (sort allDists))
+ in distLowerBound
+
+main :: IO ()
+main = do
+ stringbd <- getInput 18
+ let bd = Map.fromList [((x, y), c) | (y, row) <- zip [0..] stringbd, (x, c) <- zip [0..] row]
+ startpos = fromJust (lookup '@' (map (\(x,y) -> (y,x)) (Map.assocs bd)))
+
+ let imgraph = implicitGraph bd startpos
+ allKeys = SIS.fromList [ord c - ord 'a' + 1 | c <- Map.elems bd, isLower c]
+ print (fst (searchBFS allKeys imgraph))
diff --git a/2019/18.in b/2019/18.in
new file mode 100644
index 0000000..48f12ae
--- /dev/null
+++ b/2019/18.in
@@ -0,0 +1,81 @@
+#################################################################################
+#.#.........#...#....r#.......#...#.....#.....#...........#.......#......c......#
+#X#.#####.#.#.#.#.###.#####.#.#.#.#.###.#.###.#.#######Q###.#.###.#.#####.###.#.#
+#...#.....#...#...#.#.....#.#...#.....#.#.#...#.#.....#.....#.#.#.#.#...#.#.#.#.#
+#.###.#############.#####.#.###########.#.#.#####.###.#.#####.#.#.###F#.#.#.#.###
+#...#.#j......#.......P.#.#.#.......#...#.#.....#...#.#.#.....#...#...#.#...#...#
+###.#.#.###.#.#.#######.#.###.#####.#.#.#.#####.###.#.###.#####.###.###.#######.#
+#...#.#...#.#.#.......#.#.....#...#...#.#.....#.#...#...#.#...#.#...#...#.....M.#
+#.###.#.###.#.#######.#.#######.#.#####.#.###.#.#.#####.#.#.###.#.#####.#.#######
+#.#...#.#...#.#.....#.#.........#.......#.#.#.#...#.......#.....#.....#.#...#...#
+#.#.#####.###.#.#.###.###################.#.#.###.#############.#.###.#.###.#.#.#
+#.#...#...#...#.#...#.#...#.......#.....#...#.#...#.....#.....#.#...#.#...#...#.#
+#.###.#.#####.#.###.#.#.#.#.#####.#.#.#####.#.#####.###.#.###.#.###.#.###.#.###.#
+#...#.#..g..#.#.#...#.L.#.#.#..n#.#.#...#...#.....#.#..i#.#...#...#.#.#.#.#.#...#
+#####.#####.###.#.#.#####.#.#.#.#.#####.#####.###.#.#.###.#.#####.###.#.#.#.#.###
+#.....#...#.....#.#.#.......#.#.#...#...#...#...#...#.....#...#...#...#.#.#.#...#
+#D#####.#.#######.###.#######.#.###.#.#.#.#.#############.###.#.###U###.#A#####.#
+#.......#.#.H...#.....#...E...#...#...#.#.#...#.........#...#.#...#.#...........#
+#.#######.#.###.#######.#########.#####.#.###.#.#######.#.###.###.#.###########.#
+#.#.....#.#.#.#e........#.....N...#...#.#.#.....#.....#.#.#...#...#...#.......#y#
+#.###.#.#.#.#.#########.#.#########.###.#.#######.###.#.###.#####.#.#.#.#####.#.#
+#...#.#.#.#.#.....#.O.#.#.#.......#.....#.#...#.....#....z#.#...#.#.#.#.#...#.#.#
+###.#.###.#.#.###.#.#####.#.#####.#.#####.#.#.###########.#.###.#.#.#.#.###.#.#.#
+#.....#.V.#.#.#...#......o#.#.....#.#...#...#.T.......#.......#.#.#.#.......#.#.#
+#######.###.#.#.#############.#####.#.#.#.###########.#########.#.###########.#.#
+#.....#...#...#..b#...#.......#.....#.#.#.#.....#...#.........#.#.......#.....#.#
+#.###.###.#######.#.#.#####.###.#####.###.#.#####.#.###.#####.#.#######.#.#######
+#.#.#.#...#.....#...#...#...#...#.......#.#.#.....#...#.....#.#.......#.#.......#
+#.#.#.#.#.#.###.#######.#.###.#########.#.#.#.#######.#####S#.#######.#.#.#####.#
+#u#...#.#.#...#.......#.#.....#.......#.#.#.#...#...#.....#.#.....#...#.#.#.#..v#
+#.###.#.#.###.#####.#.#.###.###.#####.#.#.#.###.#.#.#####.#######.#.###.#.#.#.#.#
+#...#...#...#.#...#.#.#...#...#.#.#...#.#.....#.#.#.#.....#.......#.#.#.#...#.#.#
+###.###W#####.#.###.#####.###.#.#.#.###.#.#####.#.#.#####.#.#######.#.#.###.#.###
+#...#...#.......#...#...#.#.#...#...#...#.#.....#.#.....#...#.......#.#..d#.#...#
+#.#######.#######.###.#.#.#.#####.###.#.#.#.#####.#####.#####.#######.###.#.###.#
+#.......#a..#.#.Y.#...#...#.....#.....#.#.#.....#.....#...#...#...#.....#.#.#...#
+#.#####.###.#.#.#.#.#######.#.#.#######.#.#####.###.#####.#.###.###.###.#.#.#.#.#
+#.....#...#.#.#.#.#...#.#...#.#.#.......#.#...#.....#.....#.#.....#...#.#.#.#.#.#
+#####.#.###.#.#.#####.#.#.###.###.#######.###.#######.#####.#.###.###.#.#.###.#.#
+#....f#.......#....m..#.....#.......................#.......#...#.....#.......#.#
+#######################################.@.#######################################
+#...#.....#...#...#.#.......#.....#...........#.....#.#.......#...........#.....#
+#.#.#.#.#.#.#.#.#.#.#.#.###.#.###.#####.#.###.###.#.#.#.#####.#.#######.#.###.#.#
+#.#...#.#...#.#.#...#.#...#...#.........#...#...#.#...#.#...#.#.#.#...#.#.#...#.#
+#######.#####.#.###.#.###.#############.###.###.#.###.#.#.###.#.#.#.#.#.#.#.###.#
+#.....#.#.......#...#s#.#.#.........#...#...#...#...#.#.#.#...#...#.#...#...#.#.#
+#.###.#.#############.#.#.#.#######.#.###.#####.#.#.###.#.#.#####.#.#########.#.#
+#...#...#...............#.#.#.#.....#.#.#.....#t#.#...#.#.#.#.....#...#.......#.#
+#.#.#####.###############.#.#.#.#####.#.#.###.#.#####.#.#.#.#########.#.#######.#
+#.#.#...#.#.....#...#...#.....#.#...#.#.#.#.#.#.#.....#...#...#.......#.........#
+#.#.#.#.#.#.###Z#.###.#.###.###.#.###.#.#.#.#.#.#.###.###.###.#.#######.#####.###
+#.#.#.#.#...#.....#...#...#.#...#.#...#.#.#.#.#...#...#...#.#.#...#...#.#...#...#
+###.#.#.#####.#####.#####.###.###.#.###.#.#.#.#########.###.#.#.#.###.#.#.#.###.#
+#...#.#.....#.#.#...#...#.....#.........#...#...........#...#.#.#...#...#.#.#...#
+#.###.#.#####.#.#.###.#.###.###############.#############.###.#####.#####.#.###.#
+#.#...#....k....#.#...#.....#.......#...#.#.......#.....#...#...K.#.#.....#...#.#
+#.#.#############.#####.#####.#####.#.#.#.#######.#.###.###.#####.#.#.#######.#.#
+#...#.........#...#...#.....#...#.#...#.#.......#...#.........#...#.#.#.....#.#.#
+#####.#######.#.###.#.#########.#.#####.#.#.###.#.###########.#.###.#.#.#####.#.#
+#.....#.........#...#.#.........#...#...#.#...#.#.#.......#...#...#...#...#...#.#
+#.###############B###.#.###########.#.#######.###.#.#####.#####.#.#.#####.#.###.#
+#.....#.....#...#...#h#...........#.....#.....#...#.#...#.....#.#.#.....#.#...#w#
+#.###.#.###.#.#.###.#####.#######.#####.#.#####.###.#.#.#########.#####.#.###.###
+#...#...#...#.#...#.....#.......#...#.#.#.#.....#.#...#...#.....#...#.......#...#
+#########.###.###.#####.#####.#####.#.#.#.#.#####.#######.#.###.###.#.#########.#
+#.....#...#.....#.....#...#...#.....#.#.#...#.......#...#.#.#.......#...#.....#.#
+#.###.#.###.#####.#######.#.###.#####.#.#.#####.#####.#.#.#.#############.###G#.#
+#...#...#...#...#.......#.#...#.#...#...#.....#.....#.#...#.......#.......#.#...#
+###.#####.###.#.###.###.#.#####.###.#.#######.#####.#.###########.#.#######.###.#
+#...#.......#.#...#.#...#.#.....#...#...#...#.....#.#.......#...#.#.#.........#.#
+#.###.#######.###.#.#.###.#.#####.#####.#.#.#####.#.#######.#.#.#.#.#.###.#####.#
+#.....#...#...#.#.#.#...#.#.#...#.......#.#.......#...#...#...#...#.#.#.#.......#
+#.#######.#.###.#.#####.#.#C#.#.#.#######.#########.###.#.#########.#.#.#########
+#.......#.#...#.....R...#...#.#.#.#.....#.#.......#...#.#.....#.....#.#.........#
+#######.#.###.###############.#.#.###.#.#.#.#####.#.#.#.#.###.#.#.###.###.#####.#
+#.....#.#...#...#...........#.#.#.....#.#.#.....#...#..p#.#...#.#.#...#...#...#.#
+#.#####.#.#.###.#.#########.#.#.#######.#.###.###########.###.###.#.###.#####.#.#
+#.....#.#.#.#q#...#.....#.#.#.#.......#.#.#...#.....#...#...#...#.#...#.#x....#.#
+#.###.#.#.#.#.#######.#.#.#.#.###.#####.#.#####.###.#.#I###.###.#.###.#.#.#####.#
+#...#...J.#...........#...#.....#.......#.......#.....#..l..#.....#.....#.......#
+#################################################################################
diff --git a/2019/Makefile b/2019/Makefile
index a21d52b..d5db74d 100644
--- a/2019/Makefile
+++ b/2019/Makefile
@@ -5,7 +5,7 @@ CXXFLAGS = -Wall -Wextra -std=c++17 -O2
OBJDIR = obj
-HASKELL_AUX := Input.hs IntCode.hs
+HASKELL_AUX := Input.hs IntCode.hs SmallIntSet.hs
CPP_AUX :=
HASKELL_SRC := $(filter-out $(HASKELL_AUX),$(wildcard *.hs))
CPP_SRC := $(filter-out $(CPP_AUX),$(wildcard *.cpp))
diff --git a/2019/SmallIntSet.hs b/2019/SmallIntSet.hs
new file mode 100644
index 0000000..182b850
--- /dev/null
+++ b/2019/SmallIntSet.hs
@@ -0,0 +1,54 @@
+module SmallIntSet (
+ SmallIntSet,
+ toList, fromList, size, empty, singleton, insert, member, notMember, union, (\\)
+) where
+
+import Data.Bits
+import Data.List (intercalate)
+
+
+nBits :: Int
+nBits = finiteBitSize (undefined :: Int)
+
+newtype SmallIntSet = SmallIntSet Int
+ deriving (Eq, Ord)
+
+instance Show SmallIntSet where
+ show set = "{" ++ intercalate "," (map show (toList set)) ++ "}"
+
+instance Semigroup SmallIntSet where
+ s1 <> s2 = union s1 s2
+
+toList :: SmallIntSet -> [Int]
+toList (SmallIntSet bm) = [n | n <- [0..nBits-1], testBit bm n]
+
+fromList :: [Int] -> SmallIntSet
+fromList = foldr insert empty
+
+size :: SmallIntSet -> Int
+size (SmallIntSet bm) = popCount bm
+
+empty :: SmallIntSet
+empty = SmallIntSet 0
+
+singleton :: Int -> SmallIntSet
+singleton n = checkValid n `seq` SmallIntSet (1 `shiftL` n)
+
+insert :: Int -> SmallIntSet -> SmallIntSet
+insert n (SmallIntSet bm) = checkValid n `seq` SmallIntSet (bm .|. (1 `shiftL` n))
+
+member :: Int -> SmallIntSet -> Bool
+member n (SmallIntSet bm) = checkValid n `seq` (bm .&. (1 `shiftL` n)) /= 0
+
+notMember :: Int -> SmallIntSet -> Bool
+notMember n (SmallIntSet bm) = checkValid n `seq` (bm .&. (1 `shiftL` n)) == 0
+
+union :: SmallIntSet -> SmallIntSet -> SmallIntSet
+union (SmallIntSet b1) (SmallIntSet b2) = SmallIntSet (b1 .|. b2)
+
+(\\) :: SmallIntSet -> SmallIntSet -> SmallIntSet
+SmallIntSet b1 \\ SmallIntSet b2 = SmallIntSet (b1 .&. complement b2)
+
+checkValid :: Int -> Bool
+checkValid n | 0 <= n, n < nBits = True
+ | otherwise = error $ "SmallIntSet bounds violated with " ++ show n