FsControl ZipIndex

gistfile1.fs

#r "../packages/FsControl.1.0.8/lib/net40/FsControl.Core.dll"

open FsControl.Core.TypeMethods
open FsControl.Core.Types
 
let inline result (x:'a): 'Functor'a = Inline.instance Applicative.Pure x
let inline (>>=) (x:'Monad'a) (f:'a->'Monad'b) :'Monad'b = Inline.instance (Monad.Bind, x) f
let inline traverse (f:'a->'Applicative'b) (t:'Traversable'a) :'Applicative'Traversable'b = Inline.instance (Traversable.Traverse , t) f
type MonadBuilder() =
    member inline b.Return(x)    = result x
    member inline b.Bind(p,rest) = p >>= rest
    member        b.Let (p,rest) = rest p
    member    b.ReturnFrom(expr) = expr
 
let monad     = new MonadBuilder()


type State<'s,'a, 'r> = State of ('s -> ('s -> 'a -> 'r) -> 'r)
let runS (State s) = s
 
type State with
    static member instance (_:Applicative.Pure, _:State<'s,'a, 'r> ) = fun a -> 
        State(fun s k -> k s a)  :State<'s,'a, 'r>
    static member instance (_:Monad.Bind  ,   State m, _:State<'s,'b, 'r>) = fun k -> 
        State(fun s k' -> 
            m s (fun s' a -> 
                          runS (k a) s' (fun s'' b -> k' s'' b)  )) : State<'s,'b, 'r>
    static member instance (_:Applicative.Apply, f:State<'s,'a -> 'b, 'r>, x:State<'s,'a,'r>, _:State<'s,'b,'r>) = fun () -> 
        State(fun s k' -> 
            runS x s (fun s' a -> 
                          runS f s' (fun s'' f' -> k' s'' (f' a))  )) : State<'s,'b, 'r>
  
let inline get ()  = State(fun s k -> k s s)
let inline put x = State(fun s k -> k x ())
 
 
 
// TEST
 
let f a = monad {
        let! n = get ()
        do! put (n + 1)
        return n, a
    }

//let zipIndex (xs: 'a list) : (int * 'a) list =
//    let rec zipIndex' f (xs: 'a list) =
//        match xs with
//        | x::xs ->
//            monad {
//                let! x' = f x
//                let! xs' = zipIndex' f xs
//                return x' :: xs'
//            }
//        | [] -> monad { return [] }
//    runS (zipIndex' f xs) 0 (fun s a -> a)

let zipIndex (xs: 'a list) : (int * 'a) list =
    runS (traverse f xs) 0 (fun s a -> a)

let zipIndex' (xs: seq<'a>) : seq<int * 'a> =
    runS (traverse f xs) 0 (fun s a -> a)

// ok
zipIndex [1..1000000] 

// stackoverflow
// Traversable.fs line 17 let cons x y = Seq.append (Seq.singleton x) y 
// use instead LazyList.OfSeq and LazyList.cons
zipIndex' [1..1000000]