Arrow tutorial

Arrow.fs

[<AutoOpen>]
module Operators =
    let uncurry f (a, b) = f a b
    let cnst x _ = x

/// https://en.wikibooks.org/wiki/Haskell/Arrow_tutorial
type Circuit<'a, 'b> = Cir of TransitionFunction<'a, 'b>
and TransitionFunction<'a, 'b> = 'a -> Circuit<'a, 'b> * 'b

module Circuit =

    /// Lifts a function into a circuit.
    let rec arr f =
        Cir (fun a -> arr f, f a)

    /// Composes two circuits, left to right.
    let rec (>>>) (Cir tf1) (Cir tf2) =
        Cir (fun a ->
            let cir1', b = tf1 a
            let cir2', c = tf2 b
            cir1' >>> cir2', c)

    /// Composes two circuits, right to left.
    let rec (<<<) (Cir tf1) (Cir tf2) =
        Cir (fun a ->
            let cir2', b = tf2 a
            let cir1', c = tf1 b
            cir1' <<< cir2', c)

    /// Combines two circuits in parallel.
    let rec ( ***) (Cir tf1) (Cir tf2) =
        Cir (fun (a, b) ->
            let cir1', c = tf1 a
            let cir2', d = tf2 b
            cir1' *** cir2', (c, d))

    /// Composes a function with a circuit, left to right.
    let (^>>) f cir =
        arr f >>> cir

    /// Shares an input between two circuits.
    let rec (&&&) cir1 cir2 =
        (fun a -> (a, a)) ^>> (cir1 *** cir2)

    let rec first cir =
        cir *** arr id

    let rec second cir =
        arr id *** cir

    let arr2 f =
        f |> uncurry |> arr

module Test =

    open Circuit

    /// Runs a circuit.
    let rec run (Cir tf) = function
        | a :: tail ->
            let cir', b = tf a
            b :: run cir' tail
        | [] -> []

    let rec accum acc f =
        Cir (fun input ->
            let output, acc' = f input acc
            accum acc' f, output)

    let accum' acc f =
        accum acc (fun input acc ->
            let acc' = f input acc
            acc', acc')

    let total = accum' 0.0 (+)

    let mean =
        (total &&& (cnst 1.0 ^>> total)) >>> (arr2 (/))

Test.run Test.mean [0.0; 10.0; 7.0; 8.0]
    |> printfn "%A"