I'm struggling with mapping non trivial function to be tail recursive.
take even the simple rosetree
type Tree<'a> =
| Leaf of 'a
| Branch of List<Tree<'a>>
with map
let rec map : ('a -> 'b) -> Tree<'a> -> Tree<'b> =
fun f ->
function
| Leaf a ->
f a
|> Leaf
| Branch xs ->
xs
|> List.map (map f)
|> Branch
(let alone bind)
making this tail recursive seems quite painful, I've looked at examples in things like FSharpx, but they arent tail recursive.
I have found this
https://www.gresearch.co.uk/article/advanced-recursion-techniques-in-f/
but the leap from the final example based on continuities seems quite bespoke to their example (of max), I can't seem to get my head around it.
is there an example implementation of this pretty canonical example somewhere?
so the simple bit would be something like this
let map2 : ('a -> 'b) -> Tree<'a> -> Tree<'b> =
fun f ta ->
let rec innerMap : Tree<'a> -> (Tree<'b> -> Tree<'b>) -> Tree<'b> =
fun ta cont ->
match ta with
| Leaf a ->
f a |> Leaf |> cont
innerMap ta id
but I'm missing the hard bit with branch
If you use the suggestion from your link the implementation is as follows:
let rec mapB : ('a -> 'b) -> Tree<'a> -> (Tree<'b>-> Tree<'b>) -> Tree<'b> =
fun f ta k ->
match ta with
| Leaf a -> k (Leaf (f a))
| Branch ys ->
let continuations = ys |> List.map (mapB f)
let final (list:List<Tree<'b>>) = k (Branch list)
Continuation.sequence continuations final
As you've noticed the case for the leaf is straightforward: apply F, wrap it back into a Leaf and apply the continuation.
As for the Branch, we generate a number of partial functions that map the children in the branch. We leverage Continuation.sequence which executes these partial functions for us. We then take the result, wrap it in a Branch and apply the (final) continuation.
A basic test:
let t = Branch ([Leaf 3; Leaf 4;Leaf 5;Branch([Leaf 6])])
let t4 = mapB (fun x->x+1) t id
printfn "%A" t4
yields
Branch [Leaf 4; Leaf 5; Leaf 6; Branch [Leaf 7]]
On a side note what are you trying to do? run Montecarlo simulations with thousands of scenarios? I have yet to run into a stack overflow error even with your original implementation.
I like using ROP when I have to deal with IO/Parsing strings/...
However let's say that I have a function taking 2 parameters. How can you do clean/readable partial application when your 2 parameters are already a Result<'a,'b> (not necessary same 'a, 'b)?
For now, what I do is that I use tuple to pass parameters and use the function below to get a Result of a tuple so I can then bind my function with this "tuple-parameter".
/// Transform a tuple of Result in a Result of tuple
let tupleAllResult x =
match (fst x, snd x) with
| Result.Ok a, Result.Ok b -> (a,b) |> Result.Ok
| Result.Ok a, Result.Error b -> b |> Result.Error
| Result.Error a, _ -> a |> Result.Error
let f (a: 'T, b: 'U) = // something
(A, B) |> tupleAllResult
|> (Result.bind f)
Any good idea?
Here what I wrote, which works but might not be the most elegant
let resultFunc (f: Result<('a -> Result<'b, 'c>), 'd>) a =
match f with
| Result.Ok g -> (g a) |> Result.Ok |> Result.flatten
| Result.Error e -> e |> Result.Error |> Result.flatten
I am not seeing partial application in your example, a concept related to currying and argument passing -- that's why I am assuming that you are after the monadic apply, in that you want to transform a function wrapped as a Result value into a function that takes a Result and returns another Result.
let (.>>.) aR bR = // This is "tupleAllResult" under a different name
match aR, bR with
| Ok a, Ok b -> Ok(a, b)
| Error e, _ | _, Error e -> Error e
// val ( .>>. ) : aR:Result<'a,'b> -> bR:Result<'c,'b> -> Result<('a * 'c),'b>
let (<*>) fR xR = // This is another name for "apply"
(fR .>>. xR) |> Result.map (fun (f, x) -> f x)
// val ( <*> ) : fR:Result<('a -> 'b),'c> -> xR:Result<'a,'c> -> Result<'b,'c>
The difference to what you have in your question is map instead of bind in the last line.
Now you can start to lift functions into the Result world:
let lift2 f xR yR =
Ok f <*> xR <*> yR
// val lift2 :
// f:('a -> 'b -> 'c) -> xR:Result<'a,'d> -> yR:Result<'b,'d> -> Result<'c,'d>
let res : Result<_,unit> = lift2 (+) (Ok 1) (Ok 2)
// val res : Result<int,unit> = Ok 3
let rec merge = function
| ([], ys) -> ys
| (xs, []) -> xs
| (x::xs, y::ys) -> if x < y then x :: merge (xs, y::ys)
else y :: merge (x::xs, ys)
let rec split = function
| [] -> ([], [])
| [a] -> ([a], [])
| a::b::cs -> let (M,N) = split cs
(a::M, b::N)
let rec mergesort = function
| [] -> []
| L -> let (M, N) = split L
merge (mergesort M, mergesort N)
mergesort [5;3;2;1] // Will throw an error.
I took this code from here StackOverflow Question but when I run the mergesort with a list I get an error:
stdin(192,1): error FS0030: Value restriction. The value 'it' has been inferred to have generic type
val it : '_a list when '_a : comparison
How would I fix this problem? What is the problem? The more information, the better (so I can learn :) )
Your mergesort function is missing a case causing the signature to be inferred by the compiler to be 'a list -> 'b list instead of 'a list -> 'a list which it should be. The reason it should be 'a list -> 'a list is that you're not looking to changing the type of the list in mergesort.
Try changing your mergesort function to this, that should fix the problem:
let rec mergesort = function
| [] -> []
| [a] -> [a]
| L -> let (M, N) = split L
merge (mergesort M, mergesort N)
Another problem with your code however is that neither merge nor split is tail recursive and you will therefore get stack overflow exceptions on large lists (try to call the corrected mergesort like this mergesort [for i in 1000000..-1..1 -> i]).
You can make your split and merge functions tail recursive by using the accumulator pattern
let split list =
let rec aux l acc1 acc2 =
match l with
| [] -> (acc1,acc2)
| [x] -> (x::acc1,acc2)
| x::y::tail ->
aux tail (x::acc1) (y::acc2)
aux list [] []
let merge l1 l2 =
let rec aux l1 l2 result =
match l1, l2 with
| [], [] -> result
| [], h :: t | h :: t, [] -> aux [] t (h :: result)
| h1 :: t1, h2 :: t2 ->
if h1 < h2 then aux t1 l2 (h1 :: result)
else aux l1 t2 (h2 :: result)
List.rev (aux l1 l2 [])
You can read more about the accumulator pattern here; the examples are in lisp but it's a general pattern that works in any language that provides tail call optimization.
I have this monad called Desync -
[<AutoOpen>]
module DesyncModule =
/// The Desync monad. Allows the user to define in a sequential style an operation that spans
/// across a bounded number of events. Span is bounded because I've yet to figure out how to
/// make Desync implementation tail-recursive (see note about unbounded recursion in bind). And
/// frankly, I'm not sure if there is a tail-recursive implementation of it...
type [<NoComparison; NoEquality>] Desync<'e, 's, 'a> =
Desync of ('s -> 's * Either<'e -> Desync<'e, 's, 'a>, 'a>)
/// Monadic return for the Desync monad.
let internal returnM (a : 'a) : Desync<'e, 's, 'a> =
Desync (fun s -> (s, Right a))
/// Monadic bind for the Desync monad.
let rec internal bind (m : Desync<'e, 's, 'a>) (cont : 'a -> Desync<'e, 's, 'b>) : Desync<'e, 's, 'b> =
Desync (fun s ->
match (match m with Desync f -> f s) with
// ^--- NOTE: unbounded recursion here
| (s', Left m') -> (s', Left (fun e -> bind (m' e) cont))
| (s', Right v) -> match cont v with Desync f -> f s')
/// Builds the Desync monad.
type DesyncBuilder () =
member this.Return op = returnM op
member this.Bind (m, cont) = bind m cont
/// The Desync builder.
let desync = DesyncBuilder ()
It allows the implementation of game logic that executes across several game ticks to written in a seemingly sequential style using computation expressions.
Unfortunately, when used for tasks that last for an unbounded number of game ticks, it crashes with StackOverflowException. And even when it's not crashing, it's ending up with unwieldy stack traces like this -
InfinityRpg.exe!InfinityRpg.GameplayDispatcherModule.desync#525-20.Invoke(Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> _arg10) Line 530 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>>.Invoke(Nu.SimulationModule.World s) Line 24 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21 F#
Prime.exe!Prime.DesyncModule.bind#20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21 F#
Prime.exe!Prime.Desync.step<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit>(Prime.DesyncModule.Desync<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit> m, Nu.SimulationModule.World s) Line 71 F#
Prime.exe!Prime.Desync.advanceDesync<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit>(Microsoft.FSharp.Core.FSharpFunc<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Prime.DesyncModule.Desync<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit>> m, Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> e, Nu.SimulationModule.World s) Line 75 F#
Nu.exe!Nu.Desync.advance#98<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>.Invoke(Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> event, Nu.SimulationModule.World world) Line 100 F#
Nu.exe!Nu.Desync.subscription#104-16<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>.Invoke(Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> event, Nu.SimulationModule.World world) Line 105 F#
Nu.exe!Nu.World.boxableSubscription#165<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>.Invoke(object event, Nu.SimulationModule.World world) Line 166 F#
I am hoping to solve the problem by making the Left case of the bind function tail-recursive. However, I'm not sure of two things -
1) if it can be done at all, and
2) how it would actually be done.
If it's impossible to make bind tail-recursive here, is there some way to restructure my monad to allow it to become tail-recursive?
EDIT 3 (subsumes previous edits): Here is additional code that implements the desync combinators I will use to demonstrate the stack overflow -
module Desync =
/// Get the state.
let get : Desync<'e, 's, 's> =
Desync (fun s -> (s, Right s))
/// Set the state.
let set s : Desync<'e, 's, unit> =
Desync (fun _ -> (s, Right ()))
/// Loop in a desynchronous context while 'pred' evaluate to true.
let rec loop (i : 'i) (next : 'i -> 'i) (pred : 'i -> 's -> bool) (m : 'i -> Desync<'e, 's, unit>) =
desync {
let! s = get
do! if pred i s then
desync {
do! m i
let i = next i
do! loop i next pred m }
else returnM () }
/// Loop in a desynchronous context while 'pred' evaluates to true.
let during (pred : 's -> bool) (m : Desync<'e, 's, unit>) =
loop () id (fun _ -> pred) (fun _ -> m)
/// Step once into a desync.
let step (m : Desync<'e, 's, 'a>) (s : 's) : 's * Either<'e -> Desync<'e, 's, 'a>, 'a> =
match m with Desync f -> f s
/// Run a desync to its end, providing e for all its steps.
let rec runDesync (m : Desync<'e, 's, 'a>) (e : 'e) (s : 's) : ('s * 'a) =
match step m s with
| (s', Left m') -> runDesync (m' e) e s'
| (s', Right v) -> (s', v)
Here is the Either implementation -
[<AutoOpen>]
module EitherModule =
/// Haskell-style Either type.
type Either<'l, 'r> =
| Right of 'r
| Left of 'l
And finally, here's simple a line of code that will yield a stack overflow -
open Desync
ignore <| runDesync (desync { do! during (fun _ -> true) (returnM ()) }) () ()
It seems to me your monad is a State with error handling.
It's basically ErrorT< State<'s,Either<'e,'a>>> but the error branch binds again which is not very clear to me why.
Anyway I was able to reproduce your Stack Overflow with a basic State monad:
type State<'S,'A> = State of ('S->('A * 'S))
module State =
let run (State x) = x :'s->_
let get() = State (fun s -> (s , s)) :State<'s,_>
let put x = State (fun _ -> ((), x)) :State<'s,_>
let result a = State(fun s -> (a, s))
let bind (State m) k = State(fun s ->
let (a, s') = m s
let (State u) = (k a)
u s') :State<'s,'b>
type StateBuilder() =
member this.Return op = result op
member this.Bind (m, cont) = bind m cont
let state = StateBuilder()
let rec loop (i: 'i) (next: 'i -> 'i) (pred: 'i -> 's -> bool) (m: 'i -> State<'s, unit>) =
state {
let! s = get()
do! if pred i s then
state {
do! m i
let i = next i
do! loop i next pred m }
else result () }
let during (pred : 's -> bool) (m : State<'s, unit>) =
loop () id (fun _ -> pred) (fun _ -> m)
// test
open State
ignore <| run (state { do! during (fun c -> true) (result ()) }) () // boom
As stated in the comments one way to solve this is to use a StateT<'s,Cont<'r,'a>>.
Here's an example of the solution. At the end there is a test with the zipIndex function which blows the stack as well when defined with a normal State monad.
Note you don't need to use the Monad Transformers from FsControl (now FSharpPlus), I use them because it's easier for me since I write less code but you can always create your transformed monad by hand.
Is there already a way to do something like a chooseTill or a foldTill, where it will process until a None option is received? Really, any of the higher order functions with a "till" option. Granted, it makes no sense for stuff like map, but I find I need this kind of thing pretty often and I wanted to make sure I wasn't reinventing the wheel.
In general, it'd be pretty easy to write something like this, but I'm curious if there is already a way to do this, or if this exists in some known library?
let chooseTill predicate (sequence:seq<'a>) =
seq {
let finished = ref false
for elem in sequence do
if not !finished then
match predicate elem with
| Some(x) -> yield x
| None -> finished := true
}
let foldTill predicate seed list =
let rec foldTill' acc = function
| [] -> acc
| (h::t) -> match predicate acc h with
| Some(x) -> foldTill' x t
| None -> acc
foldTill' seed list
let (++) a b = a.ToString() + b.ToString()
let abcdef = foldTill (fun acc v ->
if Char.IsWhiteSpace v then None
else Some(acc ++ v)) "" ("abcdef ghi" |> Seq.toList)
// result is "abcdef"
I think you can get that easily by combining Seq.scan and Seq.takeWhile:
open System
"abcdef ghi"
|> Seq.scan (fun (_, state) c -> c, (string c) + state) ('x', "")
|> Seq.takeWhile (fst >> Char.IsWhiteSpace >> not)
|> Seq.last |> snd
The idea is that Seq.scan is doing something like Seq.fold, but instead of waiting for the final result, it yields the intermediate states as it goes. You can then keep taking the intermediate states until you reach the end. In the above example, the state is the current character and the concatenated string (so that we can check if the character was whitespace).
A more general version based on a function that returns option could look like this:
let foldWhile f initial input =
// Generate sequence of all intermediate states
input |> Seq.scan (fun stateOpt inp ->
// If the current state is not 'None', then calculate a new one
// if 'f' returns 'None' then the overall result will be 'None'
stateOpt |> Option.bind (fun state -> f state inp)) (Some initial)
// Take only 'Some' states and get the last one
|> Seq.takeWhile Option.isSome
|> Seq.last |> Option.get