Day14, move stuff to libraries, aoc2024 -> samples, fix FC on an error

aoc2024/Day10.newt

@@ -16,21 +16,6 @@ gridPoints text = go 0 0 (unpack text) Nil
     go row col ('\n' :: cs) points = go (row + 1) 0 cs points
     go row col (c :: cs) points = go row (col + 1) cs ((c,row,col) :: points)
 
-Point : U
-Point = Int × Int
-
-instance Add Point where
-  (a,b) + (c,d) = (a + c, b + d)
-
-instance Sub Point where
-  (a,b) - (c,d) = (a - c, b - d)
-
-instance Ord Point where
-  (a,b) < (c,d) = a < c || a == c && b < d
-
-instance Eq Point where
-  (a,b) == (c,d) = a == c && b == d
-
 -- TODO add parameter a and pass Char -> a into getGrid
 Grid : U
 Grid = SortedMap Point Int
@@ -59,12 +44,6 @@ paths grid pts ht =
     getCands : Point → List (Point × Int)
     getCands pt = mapMaybe (\ p => lookupMap p grid) (peers pt)
 
-foldMap : ∀ a b. {{Ord a}} {{Eq a}} → (b → b → b) → SortedMap a b → List (a × b) → SortedMap a b
-foldMap f m Nil = m
-foldMap f m ((a,b) :: xs) = case lookupMap a m of
-  Nothing => foldMap f (updateMap a b m) xs
-  Just (_, b') => foldMap f (updateMap a (f b' b) m) xs
-
 paths2 : Grid → List (Point × Int) → Int → Int
 paths2 grid pts ht =
   if ht == 9 then foldl _+_ 0 $ map snd $ pts else

aoc2024/Day11.newt

@@ -14,12 +14,6 @@ pfunc divide uses (_,_) : String → String × String := `(s) => {
   return _$2C_(undefined, undefined, s.slice(0,l), s.slice(l))
 }`
 
-foldMap : ∀ a b. {{Ord a}} {{Eq a}} → (b → b → b) → SortedMap a b → List (a × b) → SortedMap a b
-foldMap f m Nil = m
-foldMap f m ((a,b) :: xs) = case lookupMap a m of
-  Nothing => foldMap f (updateMap a b m) xs
-  Just (_, b') => foldMap f (updateMap a (f b' b) m) xs
-
 step : List (Int × Int) → List (Int × Int)
 step = go Nil
   where

aoc2024/Day11b.newt

@@ -22,12 +22,6 @@ stone num = if num == 0 then Left 1 else go num num 1
       else if b < 10 then Left (2024 * num)
       else go (div53 a 10) (div53 b 100) (mod * 10)
 
-foldMap : ∀ a b. {{Ord a}} {{Eq a}} → (b → b → b) → SortedMap a b → List (a × b) → SortedMap a b
-foldMap f m Nil = m
-foldMap f m ((a,b) :: xs) = case lookupMap a m of
-  Nothing => foldMap f (updateMap a b m) xs
-  Just (_, b') => foldMap f (updateMap a (f b' b) m) xs
-
 step : List (Int × Int) → List (Int × Int)
 step xs = go Nil xs
   where

aoc2024/Day12.newt

@@ -16,21 +16,6 @@ gridPoints text = go 0 0 (unpack text) Nil
     go row col ('\n' :: cs) points = go (row + 1) 0 cs points
     go row col (c :: cs) points = go row (col + 1) cs ((c,row,col) :: points)
 
-Point : U
-Point = Int × Int
-
-instance Add Point where
-  (a,b) + (c,d) = (a + c, b + d)
-
-instance Sub Point where
-  (a,b) - (c,d) = (a - c, b - d)
-
-instance Ord Point where
-  (a,b) < (c,d) = a < c || a == c && b < d
-
-instance Eq Point where
-  (a,b) == (c,d) = a == c && b == d
-
 -- TODO add parameter a and pass Char -> a into getGrid
 Grid : U
 Grid = SortedMap Point Int

aoc2024/Day13.newt

@@ -5,27 +5,6 @@ import Node
 import Aoc
 import Parser
 
-
-Point : U
-Point = Int × Int
-
-instance Add Point where
-  (a,b) + (c,d) = (a + c, b + d)
-
-instance Sub Point where
-  (a,b) - (c,d) = (a - c, b - d)
-
-instance Ord Point where
-  (a,b) < (c,d) = a < c || a == c && b < d
-
-instance Eq Point where
-  (a,b) == (c,d) = a == c && b == d
-
-
-token : String → Parser Unit
-token str = string str >> ws
-
-
 data Machine : U where
   MkMachine : Point → Point → Point → Machine
 

aoc2024/Day14.newt

@@ -0,0 +1,156 @@
+module Day14
+
+import Prelude
+import Node
+import Aoc
+import Parser
+import SortedMap
+
+data Robot : U where
+  MkBot : Point → Point → Robot
+
+pint : Parser Int
+pint = do
+  sign <- pure (0 - 1) <* match '-' <|> pure 1
+  num <- number
+  pure $ sign * num
+
+ppoint : Parser Point
+ppoint = _,_ <$> pint <* match ',' <*> pint
+
+probot : Parser Robot
+probot = do
+  token "p="
+  p <- ppoint
+  ws
+  token "v="
+  v <- ppoint
+  ws
+  many (match '\n')
+  pure $ MkBot p v
+
+-- TODO make Mod typeclass or something
+infixl 7 _%_
+pfunc _%_ : Int → Int → Int := `(x,y) => x % y`
+
+pmod : Int → Int → Int
+pmod a b =
+  if a < 0 then (a + b * ((0 - a / b) + 1)) % b else a % b
+
+move : Int → Int → Int → Robot → Point
+move w h time (MkBot (x,y) (dx,dy)) =
+  -- no HMul yet
+  -- let (x',y') = trace "to" $ (x,y) + (time * dx, time * dy) in
+  let x' = pmod (x + time * dx) w
+      y' = pmod (y + time * dy) h
+   in (x', y')
+
+count : ∀ a. (a → Bool) → List a → Int
+count {a} f xs = go xs 0
+  where
+    go : List a → Int → Int
+    go Nil acc = acc
+    go (x :: xs) acc = if f x then go xs (acc + 1) else go xs acc
+
+draw' : Int → Int → SortedMap Point Int → IO Unit
+draw' w h pts = go 0
+  where
+    mkLine : Int → Int → SnocList Char → String
+    mkLine y x acc = if x == w then pack (acc <>> Nil)
+      else case lookupMap (x,y) pts of
+        Nothing => mkLine y (x + 1) (acc :< '.')
+        _       => mkLine y (x + 1) (acc :< '*')
+
+    go : Int → IO Unit
+    go y = if y == h then pure MkUnit else do
+      putStrLn $ mkLine y 0 Lin
+      go (y + 1)
+
+draw : Int → Int → List Point → IO Unit
+draw w h pts =
+  let m = foldMap _+_ EmptyMap $ map (flip _,_ 1) pts in draw' w h m
+
+
+part2 : Int → Int → List Robot → List Point × Int
+part2 w h robots = go 1
+  where
+    heuristic : Point → Bool
+    heuristic (x,y) = if x < w / 2 then 100 < 2 * x + y else 2 * (x - 50) < y
+    -- heuristic (x,y) = x == w / 2
+    go : Int → List Point × Int
+    go t =
+      let pts = map (move w h t) robots
+          cnt = count heuristic pts
+      in if cnt > 20 then (pts, t)
+      else go (t + 1)
+
+run : String → Int → Int → IO Unit
+run fn w h = do
+  putStrLn fn
+  text <- readFile fn
+  let (Right (robots, Nil)) = some probot $ unpack text
+    | Left msg => putStrLn $ "Parse Error " ++ msg
+    | Right (robots, rest) => putStrLn $ "stuck at¬" ++ pack rest
+  let result = map (move w h 100) robots
+  -- debugLog result
+  let q1 = count quad1 result
+  let q2 = count quad2 result
+  let q3 = count quad3 result
+  let q4 = count quad4 result
+  debugLog (q1,q2,q3,q4)
+  let p1 = q1 * q2 * q3 * q4
+  putStrLn $ "part1 " ++ show p1
+  printLn $ count (\ x => True) robots
+  let scores = collect robots 0 Nil
+  let stuff = qsort (\ a b => snd a < snd b) $ collect robots 0 Nil
+  -- debugLog stuff
+  dump robots stuff 1
+  where
+    dump : List Robot → List (Int × Int) → Int → IO Unit
+    dump robots Nil _ = pure MkUnit
+    dump robots (((t,cnt) :: xs)) 0 = pure MkUnit
+    dump robots (((t,cnt) :: xs)) gas = do
+      printLn t
+      draw w h $ map (move w h t) robots
+      printLn ""
+      dump robots xs (gas - 1)
+
+    quad1 : Point → Bool
+    quad1 (x,y) = x < w / 2 && y < h / 2
+
+    quad2 : Point → Bool
+    quad2 (x,y) = x > w / 2 && y < h / 2
+
+    quad3 : Point → Bool
+    quad3 (x,y) = x > w / 2 && y > h / 2
+
+    quad4 : Point → Bool
+    quad4 (x,y) = x < w / 2 && y > h / 2
+
+    heuristic : Point → Bool
+    heuristic (x,y) = if x < w / 2  then 100 - 2 * x < y else 2 * x - 100 < y
+
+    dist : Point → Int
+    dist (x,y) = let d = if x < w / 2 then y - (h - 2 * x) else y - (h - 2 * (w - x)) in
+      if d < 0 then 0 - d else d
+
+    collect : List Robot → Int → List (Int × Int) → List (Int × Int)
+    collect robots iter acc =
+      if iter > w * h then acc else
+      let pts = map (move w h iter) robots in
+
+      -- This heuristic found it, attempting to find an outline of a large tree
+      -- but the picture looks nothing like that, so I got lucky
+      -- let cnt = foldl _+_ 0 $ map dist pts in
+      -- so I'll go with min danger (although it takes 4 * as long)
+      let q1 = count quad1 pts
+          q2 = count quad2 pts
+          q3 = count quad3 pts
+          q4 = count quad4 pts
+          cnt = q1 * q2 * q3 * q4 in
+      collect robots (iter + 1) ((iter,cnt) :: acc)
+
+main : IO Unit
+main = do
+  -- run "aoc2024/day14/eg.txt" 11 7
+  run "aoc2024/day14/input.txt" 101 103

aoc2024/Day6.newt

@@ -5,15 +5,6 @@ import Node
 import Aoc
 import SortedMap
 
-Point : U
-Point = Int × Int
-
-instance Eq Point where
-  (a,b) == (c,d) = a == c && b == d
-
-instance Ord Point where
-  (a,b) < (c,d) = a < c || a == c && b < d
-
 Grid : U
 Grid = SortedMap Point Char
 

aoc2024/Day8.newt

@@ -5,15 +5,6 @@ import Node
 import Aoc
 import SortedMap
 
-Point : U
-Point = Int × Int
-
-instance Add Point where
-  (a,b) + (c,d) = (a + c, b + d)
-
-instance Sub Point where
-  (a,b) - (c,d) = (a - c, b - d)
-
 Ant : U
 Ant = Char × Int × Int
 
@@ -59,12 +50,6 @@ doGroup2 : Int -> List Ant -> List Point
 doGroup2 m (x :: xs) = join $ doGroup2 m xs ::  map (doPair2 m (snd x) ∘ snd) xs
 doGroup2 m Nil = Nil
 
-instance Ord Point where
-  (a,b) < (c,d) = a < c || a == c && b < d
-
-instance Eq Point where
-  (a,b) == (c,d) = a == c && b == d
-
 run : String -> IO Unit
 run fn = do
   putStrLn fn

aoc2024/Parser.newt

@@ -65,5 +65,11 @@ number = stringToInt ∘ pack <$> some (satisfy isDigit)
   -- digs <- some (satisfy isDigit)
   -- pure $ stringToInt $ pack digs
 
+optional : ∀ a. Parser a → Parser (Maybe a)
+optional pa = Just <$> pa <|> pure Nothing
+
 ws : Parser Unit
 ws = many (match ' ') >> pure MkUnit
+
+token : String → Parser Unit
+token str = string str >> ws

aoc2024/SortedMap.newt

@@ -187,3 +187,9 @@ toList {k} {v} (MapOf smap) = reverse $ go smap Nil
     go (Node2 t1 k1 t2) acc = go t2 (go t1 acc)
     go (Node3 t1 k1 t2 k2 t3) acc = go t3 $ go t2 $ go t1 acc
 toList _ = Nil
+
+foldMap : ∀ a b. {{Ord a}} {{Eq a}} → (b → b → b) → SortedMap a b → List (a × b) → SortedMap a b
+foldMap f m Nil = m
+foldMap f m ((a,b) :: xs) = case lookupMap a m of
+  Nothing => foldMap f (updateMap a b m) xs
+  Just (_, b') => foldMap f (updateMap a (f b' b) m) xs

aoc2024/day14/eg.txt

@@ -0,0 +1,12 @@
+p=0,4 v=3,-3
+p=6,3 v=-1,-3
+p=10,3 v=-1,2
+p=2,0 v=2,-1
+p=0,0 v=1,3
+p=3,0 v=-2,-2
+p=7,6 v=-1,-3
+p=3,0 v=-1,-2
+p=9,3 v=2,3
+p=7,3 v=-1,2
+p=2,4 v=2,-3
+p=9,5 v=-3,-3