functional-programming - Monad 组合(续·状态)

Question

我正在研究 monad 组合。虽然我已经了解如何编写 Async 和 Result 执行 here我正在努力编写 Continuation Monad 和 State Monad。

从基本的 State Monad 实现和用于测试目的的State-based-Stack 开始:

type State<'State,'Value> = State of ('State -> 'Value * 'State)

module State =
    let runS (State f) state = f state

    let returnS x =
        let run state =
            x, state
        State run

    let bindS f xS =
        let run state =
            let x, newState = runS xS state
            runS (f x) newState
        State run

    let getS =
        let run state = state, state
        State run

    let putS newState =
        let run _ = (), newState
        State run

    type StateBuilder()=
        member __.Return(x) = returnS x
        member __.Bind(xS,f) = bindS f xS

    let state = new StateBuilder()

module Stack =
    open State

    type Stack<'a> = Stack of 'a list

    let popStack (Stack contents) = 
        match contents with
        | [] -> failwith "Stack underflow"
        | head::tail ->     
            head, (Stack tail)

    let pushStack newTop (Stack contents) = 
        Stack (newTop::contents)

    let emptyStack = Stack []

    let getValue stackM = 
        runS stackM emptyStack |> fst

    let pop() = state {
        let! stack = getS
        let top, remainingStack = popStack stack
        do! putS remainingStack 
        return top }

    let push newTop = state {
        let! stack = getS
        let newStack = pushStack newTop stack
        do! putS newStack 
        return () }

然后还有一个 Continuation Monad 的基本实现:

type Cont<'T,'r> = (('T -> 'r) -> 'r)

module Continuation =
    let returnCont x = (fun k -> k x)
    let bindCont f m = (fun k -> m (fun a -> f a k))
    let delayCont f = (fun k -> f () k)
    let runCont (c:Cont<_,_>) cont = c cont
    let callcc (f: ('T -> Cont<'b,'r>) -> Cont<'T,'r>) : Cont<'T,'r> =
        fun cont -> runCont (f (fun a -> (fun _ -> cont a))) cont

    type ContinuationBuilder() =
        member __.Return(x) = returnCont x
        member __.ReturnFrom(x) = x
        member __.Bind(m,f) = bindCont f m
        member __.Delay(f) = delayCont f
        member this.Zero () = this.Return ()

    let cont = new ContinuationBuilder()

我试着这样写:

module StateK =
    open Continuation

    let runSK (State f) state = cont { return f state }
    let returnSK x = x |> State.returnS |> returnCont

    let bindSK f xSK = cont {
        let! xS = xSK
        return (State.bindS f xS) }

    let getSK k =
        let run state = state, state
        State run |> k

    let putSK newState = cont {
        let run _ = (), newState
        return State run }

    type StateContinuationBuilder() =
        member __.Return(x) = returnSK x
        member __.ReturnFrom(x) = x
        member __.Bind(m,f) = bindSK f m
        member this.Zero () = this.Return () 

    let stateK = new StateContinuationBuilder()

虽然这编译并且看起来正确(就机械跟随步骤组合而言)我无法实现 StateK-based-Stack。到目前为止我有这个，但这是完全错误的:

module StackCont =
    open StateK

    type Stack<'a> = Stack of 'a list

    let popStack (Stack contents) =  stateK {
        match contents with
        | [] -> return failwith "Stack underflow"
        | head::tail ->     
            return head, (Stack tail) }

    let pushStack newTop (Stack contents) = stateK {
        return Stack (newTop::contents) }

    let emptyStack = Stack []

    let getValue stackM = stateK {
        return runSK stackM emptyStack |> fst }

    let pop() = stateK {
        let! stack = getSK
        let! top, remainingStack = popStack stack
        do! putSK remainingStack 
        return top }

    let push newTop = stateK {
        let! stack = getSK
        let! newStack = pushStack newTop stack
        do! putSK newStack 
        return () }

一些有助于理解为什么以及如何受到欢迎。如果有一些您可以指向的阅读 Material ，它也会起作用。

********* 在 AMieres 之后编辑评论***************

新的 bindSK 实现试图保持签名正确。

type StateK<'State,'Value,'r> = Cont<State<'State,'Value>,'r>

module StateK =

    let returnSK x :  StateK<'s,'a,'r> = x |> State.returnS |> Continuation.returnCont
    let bindSK (f : 'a ->  StateK<'s,'b,'r>) 
        (m : StateK<'s,'a,'r>) :  StateK<'s,'b,'r> =
        (fun cont ->
            m (fun (State xS) ->
                let run state =
                    let x, newState = xS state
                    (f x) (fun (State k) -> k newState)
                cont (State run)))

尽管如此，'r 类型已被限制为 'b * 's我已经尝试移除约束，但我还没有能够做到这一点

Answer 1

我也没能解决。

我只能给你一个提示，可能会帮助你更好地理解它。将泛型类型替换为常规类型，例如:

let bindSK (f : 'a ->  StateK<'s,'b,'r>) 
    (m : StateK<'s,'a,'r>) :  StateK<'s,'b,'r> =
    (fun cont ->
        m (fun (State xS) ->
            let run state =
                let x, newState = xS state
                (f x) (fun (State k) -> k newState)
            cont (State run)))

替换's与 string , 'a与 int , 'b与 char和 'r与 float

let bindSK (f : int ->  StateK<string,char,float>) 
    (m : StateK<string,int,float>) :  StateK<string,char,float> =
    (fun cont ->
        m (fun (State xS) ->
            let run state =
                let x, newState = xS state
                (f x) (fun (State k) -> k newState)
            cont (State run)))

这样比较容易看

• k是string -> char * string
• 所以k newState是char * string
• (f x)是(State<string,char> -> float) -> float
• 和m是(State<string,int> -> float) -> float

所以他们不兼容。