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