Failed attempt at a multithreaded 16

3 files changed, 108 insertions, 1 deletions

diff --git a/2019/.gitignore b/2019/.gitignore
index ef5c4cb..efb2bbd 100644
--- a/2019/.gitignore
+++ b/2019/.gitignore
@@ -16,6 +16,7 @@ obj/
 14
 15
 16
+16multi
 17
 18
 19
diff --git a/2019/16multi.hs b/2019/16multi.hs
new file mode 100644
index 0000000..87046a5
--- /dev/null
+++ b/2019/16multi.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE BangPatterns, TypeApplications #-}
+module Main where
+
+import Control.Concurrent (getNumCapabilities, forkIO, forkOn)
+import Control.Concurrent.Chan (newChan, writeChan, readChan)
+import Control.Monad (forM_)
+import qualified Data.Array.Unboxed as A
+import qualified Data.Array.IO as IOA
+
+import Debug.Trace
+
+import Input
+
+
+ceilDiv :: Int -> Int -> Int
+ceilDiv a b = (a + b - 1) `div` b
+
+lastDigit :: Int -> Int
+lastDigit = abs . (`rem` 10)
+
+divideList :: Int -> [a] -> [[a]]
+divideList n l = blockBy (length l `div` n) l
+
+blockBy :: Int -> [a] -> [[a]]
+blockBy n l =
+    let (pre, post) = splitAt n l
+    in if null post then [pre] else pre : blockBy n post
+
+type Array = A.UArray Int
+
+prefixSums :: Array Int -> Array Int
+prefixSums input = A.listArray (0, snd (A.bounds input) + 1) (scanl (+) 0 (A.elems input))
+
+phase :: Array Int -> IO (Array Int)
+phase !input =
+    let end = snd (A.bounds input)
+        prefixes = prefixSums input
+        rangeSum from to = prefixes A.! to - prefixes A.! from
+        intervalSum acc offset step sign
+            | offset + step > end =
+                if offset > end
+                    then acc
+                    else acc + sign * rangeSum offset (end + 1)
+            | otherwise =
+                let acc' = acc + sign * rangeSum offset (offset + step)
+                in intervalSum acc' (offset + 2 * step) step (negate sign)
+    in do
+        chan <- newChan
+        destArr <- IOA.newArray (0, end) 0 :: IO (IOA.IOUArray Int Int)
+
+        -- nprocs <- getNumCapabilities
+        -- traceM (show nprocs ++ " threads")
+        -- let computePart idx =
+        --         -- sum_{i=1}^k 1/i ~= ln k + gamma
+        --         -- Find values k0=1,k1,...,kn=M such that sum_{i=kj}^{k{j+1}} 1/i = 1/n sum_{i=1}^M 1/i
+        --         --   (n = nprocs, M = end+1)
+        --         -- Approximately values such that ln k{j+1} - ln kj = 1/n ln M
+        --         -- Claim kj = M^(j/n)
+        --         -- Then ln k{j+1} - ln kj = (j+1)/n ln M - j/n ln M = 1/n ln M   \qed
+        --         let kvals = [round @Double (fromIntegral (end+1) ** (fromIntegral j / fromIntegral nprocs))
+        --                     | j <- [0..nprocs-1]]
+        --                     ++ [end+1]
+        --             intervals = (\l -> zip l (tail l)) (map pred kvals)
+        --         in forkOn idx $ do
+        --             let (low, high) = intervals !! idx
+        --             traceM ("thread " ++ show idx ++ ": writing [" ++ show low ++ ".." ++ show high ++ "]")
+        --             forM_ [low..high] $ \i -> IOA.writeArray destArr i (lastDigit (intervalSum 0 i (i+1) 1))
+        --             traceM ("thread " ++ show idx ++ ": writeChan")
+        --             writeChan chan ()
+
+        nprocs <- (*10) <$> getNumCapabilities
+        traceM (show nprocs ++ " threads")
+        let numPerPart = (end + 1) `ceilDiv` nprocs
+        let computePart idx =
+                let low = max 2 (idx * numPerPart)
+                    high = min ((idx + 1) * numPerPart - 1) end
+                in forkIO $ do
+                    traceM ("thread " ++ show idx ++ ": writing [" ++ show low ++ ".." ++ show high ++ "]")
+                    forM_ [low..high] $ \i -> IOA.writeArray destArr i (lastDigit (intervalSum 0 i (i+1) 1))
+                    traceM ("thread " ++ show idx ++ ": writeChan")
+                    writeChan chan ()
+        IOA.writeArray destArr 0 (lastDigit (intervalSum 0 0 1 1))
+        IOA.writeArray destArr 1 (lastDigit (intervalSum 0 1 2 1))
+
+        mapM_ computePart [0..nprocs-1]  -- spawn the threads
+        sequence_ (replicate nprocs (readChan chan))  -- wait for them to finish
+
+        IOA.freeze destArr
+
+fft :: Int -> [Int] -> IO [Int]
+fft times list = A.elems <$> go times (A.listArray (0, length list - 1) list)
+  where
+    go 0 arr = return arr
+    go n arr = phase arr >>= go (n - 1)
+
+main :: IO ()
+main = do
+    inpString <- head <$> getInput 16
+
+    let inpList = map (read . pure) inpString
+    concatMap show . take 8 <$> fft 100 inpList >>= putStrLn
+
+    let messageOffset = read (take 7 inpString)
+
+    -- Note: Part 2 takes 3m20s for me
+    concatMap show . take 8 . drop messageOffset <$> fft 100 (concat (replicate 10000 inpList)) >>= putStrLn
diff --git a/2019/Makefile b/2019/Makefile
index ee0449e..a21d52b 100644
--- a/2019/Makefile
+++ b/2019/Makefile
@@ -1,5 +1,5 @@
 GHC = ghc
-GHCFLAGS = -Wall -O3
+GHCFLAGS = -Wall -O3 -threaded
 CXX = g++
 CXXFLAGS = -Wall -Wextra -std=c++17 -O2