Optimised day 19

[advent-of-code-22.git] / advent15 / Main.hs

diff --git a/advent15/Main.hs b/advent15/Main.hs
index 9ed5d862ee465d5e496feab50c27f6a236aaa34e..664e47d0ab4bb73a4b44cb135d96ebd35400aa13 100644 (file)
--- a/advent15/Main.hs
+++ b/advent15/Main.hs
@@ -4,34 +4,43 @@ import AoC
 import Data.Text (Text)
 import qualified Data.Text.IO as TIO
 import Data.Attoparsec.Text hiding (take, D)
-import Control.Applicative
-import Data.List
 import Data.Ix
-import qualified Data.Set as S
+-- import qualified Data.Set as S
 import Linear hiding (Trace, trace, distance)
-import Control.Lens
+import Data.List (sortOn)
+import Data.List.Split (chunksOf)
+import Data.Ord (Down(..))
+-- import Data.Maybe
+import Control.Parallel.Strategies -- (rpar, using, withStrategy, parList, parMap)
+-- import Control.DeepSeq
+
 
 type Position = V2 Int
 
 data Sensor = Sensor Position Position -- sensor position, beacon position
   deriving (Eq, Show)
 
+instance Ord Sensor where
+  (Sensor s1 b1) `compare` (Sensor s2 b2) = (s1 `manhattan` b1) `compare` (s2 `manhattan` b2)
+
 newtype Region = Region { getRegion :: Position -> Bool }  
 
 instance Semigroup Region where
   r1 <> r2 = Region (\p -> getRegion r1 p || getRegion r2 p)
 
 instance Monoid Region where
-  mempty = Region (\p -> False)
+  -- mempty = Region (\p -> False)
+  mempty = Region (const False)
 
 main :: IO ()
 main = 
   do  dataFileName <- getDataFileName
       text <- TIO.readFile dataFileName
       let sensors = successfulParse text
+      let coverage = mconcat $ fmap nearby $ sortOn Down sensors
       -- print sensors
-      print $ part1 sensors
-      print $ part2 sensors
+      print $ part1 sensors coverage
+      print $ part2 sensors coverage
 
 thisY :: Int
 -- thisY = 10
@@ -41,16 +50,24 @@ searchRange :: (Position, Position)
 -- searchRange = ((V2 0 0), (V2 20 20))
 searchRange = ((V2 0 0), (V2 4000000 4000000))
 
-part1, part2 :: [Sensor] -> Int
-part1 sensors = length $ filter (\p -> p `notElem` occupied) $ filter (getRegion coverage) rowCoords
-  where coverage = mconcat $ fmap nearby sensors
-        rowCoords = range ((V2 (globalMinX sensors) thisY), (V2 (globalMaxX sensors) thisY))
+part1, part2 :: [Sensor] -> Region -> Int
+part1 sensors coverage = sum (fmap countForbidden rowChunks `using` (parList rseq))
+  where rowCoords = range ( (V2 (globalMinX sensors) thisY)
+                          , (V2 (globalMaxX sensors) thisY)
+                          )
+        rowChunks = chunksOf 1000 rowCoords
         occupied = concatMap (\(Sensor s b) -> [s, b]) sensors
+        countForbidden positions = 
+          length $ filter (\p -> p `notElem` occupied) 
+                 $ filter (getRegion coverage) positions
+
+part2 sensors coverage = x * 4000000 + y
+  where boundaries = fmap (filter (inRange searchRange)) 
+                      $ fmap justOutside sensors
+        holes = fmap (filter (not . (getRegion coverage))) boundaries
+                   `using` (parList rseq)
+        V2 x y = head $ concat holes
 
-part2 sensors = x * 4000000 + y
-  where coverage = mconcat $ fmap nearby sensors
-        boundaries = S.filter (inRange searchRange) $ S.unions $ fmap justOutside sensors
-        V2 x y = S.findMin $ S.filter (\p -> not $ getRegion coverage p) boundaries
 
 manhattan :: Position -> Position -> Int
 manhattan p1 p2 = (abs dx) + (abs dy)
@@ -68,8 +85,8 @@ globalMinX, globalMaxX :: [Sensor] -> Int
 globalMinX = minimum . fmap minX
 globalMaxX = maximum . fmap maxX
 
-justOutside :: Sensor -> S.Set Position
-justOutside (Sensor s@(V2 sx sy) b) = S.fromList (topLeft ++ topRight ++ bottomLeft ++ bottomRight)
+justOutside :: Sensor -> [Position]
+justOutside (Sensor s@(V2 sx sy) b) = topLeft ++ topRight ++ bottomLeft ++ bottomRight
   where d = 1 + manhattan s b
         topLeft = [V2 x y | (x, y) <- zip [(sx - d)..sx] [sy..(sy + d)] ]
         topRight = [V2 x y | (x, y) <- zip [(sx + d), (sx + d - 1)..sx] [sy..(sy + d)] ]