never executed always true always false

    1 {-|
    2 Module:      Y2021.D12
    3 Description: Advent of Code 2021 Day 12 Solutions.
    4 License:     MIT
    5 Maintainer:  @tylerjl
    6 
    7 Solutions to the 2021 day 12 set of problems for <adventofcode.com>.
    8 -}
    9 module Y2021.D12
   10   ( parse12
   11   , parse12'
   12   , part12A
   13   , part12B
   14   ) where
   15 
   16 import Control.Applicative
   17 import Data.Attoparsec.Text
   18 import Data.Bifunctor    (second)
   19 import Data.Either.Utils (fromRight)
   20 import Data.List         (nub)
   21 import Data.Map.Strict   (Map)
   22 import Data.MultiSet     (MultiSet)
   23 import Data.Set          (Set)
   24 import Data.Text         (Text)
   25 import Witch
   26 import Y2015.Util        ((<&&>))
   27 
   28 import qualified Data.Map.Strict as M
   29 import qualified Data.Set      as S
   30 import qualified Data.MultiSet as MS
   31 
   32 -- |This GADT helps quite a bit when comparing vaules later on
   33 data Room = Start | BigCave Text | SmallCave Text | End
   34   deriving (Eq, Ord, Show)
   35 -- |Type alias for better readability.
   36 type Caves = Map Room (Set Room)
   37 -- |Type alias for better readability.
   38 type TwiceVisit = Bool
   39 -- |Type alias for better readability.
   40 type Journey = (TwiceVisit, MultiSet Room)
   41 
   42 -- |Solution to part A
   43 part12A :: Text -> Int
   44 part12A (parse12' -> rooms)
   45   = length $ explore smallOnce rooms (True, mempty) Start
   46 
   47 -- |This is the main recursive function that drives both A and B. The
   48 -- higher-order function argument is the main difference, bit otherwise we build
   49 -- up a list of all valid routes by traversing the overall `Map`.
   50 explore :: (Journey -> Room -> Bool) -> Caves -> Journey -> Room -> [Journey]
   51 explore allowed caves (twice', journey') room
   52   | room == End = [visited]
   53   | otherwise = foldMap (concatMap (explore allowed caves visited)) rooms
   54   where
   55     journey = MS.insert room journey'
   56     twice
   57       | twice' = True
   58       | otherwise =
   59         any ((isSmall . fst) <&&> ((> 1) . snd)) $ MS.toOccurList journey
   60     visited = (twice, journey)
   61     rooms = S.filter (allowed visited) <$> M.lookup room caves
   62 
   63 -- |The predicate we use for part A, which is essentially "don't visit small
   64 -- rooms twice"
   65 smallOnce :: Journey -> Room -> Bool
   66 smallOnce (_, journey) c@(SmallCave _) = c `notElem` journey
   67 smallOnce _ Start = False
   68 smallOnce _ _ = True
   69 
   70 -- |Solution to part B
   71 part12B :: Text -> Int
   72 part12B (parse12' -> rooms)
   73   = length $ explore smallTwice rooms (False, mempty) Start
   74 
   75 -- |Given our journey through the caves so far and the room we'd like to proceed
   76 -- through, should we continue?
   77 --
   78 -- Part B requires a little more logic, which is primarily to visit any single
   79 -- small cave at most two times.
   80 smallTwice :: Journey -> Room -> Bool
   81 smallTwice _ (BigCave _) = True
   82 smallTwice _ Start = False
   83 smallTwice _ End = True
   84 smallTwice (seenTwice, j) r
   85   | r `MS.notMember` j = True
   86   | seenTwice = False
   87   | otherwise = True
   88 
   89 -- |Super small utility to find small caves.
   90 isSmall :: Room -> Bool
   91 isSmall (SmallCave _) = True
   92 isSmall _ = False
   93 
   94 -- |An intermediate parsing function; once we get the raw room pairs we turn it
   95 -- into the structure we'll work with later.
   96 parse12' :: Text -> Map Room (Set Room)
   97 parse12' =
   98   M.fromListWith S.union .
   99   map (second S.singleton) . nub . concatMap backpath . parse12
  100   where
  101     backpath (a, b) = [(a, b), (b, a)]
  102 
  103 -- |Pairs of cave "rooms", which we parse very simply and postprocess later.
  104 parse12 :: Text -> [(Room, Room)]
  105 parse12 = fromRight . parseOnly parser
  106   where
  107     parser    = line `sepBy1` endOfLine <* atEnd
  108     line      = (,) <$> location <* char '-' <*> location
  109     location  = start' <|> end' <|> bigCave <|> smallCave
  110     start'    = Start                  <$  string "start"
  111     bigCave   = BigCave   . into @Text <$> many1 (satisfy (`elem` ['A'..'Z']))
  112     smallCave = SmallCave . into @Text <$> many1 (satisfy (`elem` ['a'..'z']))
  113     end'      = End                    <$  string "end"