Thrice is a charm — A-star in F#

The real goal of the last couple of exercises, creeping crabwise up on doing something in F# that's not totally trivial.

Having started with the wikipedia pseudo-code, Python was an obvious first real language; then to make it pure functional, Erlang was the obvious choice, before going to F#. And boy was that last step painful at times.

Really Erlang:Python :: F#:C# -- the first two being dynamically typed and forgiving; the other requiring dodges like nullable/option types for the "it didn't work" return cases. Those required some wrestling with the type system in the middle of the conversion from Erlang, though in the end, all the explicit argument type specifications did eventually go away.

#light

// specialize for the torch-carrier problem
// bits 0-4 represent torch, 1m, 2m, 5m, 10m
// set bit = on the near side
//
// Updated to F# 1.9.9.9 11-Feb-10

// Every possible crossing of one or two
let swaps =
  [3;5;9;17; 7; 11;13; 19;21;25];;

let crossing_time swap = 
  match swap with
    | x when x > 16 -> 10
    | x when x > 8 -> 5
    | x when x > 4 -> 2
    | _ -> 1;;

let h_score node =
  crossing_time node;;
  
let equivalent_point x = 
  match x &&& 1 with
    | 1 -> x
    | _ -> 31^^^x;;
  
let rec compatible x y outlist inlist = 
  match inlist with
  | [] -> outlist
  | swap::tail when (y &&& swap) = swap ->
    let newlist = (x^^^swap)::outlist
    compatible x y newlist tail
  | swap2::tail2 -> compatible x y outlist tail2;;
  
let neighbour_nodes x = 
    compatible x (equivalent_point x) [] swaps;;

let dist_between x y =
  crossing_time (x^^^y);;

//------------ Generic A* starts here --------------

let rec reconstruct_path came_from node =
  match Map.find node came_from with
  | None ->
      node :: []
  | value ->
      node :: reconstruct_path came_from value;;
      
let rec update x y old_f old_g old_from g_value = 
  let key_f = Map.containsKey y old_f
  let key_g = Map.containsKey y old_g 
  let key_from = Map.containsKey (Some y) old_from
  match (key_f, key_g, key_from) with
  | (true,_,_) -> update x y (Map.remove y old_f) old_g old_from g_value
  | (_,true,_) -> update x y old_f (Map.remove y old_g) old_from g_value
  | (_,_,true) -> update x y old_f old_g (Map.remove (Some y) old_from) g_value
  | _ -> 
    let new_from = Map.add (Some y) (Some x) old_from
    let new_g = Map.add y g_value old_g
    let new_f = Map.add y (g_value + (h_score y)) old_f // Estimated total distance from start to goal through y.
    (new_f, new_g, new_from);;
      
let rec scan x neighbours openset closedset f g from =
  match neighbours with
  | [] -> (openset, f, g, from)
  | y::n -> 
    if Set.contains y closedset then
      scan x n openset closedset f g from
    else
      let g0 = Map.find x g
      let trial_g = g0 + dist_between x y
      if Set.contains y openset then
        let old_g = Map.find y g
        if trial_g < old_g then
          let (new_f, new_g, new_from) = update x y f g from trial_g
          scan x n openset closedset new_f new_g new_from
        else 
          scan x n openset closedset f g from
      else
        let new_open = Set.add y openset
        let (new_f, new_g, new_from) = update x y f g from trial_g        
        scan x n new_open closedset new_f new_g new_from;;

let best_step openlist score =
  let choice score h best best_value =
    let v = Map.find h score
    match best with
    | None -> ((Some h), v)
    | x when Some v < Some best_value -> ((Some h), v)
    | _ -> (best, best_value)
        
  let rec best_step4 openlist score best best_value =
    match openlist with
    | [] -> best
    | h::tail -> 
        let pair = choice score h best best_value
        match pair with 
        | (next, next_value) -> best_step4 tail score next next_value
        
  match openlist with
  | [] -> None
  | list ->
    best_step4 list score None 0;;
    
  
  
let rec astar_step goal closedset openset f_score g_score came_from =
  match Set.count openset with
    | 0 ->
      None;
    |_ ->
      let l = Set.toList openset
      let pt = best_step l f_score

      if (Some goal) = pt then
          let path = reconstruct_path came_from (Some goal)
          Some path
      else
        match pt with 
        | None -> None
        | Some x -> 
          let next_open = Set.remove x openset
          let next_closed = Set.add x closedset
          let neighbours = neighbour_nodes x

          let (new_open, new_f, new_g, new_from) = scan x neighbours next_open next_closed f_score g_score came_from
          astar_step goal next_closed new_open new_f new_g new_from;;

let astar start goal =
  let closedset = Set.empty             // The set of nodes already evaluated.
  let openset = Set.add start Set.empty // The set of tentative nodes to be evaluated

  let f_score = Map.add start (h_score start) Map.empty
  let g_score = Map.add start 0 Map.empty

  let came_from = Map.add (Some start) None Map.empty
  
  astar_step goal closedset openset f_score g_score came_from;;

//------------ Generic A* ends here ----------------


// presentation form
let rec display swap = 
    let decorate value =
      match value with
      | "" -> value
      | _ -> sprintf "+%s" value
    let rec compound swap bit =
      sprintf "%d%s" (crossing_time swap) (decorate (display (swap^^^bit)))
    match swap with
      | x when x > 16 -> compound swap 16
      | x when x > 8 -> compound swap 8
      | x when x > 4 -> compound swap 4
      | x when x > 2 -> compound swap 2
      | _ -> "";;


let print_swap swap from =
  let transition = display swap
  match from &&& 1 with
  | 1 -> printf "    %s -->\n" transition
  | _ -> printf "<-- %s\n" transition;;

let rec  print_result path prev time =
  match path with
  | [] -> time
  | (Some h)::trace -> 
    let swap = h^^^prev
    print_swap swap h
    let interval = time + crossing_time(swap)
    print_result trace h interval;;
    

let main =
  match astar 31 0 with
  | Some((Some h)::trace) ->
      let time = print_result trace h 0
      printf "Time taken = %d minutes\n" time;;
  
printf "----";;

The ability to nest functions is where the big changes is structure from the Erlang version show up. I could do a bit more of this -- pulling astar_step into astar, for example, or pulling compatible and equivalent_point into neighbour_nodes -- but I wouldn't want to pull too many long functions inside other ones, simply for clarity.

Also the generic engine could in all three cases be given function arguments to replace the coupling by name in these examples.

It's also annoying that calls always have to go up the source file -- smells a bit of 'C' in comparison with the customary freedom to refer back and forth as in the other implementations (or even in C# or Java) -- so that the algorithm bit is now in the middle and not at the top.

Yes, this does compile with a couple of warnings about incomplete matches in failure cases.