Day23.hs

-- |
-- Module      : AOC.Challenge.Day23
-- Copyright   : (c) Justin Le 2018
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 23.  See "AOC.Solver" for the types used in this module!

module AOC.Challenge.Day23 (
    day23a
  , day23b
  ) where

import           AOC.Common              (clearOut, mannDist, boundingBox)
import           AOC.Solver              ((:~>)(..))
import           Data.Char               (isDigit)
import           Data.Foldable           (foldl', toList, maximumBy)
import           Data.List.NonEmpty      (NonEmpty)
import           Data.Ord                (Down(..), comparing)
import           Data.OrdPSQ             (OrdPSQ)
import           Data.Semigroup.Foldable (foldMap1)
import           Data.Witherable         (mapMaybe)
import           Linear                  (V2(..), V3(..))
import qualified Data.List.NonEmpty      as NE
import qualified Data.OrdPSQ             as PSQ
import qualified Linear                  as L

type Point3 = V3 Int
type BoundingBox = V2 Point3
data Sphere = S { _sCenter :: !Point3
                , _sRadius :: !Int
                }
  deriving (Show, Eq, Ord)

day23a :: _ :~> _
day23a = MkSol
    { sParse = Just . parse23
    , sShow  = show
    , sSolve = \ps -> Just
                    . (`go` map _sCenter ps)
                    . maximumBy (comparing _sRadius)
                    $ ps
    }
  where
    go c = length . filter (`inRangeOf` c)

touchesRegion
    :: Sphere
    -> BoundingBox
    -> Bool
touchesRegion c bb = any (`inRangeOf` c) (boundingCube bb)
                  || any (`inRegion` bb) (circleBounds c)

inRangeOf
    :: Point3
    -> Sphere
    -> Bool
p `inRangeOf` S c r = mannDist c p <= r

inRegion :: Point3 -> BoundingBox -> Bool
inRegion p (V2 mn mx) = all (>= 0) (p - mn)
                     && all (>= 0) (mx - p)

splitOctants
    :: [Sphere]
    -> BoundingBox
    -> [(BoundingBox, [Sphere])]
splitOctants ss bb0 =
    [ (oct, touching)
    | oct <- octants bb0
    , let touching = filter (`touchesRegion` oct) ss
    ]

-- "drilling down" can only make number of drones smaller (or the same),
-- not larger.

drillDown
    :: NonEmpty Sphere
    -> Point3
drillDown ss0 = go (addIn bb0 ss0 PSQ.empty)
  where
    go :: OrdPSQ BoundingBox (Down Int) (NonEmpty Sphere) -> Point3
    go q0 = case PSQ.minView q0 of
      Nothing -> error "ran out of points? this shouldn't happen."
      Just (bb@(V2 mn mx), _, ss, q1)
        | mn == mx  -> mn
        | otherwise -> go $ foldl' (flip processNew) q1 (splitOctants (toList ss) bb)
    processNew (bb, ss) = case NE.nonEmpty ss of
      Nothing  -> id
      Just ss' -> addIn bb ss'
    addIn bb ss = PSQ.insert bb (Down (length ss)) ss
    bb0 = boundingBox . foldMap1 (NE.fromList . circleBounds) $ ss0

octants :: BoundingBox -> [BoundingBox]
octants (V2 mns mxs)
    | mns == mxs = []
    | otherwise  = filter (\(V2 mn mx) -> all (>= 0) (mx - mn))
                 $ zipWith V2 (boundingCube (V2 mns (mid + 1)))
                              (boundingCube (V2 mid mxs     ))
  where
    mid = (\x y -> (x + y) `div` 2) <$> mns <*> mxs

boundingCube
    :: BoundingBox
    -> [Point3]
boundingCube = traverse (\(V2 mn mx) -> [mn,mx]) . L.transpose

day23b :: _ :~> _
day23b = MkSol
    { sParse = Just . parse23
    , sShow  = show
    , sSolve = fmap (mannDist 0 . drillDown) . NE.nonEmpty
    }

circleBounds :: Sphere -> [Point3]
circleBounds (S c r) =
    [ c + d
    | b <- [ V3 r 0 0
           , V3 0 r 0
           , V3 0 0 r
           ]
    , d <- [b, -b]
    ]




parse23 :: String -> [Sphere]
parse23 = mapMaybe (go . map read . words . clearOut d) . lines
  where
    d '-' = False
    d c   = not (isDigit c)
    go [x,y,z,r] = Just $ S (V3 x y z) r
    go _         = Nothing