From 521ed807433f998863c7c603f294328b87be741e Mon Sep 17 00:00:00 2001
From: Manu Phatak <manu@phatak.io>
Date: Sun, 10 Jan 2021 15:45:06 -0800
Subject: [PATCH 1/2] Create a Circuit Arrow

---
 AdventOfCode2020.cabal            |  2 ++
 src/Practice/ArrowCircuit.hs      | 51 +++++++++++++++++++++++++++++++
 test/Practice/ArrowCircuitSpec.hs | 16 ++++++++++
 3 files changed, 69 insertions(+)
 create mode 100644 src/Practice/ArrowCircuit.hs
 create mode 100644 test/Practice/ArrowCircuitSpec.hs

diff --git a/AdventOfCode2020.cabal b/AdventOfCode2020.cabal
index ddb5e5a..0f5e840 100644
--- a/AdventOfCode2020.cabal
+++ b/AdventOfCode2020.cabal
@@ -53,6 +53,7 @@ library
       Day18.Solution
       Day20.Solution
       Day21.Solution
+      Practice.ArrowCircuit
       Practice.Foldable
       Template.Solution
   other-modules:
@@ -99,6 +100,7 @@ test-suite AdventOfCode2020-test
       Day18.SolutionSpec
       Day20.SolutionSpec
       Day21.SolutionSpec
+      Practice.ArrowCircuitSpec
       Practice.FoldableSpec
       Template.SolutionSpec
       Paths_AdventOfCode2020
diff --git a/src/Practice/ArrowCircuit.hs b/src/Practice/ArrowCircuit.hs
new file mode 100644
index 0000000..7fc49b5
--- /dev/null
+++ b/src/Practice/ArrowCircuit.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE TupleSections #-}
+
+module Practice.ArrowCircuit where
+
+import Control.Arrow
+import Control.Category (Category (..))
+import qualified Control.Category as Category
+import Data.Traversable (mapAccumL)
+import Prelude hiding (id, (.))
+
+-- from https://en.wikibooks.org/wiki/Haskell/Arrow_tutorial
+newtype Circuit a b = Circuit {getCircuit :: a -> (Circuit a b, b)}
+
+instance Category Circuit where
+  id = Circuit (Category.id,)
+  (.) = dot
+    where
+      (Circuit g) `dot` (Circuit f) = Circuit $ \a ->
+        let (f', b) = f a
+            (g', c) = g b
+         in (g' `dot` f', c)
+
+instance Arrow Circuit where
+  arr f = Circuit $ \a -> (arr f, f a)
+  first (Circuit f) = Circuit $ \(b, d) ->
+    let (f', c) = f b
+     in (first f', (c, d))
+
+runCircuit :: Traversable t => Circuit a c -> t a -> t c
+runCircuit cir = snd . mapAccumL getCircuit cir
+
+accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b
+accum acc f = Circuit $ \input ->
+  let (output, acc') = input `f` acc
+   in (accum acc' f, output)
+
+accum' :: b -> (a -> b -> b) -> Circuit a b
+accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b'))
+
+total :: Num a => Circuit a a
+total = accum' 0 (+)
+
+mean1 :: Fractional a => Circuit a a
+mean1 = (total &&& (const 1 ^>> total)) >>> arr (uncurry (/))
+
+mean2 :: Fractional a => Circuit a a
+mean2 = proc value -> do
+  t <- total -< value
+  n <- total -< 1
+  returnA -< t / n
diff --git a/test/Practice/ArrowCircuitSpec.hs b/test/Practice/ArrowCircuitSpec.hs
new file mode 100644
index 0000000..1c25d79
--- /dev/null
+++ b/test/Practice/ArrowCircuitSpec.hs
@@ -0,0 +1,16 @@
+module Practice.ArrowCircuitSpec where
+
+import Practice.ArrowCircuit
+import Test.Hspec
+
+spec :: Spec
+spec = parallel $ do
+  describe "runCircuit" $ do
+    it "creates running total of all numbers passed as inputs" $ do
+      runCircuit total [1, 0, 1, 0, 0, 2] `shouldBe` [1 :: Int, 1, 2, 2, 2, 4]
+
+    it "can calculate mean" $ do
+      runCircuit mean1 [0, 10, 7, 8] `shouldBe` [0.0 :: Double, 5.0, 5.666666666666667, 6.25]
+
+    it "can calculate mean" $ do
+      runCircuit mean2 [0, 10, 7, 8] `shouldBe` [0.0 :: Double, 5.0, 5.666666666666667, 6.25]

From ed451494ed2b4ca6bca6f7a23f073af19b44c61e Mon Sep 17 00:00:00 2001
From: Manu Phatak <manu@phatak.io>
Date: Sun, 10 Jan 2021 16:23:24 -0800
Subject: [PATCH 2/2] Work through a couple Arrow tutorials

---
 AdventOfCode2020.cabal               |  2 ++
 src/Practice/ArrowSimpleFunc.hs      | 43 ++++++++++++++++++++++++++++
 test/Practice/ArrowSimpleFuncSpec.hs | 11 +++++++
 3 files changed, 56 insertions(+)
 create mode 100644 src/Practice/ArrowSimpleFunc.hs
 create mode 100644 test/Practice/ArrowSimpleFuncSpec.hs

diff --git a/AdventOfCode2020.cabal b/AdventOfCode2020.cabal
index 0f5e840..269f9c5 100644
--- a/AdventOfCode2020.cabal
+++ b/AdventOfCode2020.cabal
@@ -54,6 +54,7 @@ library
       Day20.Solution
       Day21.Solution
       Practice.ArrowCircuit
+      Practice.ArrowSimpleFunc
       Practice.Foldable
       Template.Solution
   other-modules:
@@ -101,6 +102,7 @@ test-suite AdventOfCode2020-test
       Day20.SolutionSpec
       Day21.SolutionSpec
       Practice.ArrowCircuitSpec
+      Practice.ArrowSimpleFuncSpec
       Practice.FoldableSpec
       Template.SolutionSpec
       Paths_AdventOfCode2020
diff --git a/src/Practice/ArrowSimpleFunc.hs b/src/Practice/ArrowSimpleFunc.hs
new file mode 100644
index 0000000..7f4d383
--- /dev/null
+++ b/src/Practice/ArrowSimpleFunc.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE Arrows #-}
+
+module Practice.ArrowSimpleFunc where
+
+import Control.Arrow
+import Control.Category
+import Prelude hiding (id, (.))
+
+-- https://wiki.haskell.org/Arrow_tutorial
+newtype SimpleFunc a b = SimpleFunc {runF :: a -> b}
+
+instance Category SimpleFunc where
+  id = arr id
+  (SimpleFunc g) . (SimpleFunc f) = SimpleFunc (g . f)
+
+instance Arrow SimpleFunc where
+  arr f = SimpleFunc f
+  first (SimpleFunc f) = SimpleFunc (mapFst f)
+    where
+      mapFst g (b, d) = (g b, d)
+  second (SimpleFunc f) = SimpleFunc (mapSnd f)
+    where
+      mapSnd g (d, b) = (d, g b)
+
+unsplit :: (Arrow a) => (b -> c -> d) -> a (b, c) d
+unsplit = arr . uncurry
+
+liftA2 :: Arrow cat => (c1 -> c2 -> c3) -> cat a c1 -> cat a c2 -> cat a c3
+liftA2 op f g = f &&& g >>> unsplit op
+
+f, g :: SimpleFunc Int Int
+f = arr (`div` 2)
+g = arr (\x -> x * 3 + 1)
+
+h :: SimpleFunc Int Int
+h = liftA2 (+) f g
+
+h' :: SimpleFunc Int Int
+h' = proc x -> do
+  fx <- f -< x
+  gx <- g -< x
+
+  returnA -< (fx + gx)
diff --git a/test/Practice/ArrowSimpleFuncSpec.hs b/test/Practice/ArrowSimpleFuncSpec.hs
new file mode 100644
index 0000000..cf1b1ea
--- /dev/null
+++ b/test/Practice/ArrowSimpleFuncSpec.hs
@@ -0,0 +1,11 @@
+module Practice.ArrowSimpleFuncSpec where
+
+import Practice.ArrowSimpleFunc
+import Test.Hspec
+
+spec :: Spec
+spec = parallel $ do
+  it "it fans out and collapses" $ do
+    runF h 8 `shouldBe` 29
+  it "works with arrow notation" $ do
+    runF h' 8 `shouldBe` 29