How can I correctly return produced sequences in an F# recursive algorithm - functional-programming

As a tutoring exercise I implemented the Knights Tour algorithm in CS and worked fine, after trying to port it to F# I cannot go past the part where I aggregate the resulting sequences of the Knight's path to return to the caller.
The code is this:
let offsets = [|(-2,-1);(-2,1);(-1,-2);(-1,2);(1,-2);(1,2);(2,-1);(2,1)|];
let squareToPair sqr =
(sqr % 8, sqr / 8)
let pairToSquare (col, row) =
row * 8 + col
// Memoizing function taken from Don Syme (http://blogs.msdn.com/b/dsyme/archive/2007/05/31/a-sample-of-the-memoization-pattern-in-f.aspx)
let memoize f =
let cache = ref Map.empty
fun x ->
match (!cache).TryFind(x) with
| Some res -> res
| None ->
let res = f x
cache := (!cache).Add(x,res)
res
let getNextMoves square =
let (col, row) = squareToPair square
offsets
|> Seq.map (fun (colOff, rowOff) -> (col + colOff, row + rowOff))
|> Seq.filter (fun (c, r) -> c >= 0 && c < 8 && r >= 0 && r < 8) // make sure we don't include squares out of the board
|> Seq.map (fun (c, r) -> pairToSquare (c, r))
let getNextMovesMemoized = memoize getNextMoves
let squareToBoard square =
1L <<< square
let squareToBoardMemoized = memoize squareToBoard
let getValidMoves square board =
getNextMovesMemoized square
|> Seq.filter (fun sqr -> ((squareToBoardMemoized sqr) &&& board) = 0L)
// gets all valid moves from a particular square and board state sorted by moves which have less next possible moves
let getValidMovesSorted square board =
getValidMoves square board
|> Seq.sortBy (fun sqr -> (getValidMoves sqr board) |> Seq.length )
let nextMoves = getValidMovesSorted
let sqrToBoard = squareToBoardMemoized
let findPath square =
let board = sqrToBoard square
let rec findPathRec brd sqr sequence = seq {
match brd with
| -1L -> yield sequence
| _ -> for m in nextMoves sqr do yield! findPathRec (brd ||| (sqrToBoard m)) m m::sequence
}
findPathRec board square [square]
let solution = findPath ((4,4) |> pairToSquare) |> Seq.take 1
I am getting the following error:
The type '(int64 -> seq<int>)' is not a type whose values can be enumerated with this syntax, i.e. is not compatible with either seq<_>, IEnumerable<_> or IEnumerable and does not have a GetEnumerator method (using external F# compiler)
I could probably be misunderstanding how this work, but I would expect the results of nextMoves to be seq<_>. Is there a better way of doing this? Am I missing something? Any recommended patterns?
Thanks in advance!

So the problem is that nextMoves has type
val nextMoves : (int -> int64 -> seq<int>)
because it is identical to getValidMovesSorted. You need to supply the board argument

nextMoves is just getValidMovesSorted which takes two arguments (square and board) - now in findPath you only provided one and I guess you wanted to write this
nextMoves sqr board
but then there are more issues in the rest of the code and it's really hard to figure out what you are trying to do
I think you wanted to do something like this:
let findPath square =
let board = sqrToBoard square
let rec findPathRec brd sqr (sequence : int list) =
match brd with
| -1L -> sequence
| _ ->
[
for m in nextMoves sqr board do
yield! findPathRec (brd ||| (sqrToBoard m)) m (m::sequence)
]
this will compile (but will result in an stack-overflow exception)

Related

How can I create a type in order to accommodate the return value of my Ocaml function?

I am trying to implement a lazy fibonacci generator in Ocaml as shown below:
(* fib's helper *)
let rec fibhlpr n = if n == 0 then 0 else if n == 1 then 1 else fibhlpr (n-1) + fibhlpr (n-2);;
(* lazy fib? *)
let rec fib n = ((fibhlpr n), fun() -> fib (n+1));;
I am trying to return the result of fibhlpr (an int) and a function to retrieve the next value, but am not sure how. I think I have to create a new type in order to accommodate the two items I am returning, but I don't know what type fun() -> fib (n+1) returns. When messing around with the code, I received an error which informed me that
fun() -> fib (n+1) has type: int * (unit ->'a).
I am rather new to Ocaml and functional programming in general, so I don't know what this means. I tried creating a new type as follows:
type t = int * (unit -> 'a);;
However, I received the error: "Unbound type parameter 'a".
At this point I am truly stuck: how can I returns the two items that I want (the result of fibhlpr n and a function which returns the next value in the sequence) without causing an error? Thank you for any help.
If you want to define a lazy sequence, you can use the built-in sequence type
constructor Seq.t
let rec gen_fib a b () = Seq.Cons(a, gen_fib b (a+b))
let fib () = gen_fib 0 1 ()
This implementation also has the advantage that computing the n-th term of the sequence is O(n) rather than O(2^n).
If you want to keep using an infinite lazy type, it is also possible. However, you cannot use the recursive type expression
type t = int * (unit -> t)
without the -rectypes flag. And using -rectypes is generally ill-advised for beginners because it reduces the ability of type inference to identify programming errors.
It is thus better to simply use a recursive type definition as suggested by #G4143
type 'a infinite_sequence = { x:'a; next: unit -> 'a infinite_sequence }
let rec gen_fib a b () =
{ x = a; next = gen_fib b (a+b) }
let fib = gen_fib 0 1 ()
The correct type is
type t = int * (unit -> t)
You do not need a polymorphic 'a, because fibonacci only ever yields ints.
However, when you call the next function, you need to get the next value, but also a way to get the one after it, and so on and so on. You could call the function multiple times, but then it means that the function has mutable state, the above signature doesn't require that.
Try:
type 'a t = int * (unit -> 'a);
Your whole problems stems from this function:
let rec fib n = ((fibhlpr n), fun() -> fib (n+1))
I don't think the type system can define fib when it returns itself.. You need to create a new type which can construct a function to return.
I quickly tried this and it works:
type func = Func of (unit ->(int * func))
let rec fib n =
let c = ref 0 in
let rec f () =
if !c < n
then
(
c := !c + 1;
((fibhlpr !c), (Func f))
)
else
failwith "Done"
in
f
Following octachron's lead.. Here's a solution using Seq's unfold function.
let rec fibhlpr n =
if n == 0
then
0
else if n == 1
then
1
else
fibhlpr (n-1) + fibhlpr (n-2)
type func = Func of (unit -> (int * int * func))
let rec fib n =
(n, (fibhlpr n), Func(fun() -> fib (n+1)))
let seq =
fun x ->
Seq.unfold
(
fun e ->
let (c, d, Func f) = e in
if c > x
then
None
else
(
Some((c, d), f())
)
) (fib 0)
let () =
Seq.iter
(fun (c, d) -> Printf.printf "%d: %d\n" c d; (flush stdout)) (seq 30)
You started right saying your fib function returns an integer and a function:
type t = int * (unit -> 'a);;
But as the compiler says the 'a is not bound to anything. Your function also isn't polymorphic so that is has to return a type variable. The function you return is the fib function for the next number. Which also returns an integer and a function:
type t = int * (unit -> int * (unit -> 'a));;
But that second function again is the fib function for the next number.
type t = int * (unit -> int * (unit -> int * (unit -> 'a)))
And so on to infinity. Your type definition is actually recursive. The function you return as second half has the same type as the overall return type. You might try to write this as:
# type t = int * (unit -> t);;
Error: The type abbreviation t is cyclic
Recursive types are not allowed in ocaml unless the -rectypes option is used, which has some other side effects you should read about before using it.
A different way to break the cycle is to insert a Constructor into the cyclic type by making it a variant type:
# type t = Pair of int * (unit -> t)
let rec fibhlpr n = if n == 0 then 0 else if n == 1 then 1 else fibhlpr (n-1) + fibhlpr (n-2)
let rec fib n = Pair ((fibhlpr n), fun() -> fib (n+1));;
type t = Pair of int * (unit -> t)
val fibhlpr : int -> int = <fun>
val fib : int -> t = <fun>
Encapsulating the type recursion into a record type also works and might be the more common solution. Something like:
type t = { value : int; next : unit -> t; }
I also think you are missing the point of the exercise. Unless I'm mistaken the point of making it a generator is so that the function can compute the next fibonacci number from the two previous numbers, which you remember, instead of computing it recursively over and over.

How to find index of an Array element in OCaml

I am trying to find the index of an integer array element in ocaml. How to do this recursively.
Example code:let a = [|2; 3; 10|];;
suppose I want to return the index of 3 in the array a. Any help appreciated. I am new to OCaml programming
type opt = Some of int | None;;
let find a i =
let rec find a i n =
if a.(n)=i then Some n
else find a i (n+1)
in
try
find a i 0
with _ -> None
;;
Test
# find a 3;;
- : int option = Some 1
# find [||] 3;;
- : int option = None
# find a 12;;
- : int option = None
You check each of the elements recursively using an index
let rec find a x n =
if a.(n) = x then n
else find a x (n+1);;
find a x 0;;
that will raise an exception (when n is bigger than the length of the array) in case the element is not part of the array.
let f xs x =
let i = ref (-1) in
let () = Array.iteri (fun n elt -> if x = elt then i := n else ()) xs in
!i
The return value will be -1 if the element is not in the list.

Simplify a recursive function from 3 to 2 clauses

I am doing some exercises on F#, i have this function that calculate the alternate sum:
let rec altsum = function
| [] -> 0
| [x] -> x
| x0::x1::xs -> x0 - x1 + altsum xs;;
val altsum : int list -> int
The exercise consist in declare the same function with only two clauses...but how to do this?
The answer of mydogisbox is correct and work!
But after some attempts I found a smallest and readable solution of the problem.
let rec altsum2 = function
| [] -> 0
| x0::xs -> x0 - altsum2 xs
Example
altsum2 [1;2;3] essentially do this:
1 - (2 - (3 - 0)
it's is a bit tricky but work!
OFF TOPIC:
Another elegant way to solve the problem, using F# List library is:
let altsum3 list = List.foldBack (fun x acc -> x - acc) list 0;;
After the comment of phoog I started trying to solve the problem with a tail recursive function:
let tail_altsum4 list =
let pl l = List.length l % 2 = 0
let rec rt = function
| ([],acc) -> if pl list then -acc else acc
| (x0::xs,acc) -> rt (xs, x0 - acc)
rt (list,0)
This is also a bit tricky...substraction is not commutative and it's impossible think to revers with List.rev a long list...but I found a workaround! :)
To reduce the number of cases, you need to move your algorithm back closer to the original problem. The problem says to negate alternating values, so that's what your solution should do.
let altsum lst =
let rec altsumRec lst negateNext =
match lst with
| [] -> 0
| head::tail -> (if negateNext then -head else head) + altsumRec tail (not negateNext)
altsumRec lst false

Find "short enough" paths in a given graph

I need to design an algorithm to find a path in a public transportation system. In theory only the best (lowest cost) path is required, but in reality it's different. When traveling in a public transportation system, it's difficult to define the cost, it cannot be simplified to traveling time, waiting time, transfer time, bus/subway fees etc, are all need to take into consideration.
Firstly I need to simplify the problem, design a cost function which is a combination of all those "time" and "fee", then use a graph algorithm to find a few paths (3~5 paths). Finally present all these paths to the end users and let them make the decision.
The reason I need to present more than one path is that, for different users/situations these "time" and "fee" are different, thus presenting a few paths is better than just giving out the "best" path.
Algorithms like A* are good for finding the shortest path, but how can I find those "short enough" paths in a graph ? or how can I find the shortest N paths ?
BTW, I don't even need to find the shortest path, because in practice the end users never know the shortest path (unless the shortest path is obvious), they will be happy if the results are close to the shortest path.
A* star's "cost" is more versatile than you are thinking. A* is typically explained with nodes who's cost is simply a distance. We can, however, beef this up a little.
I'm not seeing a language you prefer, maybe Graph? Oh well, here's some c++:
namespace Astar
{
struct CostEvaluation
{
int distance_cost;
int transfer_cost;
// others
int costToTraverseNodes( const Node& first, const Node& second ) const
{
int distance = // apply distance_cost to distance between nodes
int transfer = // apply transfer_cost if there is a transfer between nodes
return distance + transfer;
}
}
}
Now, the actual implementation of your A* will take a CostEvaluation object to determine the cost on the route. If transfers don't matter, set the transfer_cost to zero.
As far as a "good enough" route: I'm sure other people would be able to help you better, but I feel like you might run into a situation where the program says something like "oh, you want to be there in an hour, but the best route only takes twenty minutes? Here, go around in circles for forty minutes, that's good enough".
As I hinted in my comments, it is possible to create a modified A* version which reports multiple routes. I just drove my implementation to the point where it is obviously confirming this statement.
The code below starts with a "classic" A* implementation, which I keep around so one can study the differences between "classic" and "modified".
The basic idea for the modified version is to start the search both forwards and backwards in parallel. This often also yields more robust results, given that the "greediness" of A* is largely driven by its heuristic function (h(x)). It is possible to construct cases, where the greediness opts for fast progress at the start of the route, while that route towards the end "slows down" drastically. Starting from both sides (source, target), this effect can be mitigated to bits. (If one calculates to the end, it should always be optimal routes, if not necessarily the same route. If one were to calculate to the "classic" ending condition in both directions a picture as the one below could result, showing that the both directions yield 2 different paths.
Now, the "explored lists" of both directions can be used to find out when while searching e.g. "forwards", the next node is already explored by the "backwards" search - or vice versa. Obviously, those "connection points" between the two searches yield a route, which is not necessarily optimal but - a valid route.
My implementation traces those intermediate routes and I did not bother to collect them. The traces show the id of the node where both exploration lists "meet" and the resulting 2 parts of the route (source -> meeting point, meeting point -> destination).
Now, using those intermediate lists along with some post processing, e.g. by means of evaluating the routes according to single dimensions of the heuristics function (e.g. comfort, speed, ...), it should be possible to find a good enough selection of routes, associated with different trade-offs in those dimensions.
The full F# script is around 340 lines - a bit too long for this site, so I will omit some nonessential parts (such as my rendering function, creating those bitmaps, etc.
module AStar =
module Internals =
let makeRoute (explo : Map<int,(int * float)>) at tgt =
let rec loop at acc =
let dst,c = explo.[at]
match at,dst with
| (_,b) when b = tgt -> (at,c) :: acc
| (_,b) -> loop b ((at,c) :: acc)
[(tgt,0.0)] # loop at []
let makeRouteBackward (exploBW : Map<int, (int * float)>) at tgt =
let rec loop at acc =
let src,c = exploBW.[at]
match at,src with
| (_,b) when b = tgt -> acc # [(at,c)]
| (_,b) -> loop b (acc # [at,c])
let r = loop at [] # [(tgt,0.0)]
let rev = List.rev r
List.zip r rev |> List.map (fun ((id1,c1),(id2,c2)) -> id1,c2)
let classic neighbors h cost start goal =
let prioSelect (lopen : (int * float) list) =
let sorted = List.sortBy (fun (id,p) -> p) lopen //|> List.rev
(fst (List.head sorted), List.tail sorted)
let rec search (lopen : (int * float) list) (routes : Map<int,int * float>) =
let rec searchNeighbors cur nl o (r : Map<int,(int * float)>) =
match nl with
| [] -> o,r
| next::others ->
let newCost = (snd (r.[cur])) + cost cur next
if (not (Map.containsKey next r)) || (newCost < snd r.[next])
then
let r1 = r |> Map.remove next |> Map.add next (cur,newCost)
let prio = newCost + h next goal
//printfn "current = %d -- next = %d -- newCost = %f -- prio = %f -- h = %f" cur next newCost prio (h next goal)
let o1 = (next,prio) :: o
searchNeighbors cur others o1 r1
else
searchNeighbors cur others o r
match lopen with
| [] -> []
| _::_ ->
let current,rest = prioSelect lopen
if current = goal then Internals.makeRoute routes current start
else
let lopen1,routes1 = searchNeighbors current (neighbors current) rest routes
search lopen1 routes1
search [start,0.] (Map.ofList [start,(start,0.0)])
let twoWay sources targets hforward hbackward costforward costbackward (start : int) (goal : int) (n : int) rr =
let prioSelect (lopen : (int * float) list) =
let sorted = List.sortBy (fun (id,p) -> p) lopen //|> List.rev
(fst (List.head sorted), List.tail sorted)
let searchforward lopen exploredF exploredB nfound acc =
let rec searchNeighbors cur nl o (r : Map<int,(int * float)>) =
match nl with
| [] -> o,r
| next::others ->
//printfn "fwd: current = %d -- next = %d -- nl = %A -- r = %A" cur next nl r
let newCost = (snd (r.[cur])) + costforward cur next
if (not (Map.containsKey next r)) || (newCost < snd r.[next])
then
let r1 = r |> Map.remove next |> Map.add next (cur,newCost)
let prio = newCost + hforward next goal
let o1 = (next,prio) :: o
if Map.containsKey next exploredB then
rr (next, Internals.makeRoute r1 next start, Internals.makeRouteBackward exploredB next goal)
searchNeighbors cur others o1 r1
else
searchNeighbors cur others o r
match lopen with
| [] -> (lopen,exploredF,0,acc)
| _::_ ->
let current,rest = prioSelect lopen
if current = goal then
(rest,exploredF,nfound+1,acc # [Internals.makeRoute exploredF current start] )
else
let lopen1,explored1 = searchNeighbors current (targets current) rest exploredF
(lopen1, explored1, nfound, acc)
let searchbackward lopen exploredB exploredF nfound acc =
let rec searchNeighbors cur nl o (r : Map<int,(int * float)>) =
match nl with
| [] -> o,r
| next::others ->
//printfn "bwd: current = %d -- next = %d -- nl = %A -- r = %A" cur next nl r
let newCost = (snd (r.[cur])) + costbackward cur next
if (not (Map.containsKey next r)) || (newCost < snd r.[next])
then
let r1 = r |> Map.remove next |> Map.add next (cur,newCost)
let prio = newCost + hbackward next start
let o1 = (next,prio) :: o
searchNeighbors cur others o1 r1
else
searchNeighbors cur others o r
match lopen with
| [] -> (lopen,exploredB,0,acc)
| _::_ ->
let current,rest = prioSelect lopen
if current = start then
//(rest,explored,nfound+1,acc # [Internals.makeRoute explored current goal []])
(rest,exploredB,nfound+1,acc # [Internals.makeRouteBackward exploredB current goal] )
else
let lopen1,explored1 = searchNeighbors current (sources current) rest exploredB
(lopen1, explored1, nfound, acc)
let rec driver openF openB exploredF exploredB nfoundF nfoundB accF accB =
let openF1, exploredF1,nfoundF1,accF1 = searchforward openF exploredF exploredB nfoundF accF
let openB1, exploredB1,nfoundB1,accB1 = searchbackward openB exploredB exploredF nfoundB accB
match (nfoundF1+nfoundB1), List.isEmpty openF1, List.isEmpty openB1 with
| (s,false,false) when s < n ->
driver openF1 openB1 exploredF1 exploredB1 nfoundF1 nfoundB1 accF1 accB1
| _ ->
accF1 # accB1
driver [start,0.0] [goal,0.0] (Map.ofList [start,(start,0.0)]) (Map.ofList [goal,(goal,0.0)]) 0 0 [] []
// Location : x,y coordinate or lat/long - whatever.
// Edges: (id,cost) list
type Node = { Id : int; Location : int * int; Edges : (int * float) list; EdgesBackward : (int * float) list}
type Graph = Map<int,Node>
let addNode node graph =
Map.add (node.Id) node graph
let newNode idgen x y =
{ Id = idgen(); Location = (x,y); Edges = []; EdgesBackward = [] }
let addEdge id cost node =
{ node with Node.Edges = node.Edges # [(id,cost)]; }
let addEdgeBackward id cost node =
{ node with Node.EdgesBackward = node.EdgesBackward # [(id,cost)]; }
let idgen startvalue =
let next = ref startvalue
fun () ->
let id = !next
next := !next + 1
id
let appendNode node nodeList = nodeList # [node]
let sq x = x*x
let distance p1 p2 =
let x1,y1 = p1
let x2,y2 = p2
sqrt( float (sq (x2-x1) + sq (y2-y1)) )
let solve (g : Graph) s e =
let ns id =
g.[id].Edges |> List.map (fun (id,c) -> id)
let h at goal =
float (distance (g.[at].Location) (g.[goal].Location))
let c a b =
g.[a].Edges |> List.pick (fun (id,cost) -> if id = b then Some(cost) else None)
[AStar.classic ns h c s e] // give it the same return type as solveTwoWay to make stuff below easier and shorter
let solveTwoWay (g : Graph) s e n =
let edges id =
let nl = g.[id].Edges |> List.map (fun (id,c) -> id)
//printfn "2way edges id = %d list = %A" id nl
nl
let edgesBackward id =
let nl = g.[id].EdgesBackward |> List.map (fun (id,c) -> id)
//printfn "2way backwards edges id = %d list = %A" id nl
nl
let hforward at goal =
float (distance (g.[at].Location) (g.[goal].Location))
let hbackward at start =
float (distance (g.[at].Location) (g.[start].Location))
let costF a b =
g.[a].Edges |> List.pick (fun (id,cost) -> if id = b then Some(cost) else None)
let costB a b =
g.[a].EdgesBackward |> List.pick (fun (id,cost) -> if id = b then Some(cost) else None)
let debugView arg =
let id,r1,r2 = arg
printfn "meeting at %d: r1 = %A r2 = %A" id r1 r2
AStar.twoWay edgesBackward edges hforward hbackward costF costB s e n debugView
let solveProblem problem =
let g, start, goal = problem
g,start,goal,solve g start goal
let solveProblemTwoWay problem n =
let g, start, goal = problem
g,start,goal,solveTwoWay g start goal n
let save name solution =
let graph, start, goal, routes = solution
use writer = System.IO.File.CreateText("""E:\temp\""" + name + """.txt""")
fprintf writer "------------------------------------\n start = %d ----> goal = %d: %d routes found.\n" start goal (List.length routes)
fprintf writer "Graph:\n"
graph |> Map.iter
(fun id node ->
fprintf writer "Node: %A\n" node
)
routes |> List.iteri
(fun index route ->
fprintf writer "Route %d: %A\n" index route
)
// An example problem I used to play with:
// The graph is such, that the nodes are connected to the right and
// downwards and diagonally downwards only.
// The cost is either 1.0 or sqrt(2), for the horizontal or vertical and
// the diagonal connection, respectively.
let problem2 () =
let newNodeAN = newNode (idgen 0)
let cond c x n =
if c then n |> x else n
let accessCost p =
match p with
| (4,4) | (4,5) | (5,4) | (5,5) -> 10.0
| _ -> 1.0
let right (n : Node) : Node =
let t = 1 + fst n.Location, snd n.Location
let c = accessCost t
n
|> cond (fst n.Location < 9) (fun n -> addEdge (n.Id + 1) c n)
|> cond (fst n.Location > 0) (fun n -> addEdgeBackward (n.Id - 1) c n)
let down n =
let t = fst n.Location, 1 + snd n.Location
let c = accessCost t
n
|> cond (snd n.Location < 9) (fun n -> addEdge (n.Id + 10) c n)
|> cond (snd n.Location > 0) (fun n -> addEdgeBackward (n.Id - 10) c n)
let diagdown n =
let t = 1 + fst n.Location, 1 + snd n.Location
let c = (sqrt(2.0)) * accessCost t
n
|> cond (fst n.Location < 9 && snd n.Location < 9) (fun n -> addEdge (n.Id + 11) c n)
|> cond (fst n.Location > 0 && snd n.Location > 0) (fun n -> addEdgeBackward (n.Id - 11) c n)
[
for y = 0 to 9 do
for x = 0 to 9 do
yield newNodeAN x y
]
|> List.map
(fun n ->
n
|> right
|> down
|> diagdown
)
|> List.map (fun n -> (n.Id,n))
|> Map.ofList
, 0, 99
// Last not least, the code can be executed like this:
// And since both implementations yield the same data structures,
// they can be used interchangeably and compared to each other.
solveProblemTwoWay (problem2() 5) |> save "problem2_solution"
The output printed during runtime which shows the "intermediate routes", then looks like this:
...
meeting at 48:
r1 = [(0, 0.0); (11, 1.414213562); (12, 2.414213562); (23, 3.828427125);
(34, 5.242640687); (35, 6.242640687); (46, 7.656854249); (47, 8.656854249);
(48, 9.656854249)]
r2 = [(48, 0.0); (58, 1.414213562); (68, 2.414213562); (78, 3.414213562);
(88, 4.414213562); (99, 5.414213562)]
meeting at 84:
r1 = [(0, 0.0); (11, 1.414213562); (21, 2.414213562); (32, 3.828427125);
(43, 5.242640687); (53, 6.242640687); (64, 7.656854249); (74, 8.656854249);
(84, 9.656854249)]
r2 = [(84, 0.0); (85, 1.414213562); (86, 2.414213562); (87, 3.414213562);
(88, 4.414213562); (99, 5.414213562)]
meeting at 95:
r1 = [(0, 0.0); (11, 1.414213562); (21, 2.414213562); (32, 3.828427125);
(43, 5.242640687); (53, 6.242640687); (64, 7.656854249); (75, 9.071067812);
(85, 10.07106781); (95, 11.07106781)]
r2 = [(95, 0.0); (96, 1.0); (97, 2.0); (98, 3.0); (99, 4.0)]
...

F# tail call optimization with 2 recursive calls?

As I was writing this function I knew that I wouldn't get tail call optimization. I still haven't come up with a good way of handling this and was hoping someone else might offer suggestions.
I've got a tree:
type Heap<'a> =
| E
| T of int * 'a * Heap<'a> * Heap<'a>
And I want to count how many nodes are in it:
let count h =
let rec count' h acc =
match h with
| E -> 0 + acc
| T(_, value, leftChild, rightChild) ->
let acc = 1 + acc
(count' leftChild acc) + (count' rightChild acc)
count' h 0
This isn't isn't optimized because of the addition of the counts for the child nodes. Any idea of how to make something like this work if the tree has 1 million nodes?
Thanks, Derek
Here is the implementation of count using CPS. It still blew the stack though.
let count h =
let rec count' h acc cont =
match h with
| E -> cont (1 + acc)
| T(_,_,left,right) ->
let f = (fun lc -> count' right lc cont)
count' left acc f
count' h 0 (fun (x: int) -> x)
Maybe I can come up with some way to partition the tree into enough pieces that I can count without blowing the stack?
Someone asked about the code which generates the tree. It is below.
member this.ParallelHeaps threads =
let rand = new Random()
let maxVal = 1000000
let rec heaper i h =
if i < 1 then
h
else
let heap = LeftistHeap.insert (rand.Next(100,2 * maxVal)) h
heaper (i - 1) heap
let heaps = Array.create threads E
printfn "Creating heap of %d elements, with %d threads" maxVal threads
let startTime = DateTime.Now
seq { for i in 0 .. (threads - 1) ->
async { Array.set heaps i (heaper (maxVal / threads) E) }}
|> Async.Parallel
|> Async.RunSynchronously
|> ignore
printfn "Creating %d sub-heaps took %f milliseconds" threads (DateTime.Now - startTime).TotalMilliseconds
let startTime = DateTime.Now
Array.length heaps |> should_ equal threads <| "The size of the heaps array should match the number of threads to process the heaps"
let rec reMerge i h =
match i with
| -1 -> h
| _ ->
printfn "heap[%d].count = %d" i (LeftistHeap.count heaps.[i])
LeftistHeap.merge heaps.[i] (reMerge (i-1) h)
let heap = reMerge (threads-1) E
printfn "Merging %d heaps took %f milliseconds" threads (DateTime.Now - startTime).TotalMilliseconds
printfn "heap min: %d" (LeftistHeap.findMin heap)
LeftistHeap.count heap |> should_ equal maxVal <| "The count of the reMerged heap should equal maxVal"
You can use continuation-passing style (CPS) to solve that problem. See Recursing on Recursion - Continuation Passing by Matthew Podwysocki.
let tree_size_cont tree =
let rec size_acc tree acc cont =
match tree with
| Leaf _ -> cont (1 + acc)
| Node(_, left, right) ->
size_acc left acc (fun left_size ->
size_acc right left_size cont)
size_acc tree 0 (fun x -> x)
Note also that in Debug builds, tail call optimization is disabled. If you don't want to run in Release mode, you can enable the optimization in the project's properties in Visual Studio.
CPS is a good general solution but you might also like to consider explicit use of a stack because it will be faster and is arguably simpler:
let count heap =
let stack = System.Collections.Generic.Stack[heap]
let mutable n = 0
while stack.Count > 0 do
match stack.Pop() with
| E -> ()
| T(_, _, heap1, heap2) ->
n <- n + 1
stack.Push heap1
stack.Push heap2
n

Resources