advent17/src/advent17.hs

   1 import Debug.Trace
   2
   3 import Intcode
   4
   5 import qualified Data.Text.IO as TIO
   6
   7 import qualified Data.Set as S
   8 import Data.Char
   9 import Data.List
  10 import Control.Monad
  11
  12 type Position = (Integer, Integer) -- r, c
  13 data Direction = North | East | South | West deriving (Show, Eq, Ord, Enum, Bounded)
  14 data Step = F | ACW | CW deriving (Show, Eq, Ord)
  15 data Command = FN Int | L | R | A | B | C deriving (Eq)
  16
  17 instance Show Command where
  18     show (FN n) = show n
  19     show L = "L"
  20     show R = "R"
  21     show A = "A"
  22     show B = "B"
  23     show C = "C"
  24     showList [] s = s
  25     showList (c:[]) s = (show c) ++ s
  26     showList (c:cs) s = (show c) ++ "," ++ (showList cs s)
  27
  28 type Routine = ([Command], [Command], [Command], [Command])
  29
  30 type Scaffold = S.Set Position
  31
  32 data ScaffoldBuilder = ScaffoldBuilder
  33     { _scaffold :: Scaffold
  34     , _r :: Integer
  35     , _c :: Integer
  36     , _droidPos :: Position
  37     , _droidDirection :: Direction
  38     } deriving (Show, Eq)
  39
  40
  41 main :: IO ()
  42 main = do
  43         text <- TIO.readFile "data/advent17.txt"
  44         let mem = parseMachineMemory text
  45         -- print mem
  46         let sb = buildScaffold mem
  47         print $ part1 sb
  48         let (scaff, num) = part2 sb mem
  49         putStrLn scaff
  50         print num
  51
  52
  53 part1 sb = S.foldl (+) 0 $ S.map alignmentParam intersections
  54     where scaffold = _scaffold sb
  55           intersections = S.filter (isIntersection scaffold) scaffold
  56
  57
  58 part2 sb mem = (scaff, last output)
  59     where compressedCmds = findRoutine sb
  60           inputs = encodeRoutine compressedCmds
  61           mem' = (2:(tail mem))
  62           (_, _, output) = runProgram inputs mem'
  63           scaff = map (chr . fromIntegral) $ init output
  64
  65
  66 buildScaffold :: [Integer] -> ScaffoldBuilder
  67 buildScaffold mem = foldl' addGridChar emptyScaffoldBuilder output
  68     where (_, _, output) = runProgram [] mem
  69           emptyScaffoldBuilder = ScaffoldBuilder {_scaffold = S.empty, _r = 0, _c = 0,
  70                     _droidPos = (0, 0), _droidDirection = North }
  71
  72 addGridChar :: ScaffoldBuilder -> Integer -> ScaffoldBuilder
  73 addGridChar sb 10  = sb { _r = _r sb + 1, _c = 0 }
  74 addGridChar sb 46  = sb { _c = _c sb + 1 }
  75 addGridChar sb 35  = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
  76                             _c = _c sb + 1 }
  77 addGridChar sb 94  = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
  78                             _c = _c sb + 1,
  79                             _droidPos = (_r sb, _c sb), _droidDirection = North }
  80 addGridChar sb 118 = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
  81                             _c = _c sb + 1,
  82                             _droidPos = (_r sb, _c sb), _droidDirection = South }
  83 addGridChar sb 60  = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
  84                             _c = _c sb + 1,
  85                             _droidPos = (_r sb, _c sb), _droidDirection = West }
  86 addGridChar sb 61  = sb { _scaffold = S.insert (_r sb, _c sb) $ _scaffold sb,
  87                             _c = _c sb + 1,
  88                             _droidPos = (_r sb, _c sb), _droidDirection = East }
  89
  90
  91 isIntersection :: Scaffold -> Position -> Bool
  92 isIntersection scaffold (r, c) = neighbours `S.isSubsetOf` scaffold
  93     where  neighbours = [(r - 1, c), (r + 1, c), (r, c - 1), (r, c + 1)]
  94
  95 alignmentParam :: Position -> Integer
  96 alignmentParam (r, c) = r * c
  97
  98
  99
 100 findRoutine :: ScaffoldBuilder -> Routine
 101 findRoutine scaff = head $ compressedCmds
 102     where path = findPath scaff
 103           cmds = toCommands path
 104           compressedCmds = compress cmds
 105
 106 encodeRoutine :: Routine -> [Integer]
 107 encodeRoutine (abc, a, b, c) = map (fromIntegral . ord) $ unlines [show abc, show a, show b, show c, "n", ""]
 108
 109
 110 findPath :: ScaffoldBuilder -> [Step]
 111 findPath = unfoldr takeStep
 112
 113 takeStep :: ScaffoldBuilder -> Maybe (Step, ScaffoldBuilder)
 114 takeStep visitedScaffold = step
 115     where   scaff = _scaffold visitedScaffold
 116             here = _droidPos visitedScaffold
 117             dir = _droidDirection visitedScaffold
 118             fPos   = ahead here dir
 119             cwPos  = ahead here $ succW dir
 120             acwPos = ahead here $ predW dir
 121             step = if canVisit scaff fPos
 122                    then Just (F, visitedScaffold {_droidPos = fPos})
 123                    else if canVisit scaff cwPos
 124                         then Just (CW, visitedScaffold {_droidDirection = succW dir})
 125                         else if canVisit scaff acwPos
 126                              then Just (ACW, visitedScaffold {_droidDirection = predW dir})
 127                              else Nothing
 128
 129 ahead :: Position -> Direction -> Position
 130 ahead (r, c) North = (r - 1, c)
 131 ahead (r, c) South = (r + 1, c)
 132 ahead (r, c) West  = (r, c - 1)
 133 ahead (r, c) East  = (r, c + 1)
 134
 135 canVisit :: Scaffold -> Position -> Bool
 136 canVisit scaff here = (S.member here scaff)
 137
 138 toCommands :: [Step] -> [Command]
 139 toCommands path = map toCommand segments
 140     where segments = group path
 141
 142 toCommand :: [Step] -> Command
 143 toCommand segment = case (head $ segment) of
 144     F -> FN (length segment)
 145     CW -> R
 146     ACW -> L
 147
 148 compress :: [Command] -> [Routine]
 149 compress commands =
 150     do  a <- tail $ inits commands
 151         guard $ length (show a) <= 20
 152         let commandsA = replace a A commands
 153         let commandsABase = dropWhile (not . isBase) commandsA
 154         b <- tail $ inits commandsABase
 155         guard $ onlyBase b
 156         guard $ length (show b) <= 20
 157         let commandsAB = replace b B commandsA
 158         let commandsABBase = dropWhile (not . isBase) commandsAB
 159         c <- tail $ inits commandsABBase
 160         guard $ onlyBase c
 161         guard $ length (show c) <= 20
 162         let commandsABC = replace c C commandsAB
 163         guard $ length (show commandsABC) <= 20
 164         guard $ onlyNonBase commandsABC
 165         return (commandsABC, a, b, c)
 166
 167
 168 replace :: Eq a => [a] -> a -> [a] -> [a]
 169 -- replace moves label commands | trace (show moves ++ " " ++ show label ++ " " ++ show commands) False = undefined
 170 replace _ _ [] = []
 171 replace moves label commands =
 172     if moves `isPrefixOf` commands
 173     then (label:(replace moves label commands'))
 174     else (head commands:(replace moves label (tail commands)))
 175     where commands' = drop (length moves) commands
 176
 177 onlyBase :: [Command] -> Bool
 178 onlyBase moves = all isBase moves
 179
 180 onlyNonBase :: [Command] -> Bool
 181 onlyNonBase moves = all (not . isBase) moves
 182
 183 isBase :: Command -> Bool
 184 isBase (FN _) = True
 185 isBase L = True
 186 isBase R = True
 187 isBase _ = False
 188
 189
 190 -- | a `succ` that wraps
 191 succW :: (Bounded a, Enum a, Eq a) => a -> a
 192 succW dir | dir == maxBound = minBound
 193           | otherwise = succ dir
 194
 195 -- | a `pred` that wraps
 196 predW :: (Bounded a, Enum a, Eq a) => a -> a
 197 predW dir | dir == minBound = maxBound
 198           | otherwise = pred dir
 199
 200
 201
 202 -- showScaffold :: VisitedScaffold -> String
 203 -- showScaffold scaff = unlines rows
 204 --     where   minR = S.findMin $ S.map fst $ _scaffold scaff
 205 --             minC = S.findMin $ S.map snd $ _scaffold scaff
 206 --             maxR = S.findMax $ S.map fst $ _scaffold scaff
 207 --             maxC = S.findMax $ S.map snd $ _scaffold scaff
 208 --             rows = [showScaffoldRow scaff minC maxC r | r <- [minR..maxR]]
 209
 210 -- showScaffoldRow :: VisitedScaffold -> Integer -> Integer -> Integer -> String
 211 -- showScaffoldRow scaff minC maxC r = [showScaffoldCell scaff r c | c <- [minC..maxC]]
 212
 213 -- showScaffoldCell :: VisitedScaffold -> Integer -> Integer -> Char
 214 -- showScaffoldCell scaff r c =
 215 --     if S.member (r, c) (_scaffold scaff)
 216 --     then '#'
 217 --     else ' '
 218