 8 people like it.

The generic model for stateful computation (S -> S x R) provides a convenient mechanism of threading stateful computation results since the functor λR . S -> S x R is monadic. But what happens if we want to thread state itself? Well, the mapping λS. S -> S x R is not even functorial! But it turns out it can become so with a bit of trickery. This snippet demonstrates a way to lift, project or inject stateful computations into ambient state monads.

 ``` 1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: ``` ``````type State<'S,'A> = Stateful of ('S -> 'S * 'A) and StateBuilder() = let (!) (Stateful f) = f let unit x = Stateful(fun s -> s,x) let (>>=) f g = Stateful(fun s -> let s', a = !f s in !(g a) s') member __.Return x = unit x member __.Bind (f,g) = f >>= g member __.ReturnFrom f = f member __.Zero () = Stateful(fun s -> s,()) member __.Combine (f, g) = f >>= (fun () -> g) member __.Delay f = f () let state = new StateBuilder() module State = let run x (Stateful f) = f x |> snd let get () = Stateful(fun t -> t,t) let set t = Stateful(fun _ -> t,()) let swap f = Stateful(fun t -> f t,()) let extract f = Stateful(fun t -> t,f t) /// this is the basic state lifting combinator which given a pair /// of opposing arrows induces a natural lifting on states. /// not very practical in real life, but added for the sake of completeness. let lift (f : 'T -> 'S) (g : 'S -> 'T) (Stateful h) = Stateful (fun s -> let t, r = h (g s) in f t, r) : State<'S,'A> // the following two combinators are the ones we will be actually using /// for any decomposition 'T ~= 'S * 'S0, returns the natural embedding /// State<'S,'A> -> State<'T,'A> let inject (split : 'T -> 'S * 'S0 ) (assemble : 'S -> 'S0 -> 'T) (Stateful f) = Stateful( fun t -> let s, s0 = split t let s', a = f s (assemble s' s0), a ) : State<'T,'A> /// for any decomposition 'T ~= 'S * 'S0, returns the natural projection /// 'S0 -> State<'T,'A> -> State<'S,'A> let project (split : 'T -> 'S * 'S0) (assemble : 'S -> 'S0 -> 'T) s0 (Stateful f) = Stateful( fun s -> let t, r = f (assemble s s0) let s',_ = split t s', r ) : State<'S,'A> let init s0 f = project (fun s -> (),s) (fun _ s -> s) s0 f // // example : generic level-order tree traversal // type Tree<'U> = Leaf of 'U | Node of Tree<'U> * 'U * Tree<'U> // need an immutable queue implementation! type Queue<'T> = private { back : 'T list ; front : 'T list } with static member ofList xs = { back = [] ; front = xs } member self.Enqueue ts = match ts with [] -> self | t::ts' -> { self with back = t :: self.back }.Enqueue ts' member self.Dequeue () = match self with | {back = [] ; front = []} -> failwith "queue underflow!" | {back = ys ; front = []} -> { back = [] ; front = List.rev ys }.Dequeue() | {front = x::xs} -> { self with front = xs }, x member self.IsEmpty = match self with {back = [] ; front = []} -> true | _ -> false // we want to define a higher-order breadth-first tree traversal using our state monad. // the higher-order function threads its own internal state, namely a queue of all nodes // waiting to be traversed. naturally, we do not want to expose this internal state to the // input function, as this may mess up the traversal pattern. enter state lifting. let levelorder (foldF : 'U -> State<'S,unit>) (t : Tree<'U>) = // define state lifting rules // external state is 'S, internal state is 'S * Queue<'U> let injectLeft f = State.inject id (fun x y -> x,y) f let projectLeft q0 f = State.project id (fun x y -> x,y) q0 f let updateQueue (q : Queue<_>) = State.swap (fun (s,_) -> s,q) let rec traverse () = state { let! _,(q : Queue<_>) = State.get() if q.IsEmpty then return () else let q, t = q.Dequeue() match t with | Leaf u -> do! foldF u |> injectLeft do! updateQueue q | Node (l,u,r) -> do! foldF u |> injectLeft do! updateQueue <| q.Enqueue [l;r] do! traverse () } traverse () |> projectLeft (Queue<_>.ofList [t]) let test t = state { do! levelorder (fun v -> State.swap(fun vs -> vs @ [v])) t return! State.get() } |> State.init [] let tree = Node(Node(Node(Leaf 8,4,Leaf 9),2,Leaf 5),1,Node(Leaf 6,3,Node(Leaf 10,7,Leaf 11))) test tree |> State.run () ``````
union case State.Stateful: ('S -> 'S * 'A) -> State<'S,'A>
Multiple items
type StateBuilder =
new : unit -> StateBuilder
member Bind : f:State<'f,'g> * g:('g -> State<'f,'h>) -> State<'f,'h>
member Combine : f:State<'b,unit> * g:State<'b,'c> -> State<'b,'c>
member Delay : f:(unit -> 'a) -> 'a
member Return : x:'i -> State<'j,'i>
member ReturnFrom : f:'e -> 'e
member Zero : unit -> State<'d,unit>

Full name: Script.StateBuilder

--------------------
new : unit -> StateBuilder
val f : ('a -> 'a * 'b)
Multiple items
val unit : ('a -> State<'b,'a>)

--------------------
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val x : 'a
val s : 'b
val f : State<'a,'b>
val g : ('b -> State<'a,'c>)
val s : 'a
val s' : 'a
val a : 'b
member StateBuilder.Return : x:'i -> State<'j,'i>

Full name: Script.StateBuilder.Return
val x : 'i
val __ : StateBuilder
member StateBuilder.Bind : f:State<'f,'g> * g:('g -> State<'f,'h>) -> State<'f,'h>

Full name: Script.StateBuilder.Bind
val f : State<'f,'g>
val g : ('g -> State<'f,'h>)
member StateBuilder.ReturnFrom : f:'e -> 'e

Full name: Script.StateBuilder.ReturnFrom
val f : 'e
member StateBuilder.Zero : unit -> State<'d,unit>

Full name: Script.StateBuilder.Zero
val s : 'd
member StateBuilder.Combine : f:State<'b,unit> * g:State<'b,'c> -> State<'b,'c>

Full name: Script.StateBuilder.Combine
val f : State<'b,unit>
val g : State<'b,'c>
member StateBuilder.Delay : f:(unit -> 'a) -> 'a

Full name: Script.StateBuilder.Delay
val f : (unit -> 'a)
val state : StateBuilder

Full name: Script.state
type State<'S,'A> = | Stateful of ('S -> 'S * 'A)

Full name: Script.State<_,_>
val run : x:'a -> State<'a,'b> -> 'b

Full name: Script.State.run
val snd : tuple:('T1 * 'T2) -> 'T2

Full name: Microsoft.FSharp.Core.Operators.snd
val get : unit -> State<'a,'a>

Full name: Script.State.get
val t : 'a
val set : t:'a -> State<'a,unit>

Full name: Script.State.set
val swap : f:('a -> 'a) -> State<'a,unit>

Full name: Script.State.swap
val f : ('a -> 'a)
val extract : f:('a -> 'b) -> State<'a,'b>

Full name: Script.State.extract
val f : ('a -> 'b)
val lift : f:('T -> 'S) -> g:('S -> 'T) -> State<'T,'A> -> State<'S,'A>

Full name: Script.State.lift

this is the basic state lifting combinator which given a pair
of opposing arrows induces a natural lifting on states.
not very practical in real life, but added for the sake of completeness.
val f : ('T -> 'S)
val g : ('S -> 'T)
val h : ('T -> 'T * 'A)
val s : 'S
val t : 'T
val r : 'A
val inject : split:('T -> 'S * 'S0) -> assemble:('S -> 'S0 -> 'T) -> State<'S,'A> -> State<'T,'A>

Full name: Script.State.inject

for any decomposition 'T ~= 'S * 'S0, returns the natural embedding
State<'S,'A> -> State<'T,'A>
val split : ('T -> 'S * 'S0)
val assemble : ('S -> 'S0 -> 'T)
val f : ('S -> 'S * 'A)
val s0 : 'S0
val s' : 'S
val a : 'A
val project : split:('T -> 'S * 'S0) -> assemble:('S -> 'S0 -> 'T) -> s0:'S0 -> State<'T,'A> -> State<'S,'A>

Full name: Script.State.project

for any decomposition 'T ~= 'S * 'S0, returns the natural projection
'S0 -> State<'T,'A> -> State<'S,'A>
val f : ('T -> 'T * 'A)
val init : s0:'a -> f:State<'a,'b> -> State<unit,'b>

Full name: Script.State.init
val s0 : 'a
type Tree<'U> =
| Leaf of 'U
| Node of Tree<'U> * 'U * Tree<'U>

Full name: Script.Tree<_>
union case Tree.Leaf: 'U -> Tree<'U>
union case Tree.Node: Tree<'U> * 'U * Tree<'U> -> Tree<'U>
type Queue<'T> =
private {back: 'T list;
front: 'T list;}
member Dequeue : unit -> Queue<'T> * 'T
member Enqueue : ts:'T list -> Queue<'T>
member IsEmpty : bool
static member ofList : xs:'a list -> Queue<'a>

Full name: Script.Queue<_>
Queue.back: 'T list
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Queue.front: 'T list
static member Queue.ofList : xs:'a list -> Queue<'a>

Full name: Script.Queue`1.ofList
val xs : 'a list
val self : Queue<'T>
member Queue.Enqueue : ts:'T list -> Queue<'T>

Full name: Script.Queue`1.Enqueue
val ts : 'T list
val ts' : 'T list
member Queue.Dequeue : unit -> Queue<'T> * 'T

Full name: Script.Queue`1.Dequeue
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val ys : 'T list
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
| ( [] )
| ( :: ) of Head: 'T * Tail: 'T list
interface IEnumerable
interface IEnumerable<'T>
member IsEmpty : bool
member Item : index:int -> 'T with get
member Length : int
member Tail : 'T list
static member Cons : head:'T * tail:'T list -> 'T list
static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
val x : 'T
val xs : 'T list
member Queue.IsEmpty : bool

Full name: Script.Queue`1.IsEmpty
val levelorder : foldF:('U -> State<'S,unit>) -> t:Tree<'U> -> State<'S,unit>

Full name: Script.levelorder
val foldF : ('U -> State<'S,unit>)
Multiple items
module State

from Script

--------------------
type State<'S,'A> = | Stateful of ('S -> 'S * 'A)

Full name: Script.State<_,_>
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val t : Tree<'U>
val injectLeft : (State<'a,'b> -> State<('a * 'c),'b>)
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val y : 'c
val projectLeft : ('a -> State<('b * 'a),'c> -> State<'b,'c>)
val q0 : 'a
val f : State<('b * 'a),'c>
val x : 'b
val y : 'a
val updateQueue : (Queue<'a> -> State<('b * Queue<'a>),unit>)
val q : Queue<'a>
val traverse : (unit -> State<('S * Queue<Tree<'U>>),unit>)
val q : Queue<Tree<'U>>
property Queue.IsEmpty: bool
member Queue.Dequeue : unit -> Queue<'T> * 'T
val u : 'U
val l : Tree<'U>
val r : Tree<'U>
member Queue.Enqueue : ts:'T list -> Queue<'T>
val test : t:Tree<'a> -> State<unit,'a list>

Full name: Script.test
val t : Tree<'a>
val v : 'a
val vs : 'a list
val tree : Tree<int>

Full name: Script.tree