diff options
| -rw-r--r-- | 2019/18.hs | 150 | ||||
| -rw-r--r-- | 2019/18.in | 81 | ||||
| -rw-r--r-- | 2019/Makefile | 2 | ||||
| -rw-r--r-- | 2019/SmallIntSet.hs | 54 |
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 |