The Bee Colony in action

In our previous installments, we laid the groundwork of our Bee Colony Algorithm implementation. Today, it’s time to put the bees to work, searching for an acceptable solution to the Traveling Salesman problem.

We will approach the search as a Sequence: starting from an initial hive and solution, we will unfold it, updating the state of the hive and the current best solution at each step. Let’s start with the hive initialization. Starting from an initial route, we need to create a pre-defined number of each Bee type, and provide them with an initial destination:

let Initialize nScouts nActives nInactives cities (rng : Random) =
   [    
      for i in 1 .. nScouts do 
         let solution = Evaluate(Shuffle rng cities)
         yield Scout(solution)
      for i in 1 .. nActives do
         let solution = Evaluate(Shuffle rng cities)
         yield Active(solution, 0)
      for i in 1 .. nActives do
         let solution = Evaluate(Shuffle rng cities)
         yield Inactive(solution)
   ]

There is probably a more elegant way to do this, but this is good enough: we use a simple List comprehension to generate a list on the fly, yielding the appropriate number of each type of bees, and assigning them a shuffled version of the starting route.

Next, we need a function to update our hive, and the current best solution available:

let Update (hive, currentBest : Solution) rng = 
   let searchResult = List.map (fun b -> Search b rng) hive
   let newSolutions = List.choose (fun e -> snd e) searchResult
   let newBest = List.fold (fun best solution -> 
      if best.Cost < solution.Cost 
      then best 
      else solution) currentBest newSolutions 
   let inactives = CountInactives hive
   let updatedHive = searchResult 
                     |> List.map (fun b -> Waggle newSolutions (fst b) rng) 
                     |> Activate rng inactives
   (updatedHive, newBest)

The function takes 2 arguments: a Tuple of the current state of affairs (the hive and the best solution), and a random number generator. First, we use List.map, to apply the Search function we defined earlier to each bee, returning a new List of Tuples, containing each bee and an option containing the result of its search (a new solution, or None). We then extract the new solutions from that list, using List.choose to retrieve the second element of the Tuples when they are not None, and use a List.fold to find the new best solution from that list, if it is better than the current best solution. Finally, we update the Hive, by having each Bee perform its Waggle dance and share its new information via List.map, and applying the Activate function to promote some of the inactive bees to Active status – and return a Tuple of the updated hive and updated best solution.

We are now almost done – we can now define a Solve function, which will call Initialize to create an initial hive, and unfold an infinite Sequence of solutions:

let Solve scouts actives inactives route =
   let rng = new Random()
   let hive = Initialize scouts actives inactives route rng
   let initialBest = List.map (fun b -> Solution b) hive 
                     |> List.minBy (fun s -> s.Cost)
   Seq.unfold (fun h -> Some(h, (Update h rng))) (hive, initialBest)

It’s now time to see this in action. Let’s add a file to our project, and create a small console application Program.fs. First, we need a good test case: let’s generate a list of cities named A to Z, located on a circle:

let RandomRoute radius points = 
   [ 
      let rng = new Random()
      let letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 
      for i in 0 .. (points - 1) do 
      let angle = Math.PI * 2.0 * (double)i / (double)points
      let name = letters.[i];
      yield { 
         Solver.City.Name = (string)name; 
         Solver.City.X = Math.Cos(angle) * radius; 
         Solver.City.Y = Math.Sin(angle) * radius }
   ]

If our algorithm is working, it should return a list of cities sorted in alphabetical (or reverse-alphabetical) order.

Next, let’s create an entry point for our console application, and watch the bees at work:

[<EntryPoint>]
let main (args : string[]) =
   printfn "Bee Hive colony at work!"
   
   let stopwatch = new Stopwatch()
   stopwatch.Start()

   let rng = new Random()
   let route = RandomRoute 100.0 26
   let bestSolution = Solver.Evaluate route
   printfn "Best possible cost: %f" bestSolution.Cost

   let initialSolution = Solver.Evaluate (Solver.Shuffle rng route)
   printfn "Initial cost: %f " initialSolution.Cost
   
   let search = Solver.Solve 30 50 20 route 
   let solution = search |> Seq.nth 20000 |> snd
   
   stopwatch.Stop()
   printfn "Milliseconds: %d" stopwatch.ElapsedMilliseconds

   printfn "Solution cost: %f" solution.Cost
   solution.Route |> List.iter (fun c -> printf "%s " c.Name)   
    
   printfn ""
   printfn "Press enter to close"
   Console.ReadLine() |> ignore
   0

Running this produces the following:

image

In about three minutes, starting from a path of length 3450, we found a solution of length 946, out of a possible best of 627. The list has long stretches of correctly reverse-sorted cities (it got D to R properly ordered), with a few misplaced cities. Not too bad!

Before going further, here is the complete code I wrote so far, in its current state. First, the Solver.fs file, which contains the algorithm logic:

module Solver
open System

let probaFalsePositive = 0.1 // proba to incorrectly pick a worse solution
let probaFalseNegative = 0.1 // proba to miss an improved solution
let tripsLimit = 100 // number of trips without improvements a bee can make
let probaConvince = 0.8 // proba to convince a bee to target a better solution

let SwapIndexPairs (rng : Random) list =  
   seq { 
      for i in (List.length list - 1) .. -1 .. 1 do 
      yield (i, rng.Next(i + 1)) }

let SwapIndexMap index (moveIndex, toIndex) =
  if index = moveIndex then toIndex
  elif index = toIndex then moveIndex
  else index

let Swap indexPair list =
  let length = List.length list
  List.permute (fun index -> SwapIndexMap index indexPair) list

let Shuffle (rng : Random) list = 
   let length = List.length list
   let indexPairs = SwapIndexPairs rng list
   Seq.scan (fun currentList indexPair -> Swap indexPair currentList) 
      list indexPairs
   |> Seq.nth (length - 1)

let SwapWithNextIndexMap index swapIndex length =
  let flipWith = (swapIndex + 1) % length
  SwapIndexMap index (swapIndex, flipWith)

let SwapWithNext swapIndex list =
  let length = List.length list
  List.permute (fun index -> SwapWithNextIndexMap index swapIndex length) list

let SwapRandomNeighbors list =
   let random = new Random()
   let index = random.Next(0, List.length list)
   SwapWithNext index list

type City = { Name: string; X: float; Y: float; }

let Distance (city1, city2) = 
    ((city1.X - city2.X) ** 2.0 
    + (city1.Y - city2.Y) ** 2.0) ** 0.5

let CircuitCost list =
      seq {
         for i in 0 .. (List.length list - 1) -> list.[i]
         yield List.head list
      }
      |> Seq.pairwise 
      |> Seq.map Distance 
      |> Seq.sum  

type Solution = { Route: List<City>; Cost: float }

let Evaluate (route: List<City>) = { Route = route; Cost = CircuitCost route }

type Bee = 
   | Scout of Solution
   | Active of Solution * int
   | Inactive of Solution

let Search bee (rng : Random) =
   match bee with
   | Scout solution -> 
      let newSolution = Evaluate (Shuffle rng solution.Route)
      if newSolution.Cost < solution.Cost
      then (Scout(newSolution), Some(newSolution))
      else (bee, None)
   | Active (solution, visits) ->
      let newSolution = Evaluate (SwapRandomNeighbors solution.Route)
      let proba = rng.NextDouble()
      if newSolution.Cost < solution.Cost
      then 
         if proba < probaFalseNegative 
         then (Active(solution, (visits + 1)), None)
         else (Active(newSolution, 0), Some(newSolution))      
      else
         if proba < probaFalsePositive
         then (Active(newSolution, 0), Some(newSolution))
         else (Active(solution, (visits + 1)), None)
   | Inactive solution -> (bee, None)

let Solution bee =
   match bee with
   | Scout(solution) -> solution
   | Inactive(solution) -> solution
   | Active(solution, trips) -> solution

let (|RequiresUpdate|) bee =
   match bee with 
   | Scout(solution) -> false
   | Inactive(solution) -> true
   | Active(solution, trips) -> trips > tripsLimit 

let Waggle (solutions : List<Solution>) (bee : Bee) (rng : Random) =
   match bee with 
   | RequiresUpdate true -> 
      let currentSolution = Solution bee
      let newSolution = List.fold (fun acc element -> 
         if element.Cost < acc.Cost && rng.NextDouble() < probaConvince 
         then element else acc) currentSolution solutions
      Inactive(newSolution)      
   | _ -> bee

let Promote bee =
   match bee with
   | Inactive(solution) -> Active(solution, 0)
   | _ -> bee

let Activate rng inactives bees =
   let inactiveIndexes = 
      List.mapi (fun i b -> match b with 
                            | Inactive(solution) -> Some(i) 
                            | _ -> None) 
                            bees
      |> List.choose (fun e -> e) 
      |> Shuffle rng

   let promoted = (List.length inactiveIndexes) - inactives
   let promotedIndexes = Seq.take promoted inactiveIndexes |> Seq.toList
   
   bees |> List.mapi (
      fun i b -> if List.exists (fun e -> e = i) promotedIndexes 
                 then Promote b
                 else b)

let CountInactives hive = 
   hive |> List.choose (fun b -> match b with 
                                 | Inactive(solution) -> Some(b) 
                                 | _ -> None)
   |> List.length

let Initialize nScouts nActives nInactives cities (rng : Random) =
   [    
      for i in 1 .. nScouts do 
         let solution = Evaluate(Shuffle rng cities)
         yield Scout(solution)
      for i in 1 .. nActives do
         let solution = Evaluate(Shuffle rng cities)
         yield Active(solution, 0)
      for i in 1 .. nActives do
         let solution = Evaluate(Shuffle rng cities)
         yield Inactive(solution)
   ]

let Update (hive, currentBest : Solution) rng = 
   let searchResult = List.map (fun b -> Search b rng) hive
   let newSolutions = List.choose (fun e -> snd e) searchResult
   let newBest = List.fold (fun best solution -> 
      if best.Cost < solution.Cost 
      then best 
      else solution) currentBest newSolutions 
   let inactives = CountInactives hive
   let updatedHive = searchResult 
                     |> List.map (fun b -> Waggle newSolutions (fst b) rng) 
                     |> Activate rng inactives
   (updatedHive, newBest)

let Solve scouts actives inactives route =
   let rng = new Random()
   let hive = Initialize scouts actives inactives route rng
   let initialBest = List.map (fun b -> Solution b) hive 
                     |> List.minBy (fun s -> s.Cost)
   Seq.unfold (fun h -> Some(h, (Update h rng))) (hive, initialBest)

Then, the Program.fs file, which contains the Console application:

module Program

open System
open System.Diagnostics

let RandomRoute radius points = 
   [ 
      let rng = new Random()
      let letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 
      for i in 0 .. (points - 1) do 
      let angle = Math.PI * 2.0 * (double)i / (double)points
      let name = letters.[i];
      yield { 
         Solver.City.Name = (string)name; 
         Solver.City.X = Math.Cos(angle) * radius; 
         Solver.City.Y = Math.Sin(angle) * radius }
   ]

[<EntryPoint>]
let main (args : string[]) =
   printfn "Bee Hive colony at work!"
   
   let stopwatch = new Stopwatch()
   stopwatch.Start()

   let rng = new Random()
   let route = RandomRoute 100.0 26
   let bestSolution = Solver.Evaluate route
   printfn "Best possible cost: %f" bestSolution.Cost

   let initialSolution = Solver.Evaluate (Solver.Shuffle rng route)
   printfn "Initial cost: %f " initialSolution.Cost
   
   let search = Solver.Solve 30 50 20 route 
   let solution = search |> Seq.nth 20000 |> snd
   
   stopwatch.Stop()
   printfn "Milliseconds: %d" stopwatch.ElapsedMilliseconds

   printfn "Solution cost: %f" solution.Cost
   solution.Route |> List.iter (fun c -> printf "%s " c.Name)   
    
   printfn ""
   printfn "Press enter to close"
   Console.ReadLine() |> ignore
   0

At that stage, we have a running algorithm, which seems to be doing what we expect, in about 200 lines of code. I am sure that code could be improved, and I would love to hear comments or suggestions to make it better!

My next objective will be to parallelize that code, to make it hopefully faster. Most of the code should be suitable for this, because we are operating on immutable structures, except for one issue, the random number generator, which uses the non-thread-safe Random() class. Stay tuned!

Do you have a comment or a question?
Ping me on Mastodon!