F# Transducers test

FsTranducers.fs

module Common =
  let inline adapt    f     = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
  let inline invoke   f s v = (f : OptimizedClosures.FSharpFunc<_, _, _>).Invoke (s, v)

module MinimalisticTransducers =
  // Disable Tiered compilation using powershell: $env:COMPlus_TieredCompilation=0

  let inline (^>)   l r       = l r 
  let inline (>->)  l r v     = l (r v) 

  let inline choose   m f s v = match m v with ValueSome vv -> f s vv | _ -> s
  let inline filter   m f s v = if m v then f s v else s
  let inline map      m f s v = f s (m v)

  let inline apply    t e f s v = t f s (e v)

module Transducers =
  // Disable Tiered compilation using powershell: $env:COMPlus_TieredCompilation=0
  open Common

  let inline (^>)   l r     = l r 
  let inline (>->)  l r v   = l (r v) 

  let inline choose   m f   = let f = adapt f in fun s v -> match m v with ValueSome vv -> invoke f s vv | _ -> s
  let inline filter   m f   = let f = adapt f in fun s v -> if m v then invoke f s v else s
  let inline map      m f   = let f = adapt f in fun s v -> invoke f s (m v)

  let inline apply    t e f = fun s v -> t f s (e v)

module FunctionalTests =
  open MinimalisticTransducers
  module MinimalisticTransducers =
    let transduce t vs =
      let f = t (fun s v -> v::s)
      List.fold f [] vs |> List.rev
    type Properties =
      class
        static member ``choose <=> List.choose`` (v : int) (vs : int list) =
          let c s n v' = if (v + v') % 2 = 0 then s (v + 1) else n
          let e = vs |> List.choose (c Some None)
          let a = vs |> transduce (choose (c ValueSome ValueNone))
          e = a

        static member ``filter <=> List.filter`` (v : int) (vs : int list) =
          let f v' = (v + v') % 2 = 0
          let e = vs |> List.filter f
          let a = vs |> transduce (filter f)
          e = a

        static member ``map <=> List.map`` (v : int) (vs : int list) =
          let m = (+) v
          let e = vs |> List.map m
          let a = vs |> transduce (map m)
          e = a

        static member ``apply is sort of likeList.collect`` (v : int) (vs : int list list) =
          let m = (+) v
          let e = vs |> List.collect id 
          let a = vs |> transduce (apply List.fold id)
          e = a

        static member ``non-trivial transduce`` (vs : int list) =
          let f v = v % 2L = 0L
          let m v = v + 1L
          let e = vs |> List.map int64 |> List.filter f |> List.map m
          let a = vs |> transduce (map int64 >-> filter f >-> map m)
          e = a

        static member ``non-trivial transduce with apply`` (vs : int list list) =
          let f v = v % 2L = 0L
          let m v = v + 1L
          let e = vs |> List.collect (List.map int64 >> List.filter f) |> List.map m
          let a = vs |> transduce (apply List.fold id >-> map int64 >-> filter f >-> map m)
          e = a
      end

  open FsCheck
  let run () =
    let count  = 100
    let config = { Config.Quick with MaxTest = count; MaxFail = count }
    Check.All<MinimalisticTransducers.Properties> config

module PerformanceTests =
  open System
  open System.Diagnostics

  let sw =
    let sw = Stopwatch ()
    sw.Start ()
    sw

  let time n a =
    let v = a ()

    let inline cc n = GC.CollectionCount n
    let bcc0, bcc1, bcc2 = cc 0, cc 1, cc 2
    let before = sw.ElapsedMilliseconds

    for i = 1 to n do
      a () |> ignore

    let after = sw.ElapsedMilliseconds
    let acc0, acc1, acc2 = cc 0, cc 1, cc 2

    v, after - before, (acc0 - bcc0, acc1 - bcc1, acc2 - bcc2)

  module PerfBaseline =
    let test n =
      let mutable sum = 0L
      for i = 0 to (n - 1) do
        let i = int64 i
        if (i &&& 1L) = 0L then
          let i = i + 1L
          sum <- sum + i
      sum

  module PerfArray =
    let test n =
      Array.init      n id
      |> Array.map    int64
      |> Array.filter (fun v -> (v &&& 1L) = 0L)
      |> Array.map    ((+) 1L)
      |> Array.sum

  module PerfList =
    let test n =
      List.init       n id
      |> List.map     int64
      |> List.filter  (fun v -> (v &&& 1L) = 0L)
      |> List.map     ((+) 1L)
      |> List.sum

  module PerfNessos =
    open Nessos.Streams
    let test n =
      Stream.initInfinite id
      |> Stream.take      n
      |> Stream.map       int64
      |> Stream.filter    (fun v -> (v &&& 1L) = 0L)
      |> Stream.map       ((+) 1L)
      |> Stream.sum

  module PerfLinq =
    open System.Linq
    let test n = Enumerable.Range(0, n).Select(int64).Where(fun v -> (v &&& 1L) = 0L).Select((+) 1L).Sum()

  module PerfTransducer1 =
    open Common
    open MinimalisticTransducers

    let inline rangeFold f s b e = 
      let f = adapt f
      let mutable sum = s
      for i = b to e do
        sum <- invoke f sum i
      sum

    let test n =
      let inline f s v = (map int64 ^> filter (fun v -> v &&& 1L = 0L) ^> map ((+) 1L) ^> (+)) s v
      rangeFold f 0L 0 (n - 1)

  module PerfTransducer2 =
    open Common
    open MinimalisticTransducers

    let inline rangeTransduce t f s b e = 
      let ff = t f
      let ff = adapt ff
      let mutable sum = s
      for i = b to e do
        sum <- invoke ff sum i
      sum

    let test n =
      rangeTransduce (map int64 >-> filter (fun v -> v &&& 1L = 0L) >-> map ((+) 1L)) (+) 0L 0 (n - 1)

  module PerfSeq =
    let test n =
      Seq.init        n id
      |> Seq.map      int64
      |> Seq.filter   (fun v -> (v &&& 1L) = 0L)
      |> Seq.map      ((+) 1L)
      |> Seq.sum

  let run () =
    let total     = 10000000
    let outers    = [| 100; 1000; 10000; 100000 |]
    let testCases =
      [|
        "baseline"    , fun n () -> PerfBaseline.test     n
        "transducer1" , fun n () -> PerfTransducer1.test  n
        "transducer2" , fun n () -> PerfTransducer2.test  n
//        "nessos"      , fun n () -> PerfNessos.test       n
//        "array"       , fun n () -> PerfArray.test        n
//        "list"        , fun n () -> PerfList.test         n
//        "linq"        , fun n () -> PerfLinq.test         n
//        "seq"         , fun n () -> PerfSeq.test          n
      |]

    for outer in outers do
      let inner = total / outer
      assert (inner > 0)
      assert (total % outer = 0)

      printfn "Test run, total: %d, outer: %d, inner: %d" total outer inner

      for n, a in testCases do
        printfn "  Running test case '%s' ..." n
        let v, ms, cc = time outer (a inner)
        printfn "  ... it took %d ms with %A cc and produced: %A" ms cc v

[<EntryPoint>]
let main argv =
  FunctionalTests.run ()
  PerformanceTests.run ()
  0