Practice arrows

AdventOfCode2020.cabal

@@ -53,6 +53,8 @@ library
       Day18.Solution
       Day20.Solution
       Day21.Solution
+      Practice.ArrowCircuit
+      Practice.ArrowSimpleFunc
       Practice.Foldable
       Template.Solution
   other-modules:
@@ -99,6 +101,8 @@ test-suite AdventOfCode2020-test
       Day18.SolutionSpec
       Day20.SolutionSpec
       Day21.SolutionSpec
+      Practice.ArrowCircuitSpec
+      Practice.ArrowSimpleFuncSpec
       Practice.FoldableSpec
       Template.SolutionSpec
       Paths_AdventOfCode2020

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

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)

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]

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