单子组成（续·状态）答案

【问题标题】：Monad composition (Cont · State)单子组成（续·状态）
【发布时间】：2019-06-06 18:29:29
【问题描述】：

我正在研究单子组合。虽然我已经知道如何编写 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 () }

一些帮助理解为什么以及如何是非常受欢迎的。如果有一些你可以指出的阅读材料，它也可以工作。

********* 在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 我试图删除约束，但我还没有能够做到这一点

【问题讨论】：

我可以告诉你bindSK 是不正确的。 f 的类型应该是：'a -> Cont<State<'s,'b>,'r>，但实际上是：'a -> State<'s,'b>
感谢@AMieres，我再次执行了我的实现，现在看来我有一个不需要的约束。 'r 已被限制为 'b*'s
你确定有可能吗？在我看来，这是自相矛盾的。由于最后一个延续是唯一能够运行状态单子的延续，并且由于状态值决定了延续。怎样才能提前确定合适的续作？
我认为是，状态应该在每个延续中运行。我将阅读有关该主题的更多信息并再试一次
@AMieres 我提出了一个可行的实现，请参阅下面的答案。你怎么看？

标签： functional-programming f# monads continuations state-monad

【解决方案1】：

我又试了一次，然后解决了这个问题，据我所知，它有效并且实际上是Cont · State：

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

let returnCont x : StateK<'s,'a> = (fun k -> k x)

let returnSK x =
    let run state =
        x, state
    State run |> returnCont

let runSK (f : ((State<'s,'b> -> 'b * 's) -> 'b * 's)) state = f (fun (State xS) ->  xS state)

let bindSK (f : 'a -> StateK<'s,'b>) (xS :StateK<'s,'a>) : StateK<'s,'b> =
    let run state =
        let x, newState = runSK xS state
        runSK (f x) newState
    returnCont (State run) // is this right? as far as I cant tell the previous (next?) continuation is encapsulated on run so this is only so the return type conforms with what is expected of a bind

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

let putSK newState =
    let run _ = (), newState
    State run |> returnCont

type StateKBuilder()=
    member __.Return(x) = returnSK x
    member __.Bind(xS,f) = bindSK f xS

let stateK = new StateKBuilder()

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 getValueS stackM = 
    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 () }


let helloWorldSK = (fun k -> stateK {
    do! push "world"
    do! push "hello"
    let! top1 = pop()
    let! top2 = pop()
    let combined = top1 + " " + top2 
    return combined
})

let helloWorld =  getValueS (helloWorldSK id)
printfn "%s" helloWorld

【讨论】：

【解决方案2】：

我阅读了更多内容，发现“ContinuousState”的正确类型是's -> Cont<'a * 's, 'r>

所以我用这个签名重新实现了StateK monad，一切都很自然。

这里是代码（为了完整起见，我添加了 mapSK 和 applySK）：

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

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)

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()

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

module StateK =
    let returnSK x =
        let run state = cont {
            return x, state
        }
        StateK run

    let runSK (StateK fSK : StateK<'s,'a,'r>) (state : 's) : Cont<'a * 's, _> = cont {
        return! fSK state }

    let mapSK (f : 'a -> 'b) (m : StateK<'s,'a,'r>) : StateK<'s,'b,'r> =
            let run state = cont {
                let! x, newState = runSK m state
                return f x, newState  }
            StateK run

    let bindSK (f : 'a -> StateK<'s,'b,'r>) (xSK : StateK<'s,'a,'r>) : (StateK<'s,'b,'r>) =
        let run state = cont {
            let! x, newState = runSK xSK state
            return! runSK (f x) newState }
        StateK run

    let applySK (fS : StateK<'s, 'a -> 'b, 'r>) (xSK : StateK<'s,'a,'r>) : StateK<'s,'b,'r> =
        let run state = cont {
            let! f, s1 = runSK fS state
            let! x, s2 = runSK xSK s1
            return f x, s2 }
        StateK run        

    let getSK =
        let run state = cont { return state, state }
        StateK run

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

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

    let stateK = new StateKBuilder()

module StackCont =
    open StateK

    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 getValueSK stackM = cont {
        let! f = runSK stackM emptyStack 
        return f |> 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 () }

open StateK
open StackCont

let helloWorldSK = (fun () -> stateK {
    do! push "world"
    do! push "hello"
    let! top1 = pop()
    let! top2 = pop()
    let combined = top1 + " " + top2 
    return combined
})

let helloWorld = getValueSK (helloWorldSK ()) id
printfn "%s" helloWorld

【讨论】：

bind 函数具有以下签名：f : 'a -> Cont<State<'b,'c>,State<'b,'c>> -> xSK: Cont<State<'b,'a>,'d> -> Cont<State<'b,'c>,'d> 这是因为您正在使用 id 函数运行延续，这基本上意味着您提供了延续并且它什么都不做。相当于解开 continuation monad，取出 state monad，绑定它，再用一个 continuation 包裹起来。这让您质疑为什么首先将其包装在延续单子中？
哦，我明白了......好吧，我想可能更难
是的！我想你是对的。它不完全是 State 和 Cont monads 的组合。取而代之的是使用 Cont monad 的状态实现。这绝对是正确的。
接下来，我建议研究 Eff monad。它是一个 monad，可让您在一个状态、Reader、Writer、Result 等中使用所有 monad。无需组合其他 monad，这个可以全部完成！\。
好的，谢谢，下一个 Eff Monad，也许它会解决我真正的问题，我正在尝试通过协程线程化一个状态......但也许我走错了路，只是有一个将可变状态放入 Coroutine 类将是唯一的解决方案。

【解决方案3】：

我也无法解决。

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

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

所以它们不兼容。

【讨论】：