gen.fs

module FsGen =
  module Details =
    let inline adapt f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f

  open System
  open Details

  type [<Struct>] StdGen = StdGen of int*int

  module Random =
    open System.Diagnostics

    //Haskell has mod,quot, en divMod. .NET has DivRem, % and /.
    // Haskell              | F#
    //---------------------------------
    // rem                  | %
    // mod                  | ?
    // quot                 | /
    // div                  | ?
    // divMod               | ?
    // quotRem              | divRem

    //since the implementation uses divMod and mod, we need to reimplement these.
    //fortunately that's fairly easy
    let inline private divMod64 (n : int64) (d : int64) = 
      let q, r = Math.DivRem (n, d)
      Debug.Assert (n / d = q)
      Debug.Assert (n % d = r)
      if Math.Sign(r) = -Math.Sign(d) then 
        (q-1L,r+d) 
      else 
        (q,r)

    let inline private hMod64 n d = 
      let (_,r) = divMod64 n d
      r

    let q1,q2 = 53668     ,52774
    let a1,a2 = 40014     ,40692
    let r1,r2 = 12211     ,3791
    let m1,m2 = 2147483563,2147483399

    let init seed : StdGen = 
      let s       = if seed < 0L then -seed else seed
      let (q, s1) = divMod64  s (int64 (m1-1))  //2147483562L
      let s2      = hMod64    q (int64 (m2-1))  //2147483398L
      StdGen (int (s1+1L),int (s2+1L))

    let sample (StdGen (s1,s2)) : int =
      let z     = s1 - s2
      if z < 1 then z + m1 - 1 else z

    let samplef rng = 
      let v = sample rng
      float v / float (m1 - 1)

    let sampleRange min max rng = 
      let f = samplef rng
      min + int (round (f*float (max - (min : int))))

    let next (StdGen (s1,s2)) : StdGen =
      let k     = s1 / q1
      let s1'   = a1 * (s1 - k * q1) - k * r1
      let s1''  = if (s1' < 0) then s1 + m1 else s1'
      let k'    = s2 / q2
      let s2'   = a2 * (s2 - k' * q2) - k' * r2
      let s2''  = if s2' < 0 then s2' + m2 else s2'
      StdGen (s1'', s2'')
        
    let split ((StdGen (s1,s2)) as std) : struct (StdGen*StdGen) = 
      let s1'               = if s1 = (m1-1) then 1 else s1 + 1
      let s2'               = if s2 = 1 then (m2-1) else s2 - 1
      let (StdGen (n1, n2)) = next std
      let left              = StdGen (s1', n2)
      let right             = StdGen (n1, s2')
      struct (left,right)

    let newSeed ()    = DateTime.Now.Ticks |> init

  type GenContext =
    {
      Size  : int
    }

  let genContext = { Size = 1000 }

  type [<Struct>] GenResult<'T>  = GenResult of StdGen*'T
  type [<Struct>] Gen<'T>        = Gen of (GenContext -> StdGen -> GenResult<'T>)

  module Gen =
    module Details =
      let gfilterLimit  = 100

      let gresult rng v = GenResult (rng, v)

      module Loops =
        let rec gfilter f (t : OptimizedClosures.FSharpFunc<_, _, _>) gc rng i =
          if i > 0 then
            let (GenResult (nrng, nv))  = t.Invoke (gc, rng)
            if f nv then 
              gresult nrng nv
            else
              gfilter f t gc nrng (i - 1)
          else
            failwithf "gfilter failed to find a valid value after %d tries" gfilterLimit

        let rec gtimes (vs : ResizeArray<_>) lv (t : OptimizedClosures.FSharpFunc<_, _, _>) gc rng i =
          if i < lv then
            let (GenResult (nrng, nv)) = t.Invoke (gc, rng)
            vs.Add nv
            gtimes vs lv t gc nrng (i + 1)
          else
            rng

        let rec gselectf (gs : _ []) rem i =
          if i < gs.Length - 1 then
            let f, g = gs.[i]
            if rem >= f then
              gselectf gs (rem - f) (i + 1)
            else
              g
          else
            let _, g = gs.[gs.Length - 1]
            g

    open Details

    // Combinators

    // Monadic return
    let greturn v : Gen<'T> =
      Gen <| fun gc rng ->
        gresult rng v

    // Monadic bind
    let gbind (Gen t) (uf : 'T -> Gen<'U>) : Gen<'U> =
      let t = adapt t
      Gen <| fun gc rng ->
        let (GenResult (trng, tv))  = t.Invoke (gc, rng)
        let (Gen u)                 = uf tv
        let u                       = adapt u
        u.Invoke (gc, trng)

    // Applicative
    let gapply (Gen f) (Gen t) : Gen<'U> =
      let f = adapt f
      let t = adapt t
      Gen <| fun gc rng ->
        let (GenResult (frng, fv))  = f.Invoke (gc, rng)
        let (GenResult (trng, tv))  = t.Invoke (gc, frng)
        gresult trng (fv tv)

    // Functor
    let gmap m (Gen t) : Gen<'U> =
      let t = adapt t
      Gen <| fun gc rng ->
        let (GenResult (trng, tv))  = t.Invoke (gc, rng)
        gresult trng (m tv)

    // Combinators
    let gand (Gen f) (Gen s) : Gen<struct ('T*'U)> =
      let f = adapt f
      let s = adapt s
      Gen <| fun gc rng ->
        let (GenResult (frng, fv))  = f.Invoke (gc, rng)
        let (GenResult (srng, sv))  = s.Invoke (gc, frng)
        gresult srng struct (fv, sv)

    let gfilter f (Gen t) : Gen<'T> =
      let t = adapt t
      Gen <| fun gc rng ->
        Loops.gfilter f t gc rng gfilterLimit

    let gselectf (gs: (int*Gen<'T>) []) : Gen<'T> =
      let gs  = gs |> Array.filter (fun (f, _) -> f > 0)
      let sum = gs |> Array.sumBy fst
      if sum < 1 then failwith "Frequency components must add up to more than 0"
      Gen <| fun gc rng ->
        let nrng    = Random.next rng
        let rem     = Random.sampleRange 0 sum nrng
        let (Gen g) = Loops.gselectf gs rem 0
        g gc nrng

    let gselect (gs: Gen<'T> []) : Gen<'T> =
      gselectf (gs |> Array.map (fun v -> 1, v))

    let gtimes (Gen l) (Gen g) : Gen<'T []> =
      let l = adapt l
      let g = adapt g
      Gen <| fun gc rng ->
        let (GenResult (lrng, lv))  = l.Invoke (gc, rng)
        let vs    = ResizeArray (lv : int)
        let nrng  = Loops.gtimes vs lv g gc lrng 0
        gresult nrng (vs.ToArray ()) 

    // Misc
    let gdebug name (Gen t) : Gen<'T> =
      let t = adapt t
      Gen <| fun gc rng ->
        printfn "Gen - %s - BEFORE" name
        let (GenResult (_, v)) as gr = t.Invoke (gc, rng)
        printfn "Gen - %s - AFTER - %A" name v
        gr

    let grun (Gen g) (gc : GenContext) (rng : StdGen) : struct ('T*StdGen) =
      let g                     = adapt g
      let (GenResult (nrng, v)) = g.Invoke (gc, rng)
      struct (v, nrng)

    // Generators
    let gnormalizedFloat : Gen<float> =
      Gen <| fun gc rng ->
        let nrng    = Random.next rng
        let f       = Random.samplef nrng
        gresult nrng f

    let grange min max : Gen<int> =
      Gen <| fun gc rng ->
        let nrng    = Random.next rng
        let v       = Random.sampleRange min max nrng
        gresult nrng v

    let floatFrequency =
      [|
        010,  greturn 0.
        100,  gnormalizedFloat
        010,  greturn (-1. / Double.PositiveInfinity)  // Negative 0
        001,  greturn Double.PositiveInfinity
        001,  greturn Double.NegativeInfinity
        001,  greturn Double.MaxValue
        001,  greturn Double.MinValue
        001,  greturn Double.Epsilon
        001,  greturn Double.NaN
        010,  (gnormalizedFloat |> gmap (( * ) 1000000.))
      |]
    let gfloat : Gen<float> = gselectf floatFrequency

    let stringFrequency =
      let gstr length min max = gtimes (grange 1 length) (grange min max |> gmap char) |> gmap (fun cs -> String cs)
      [|
        001,  greturn ""
        010,  gstr 64 32 127
//        010,  gstr 1024 1 65535
        001,  greturn null
      |]
    let gstring : Gen<string> = gselectf stringFrequency

    type Builder() =
      member inline x.Bind       (t, uf) = gbind t uf
      member inline x.Return     v       = greturn v
      member inline x.ReturnFrom t       = t : Gen<'T>
      member inline x.Zero       ()      = greturn LanguagePrimitives.GenericZero<_>

  type Gen<'T> with
    static member (<&>) (l, r) = Gen.gand   l r
    static member (<*>) (l, r) = Gen.gapply l r
    static member (>>=) (l, r) = Gen.gbind  l r


  let gen = Gen.Builder ()

open FsGen

open FsGen

[<EntryPoint>]
let main argv = 
  try
    let g             = Gen.gstring
    let gs            = Gen.gtimes (Gen.greturn 100) g
    let struct (v, _) = Gen.grun gs genContext (Random.newSeed ())

    printfn "%A" v

    0
  with
  | e ->
    printfn "Exception: %s" e.Message
    999