Ocaml: Longest path using bfs - graph

The problem is as follow: Given an oriented weighted graph, a start node, an end node and a number k, verify if exist a path from the start node to the end node with at least length k.
This is the code i wrote and it's correct but only in specific graph. For example g1 with weights1 is as follows:
let weights1 = [(2,1,1);(2,1,3);(2,1,4);(1,1,5);(5,1,2);(5,1,6);(3,1,6);(6,1,7);(4,1,3)];;
let f1 = function
1 -> [5]
| 2 -> [1;3;4]
| 3 -> [6]
| 4 -> [3]
| 5 -> [2;6]
| 6 -> [7]
| _ -> [];;
type 'a graph = Graph of ('a -> 'a list);;
let g1 = Graph f1;;
let weights2 = [(1,3,2);(1,9,5);(2,2,3);(5,4,6);(3,1,6);(3,7,4);(6,2,7);(4,4,6);(6,1,2)];;
let f2 = function
1 -> [2;5]
| 2 -> [3]
| 3 -> [4;6]
| 4 -> [6]
| 5 -> [6]
| 6 -> [2;7]
| _ -> [];;
let g2 = Graph f2;;
exception NotFound;;
exception Errore;;
(* Function that return the weight of an edge given 2 nodes*)
let rec get_k x y = function
[] -> 0
|(a,b,c)::rest -> if((a=x && c=y))then b else get_k x y rest;;
(* Function that calculate the total cost of a given path*)
let cost_of_path path weight =
let rec sum cost = function
[]->raise Errore
|x::y::rest -> sum (cost + get_k x y weight) (y::rest)
|_::[]->cost
in sum 0 path;;
(*this function print the list of the path*)
let rec printList = function [] -> print_newline()
| x::rest -> print_int(x); print_string("; "); printList rest;;
(* Simple bfs function, return only 1 path that connect the start node to the final node*)
let bfs start last_node (Graph succ) =
let extends path = printList path;
List.map (function x -> x::path) (List.filter (function x -> not (List.mem x path)) (succ (List.hd path)))
in let rec aux last_node = function
[] -> raise Not_found
| path::rest ->
if (last_node = List.hd path) then List.rev path
else aux last_node (rest # (extends path))
in aux last_node [[start]];;
let loghest_path start final_node k weight (Graph succ)=
let extends path = printList path;
List.map (function x -> x::path)(succ (List.hd path))
in let rec aux final_node = function
[] -> raise NotFound
| path::rest ->
(*if the cost of this path is >= k and the last node is the final node, return that path.*)
if ((cost_of_path (List.rev path) weight >= k) && (List.hd path == final_node)) then List.rev path
(*HERE IS THE ERROR: if the total weight of the singole path is >= k but the last node is not the final node,
find a path that connect the last node of this path to the final node using bfs. It can happen that the path exists
but it return "Not_Found".*)
else if((cost_of_path (List.rev path) weight) >= k)
then (List.rev (List.tl path)) # bfs (List.hd path) (final_node) (Graph succ)
(* If the weight is not yet k than extend the path and try another one in list 'rest' *)
else aux final_node (rest # (extends path))
in aux final_node [[start]];;
(*Function that calls the other function 'loghest_path' and print the result *)
let find_path start final_node k weigths (Graph succ)=
let result = (loghest_path start final_node k weigths (Graph succ)) in
print_string("Final Path:"); printList result ;
print_string("The weight is:"); print_int (cost_of_path result weigths); print_newline();;
And an execution of my code using weights1 and g1 is:
Now, if i execute my code in another graph, for example:
let weights3 =[(1,1,2);(1,1,3);(1,1,4);(2,1,5);(2,1,6);(3,1,7);(3,1,8);(4,1,9);(4,1,10);(10,1,1)];;
let f3 = function
1 -> [2;3;4]
| 2 -> [5;6]
| 3 -> [7;8]
| 4 -> [9;10]
| 10 -> [1]
| _ -> [];;
let g3 = Graph f3;;
With the following execution my code fails:
This because the last path before finding a path that is at least k starts with node 2, and there isn't a path that can connect 2 with 10, but a path between 1 and 10 of weights 10 exists and it's not been chosen. Can someone explain to me how can i change my code to make sure that the problem is solved in every type of graph?

As you stated yourself, the block
else if((cost_of_path (List.rev path) weight) >= k)
then (List.rev (List.tl path)) # bfs (List.hd path) (final_node) (Graph succ)
can fail because nothing ensures the existence of a path from the the last element of the current path to the final node.
The easiest fix is to simply delete this block and ... that's it.
There are no imperious needs to switch algorithms when one partial path is greater than the length threshold (and this is not the right algorithm to try to optimize).

Related

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

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)

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)]
...

compare two equivalence classes (cont.)

val compare : bool array array -> 'a list -> 'a list -> int
compare m generates the lexicographical order on list. I don't know how to fill ???
let rec compare m c c' =
match c with
| [] -> (match c' with
| [] -> 0
| _ :: _ -> -1)
| hd1 :: tl1 -> (match c' with
| [] -> 1
| hd2 :: tl2 -> ???
This is a function that I was trying to do by in a list of ints. but this function was not satisfy, it still missing to check in the rest of a list.
let cmp_classes m c c' =
match c, c' with
| i :: _, j :: _ ->
begin
match m.(i).(j), m.(j).(i) with
(* same class: there is a path between i and j, and between j and i *)
| true, true -> 0
(* there is a path between i and j *)
| true, false -> 1
(* there is a path between j and i *)
| false, true -> -1
(* i and j are not compareable *)
| false, false -> 0
end
| _ -> assert false
Could you please help me? Because when I tried with this function in int
let cmp_classes m i j =
match m.(i).(j), m.(j).(i) with
(* same class: there is a path between i and j, and between j and i *)
| true, true -> 0
(* there is a path between i and j *)
| true, false -> 1
(* there is a path between j and i *)
| false, true -> -1
(* i and j are not compareable *)
| false, false -> 0
it still not return the right order in data I test.
I have been doing this function many times, it is really stuck when I have to try again and again but not find out what is wrong. Please I need your help. Thank you
(* i and j are not compareable *)
| false, false -> 0
This is completely wrong if you are trying to make a topologic sort of your elements. You are saying that incomparable elements are equals which is complete nonsense and WILL confuse the sort algorithm.
If you want to have a real topological order you should follow these steps:
build an input list as the list containing only one representant per class; the output list is empty
until the input list is empty:
pick a random root (with no input edge) in the input list and remove it from the list
append (in any order) all elements the root representants in the output list
return the output list
Depending on the data-structures you are using, this algorithm can be more or less efficient, but your question is not enough precise for me to tell you more.

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