From 5eb58ad076f2cd435b11b140820da224b60b73d5 Mon Sep 17 00:00:00 2001
From: Aria <me@aria.rip>
Date: Mon, 2 Jan 2023 21:58:56 +0000
Subject: initial commit

---
 2020/23b.hs | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 82 insertions(+)
 create mode 100644 2020/23b.hs

(limited to '2020/23b.hs')

diff --git a/2020/23b.hs b/2020/23b.hs
new file mode 100644
index 0000000..926ce5e
--- /dev/null
+++ b/2020/23b.hs
@@ -0,0 +1,82 @@
+module Main where
+
+import System.Environment (getArgs)
+import Text.Printf (printf)
+import qualified Data.IntMap as M;
+import Debug.Trace (trace)
+import Data.List (foldl')
+
+-- Types
+-- Stores the next cup for each cup value.
+type State = M.IntMap Int;
+
+-- Parsing input
+parseLine :: String -> [Int]
+parseLine = map (read . (: ""))
+
+parseFile :: String -> IO [Int]
+parseFile f = do 
+                c <- readFile f
+                return (parseLine c);
+
+-- The maximum value cup to use
+maxCup :: Int
+maxCup = 1000000
+
+getNextCup :: State -> Int -> Int;
+getNextCup m n = M.findWithDefault (n + 1) n m
+
+-- Get the label of destination cup, given the current cup and the cups set aside
+getDestCup :: Int -> [Int] -> Int
+getDestCup x r | x <= 1 = last [i | i <- [maxCup - 4..maxCup], i `notElem` r]
+               | x - 1 `notElem` r = x - 1
+               | otherwise = getDestCup (x - 1) r
+
+-- Returns new state and whole chain of removed ones
+takeN :: State -> Int -> Int -> (State, [Int])
+takeN s i n = (M.insert i after s, finalIn)
+          where (_:finalIn) = foldr (\_ ks -> ks ++ [s `getNextCup` last ks]) [i] [1..n]
+                after = s `getNextCup` last finalIn
+
+
+-- Perform a single move on the given state with the given current cup
+-- Returns the new state and next current cup
+performMove :: State -> Int -> (State, Int)
+performMove m c = (m', (m' `getNextCup` c))
+        where (re, chain) = takeN m c 3
+              d = getDestCup c chain
+              m' = M.fromList [(d, head chain), (last chain, m `getNextCup` d)] `M.union` re
+
+-- Repeatedly performMove. This uses foldl' to prevent stack overflow
+performMoves :: State -> Int -> Int -> State
+performMoves s c n = fst $ foldl' (\(s', c') n -> performMove s' c') (s, c) [1..n]
+
+constructState :: [Int] -> State
+constructState xs = M.fromList [(last xs, maximum xs + 1), (maxCup, head xs)] `M.union` inner xs
+  where inner [] = M.empty
+        inner [x] = M.empty
+        inner (x:y:ns) = M.insert x y $ inner (y:ns)
+
+-- This is infinite, so use `take`
+getLinear :: State -> Int -> [Int]
+getLinear s c = n : getLinear s n
+    where n = s `getNextCup` c
+
+-- Usage: runghc 23b.hs inputs/day23
+main :: IO ()
+main = do 
+        args <- getArgs;
+        ns <- parseFile $ head args;
+
+        let circ = constructState ns;
+
+        let final = performMoves circ (head ns) 10000000;
+        let [a,b] = take 2 $ getLinear final 1;
+
+        printf "%d * %d = %d\n" a b (a * b);
+        return ();
+
+-- Utilities
+unwrap :: Maybe a -> a
+unwrap (Just x) = x
+unwrap _ = error "unwrap on null value"
\ No newline at end of file
-- 
cgit v1.2.3