Sorting out Sorters

Previously I proved how the zero-one principle can test if a comparator network is actually a sorting network or not. This can be efficiently implemented as a program. I'll represent a comparator network of width w as an array of exchange boxes:

type network = (int * int) array

Each entry of the array is a pair (i, j) with 0 ≤ i ≤ j < w, representing an exchange box between "wires" or indices i and j. If i = j, the "exchange" box is the null operation, as x↑x = x↓x = x. Now the quickest way to generate binary sequences in a binary computer is to count. For every 0 ≤ x < 2^w,

x = ⟨∑i : 0 ≤ i < x : 2i⋅xi⟩

with x_i ∈ {0, 1} a binary digit. With that, a binary sequence is sorted if, as a binary word, it is represented as a block of zeros followed by a block of ones. It is well known that it is very easy to test if the block of ones is contiguous in the least significant positions, that is, if there is a k ≤ w such that for all 0 ≤ i < k, x_i = 1 and for k < i < x, x_i = 0:

let is_sorted word = word land (word + 1) == 0

Why does that work? The condition on x is equivalent to requiring that x = 2^k - 1, hence the bitwise land will not find a 1 digit in common between this and 2^k. Now, viewed as an operation on bits, the exchange box computes the following binary function:

A	B	A↓B	A↑B
0	0	0	0
0	1	0	1
1	0	0	1
1	1	1	1

That is, (A ↕ B) = (A ∧ B, A ∨ B). An exchange box, hence, needs to select bits and apply the corresponding functions according to a mask:

let exchange (i, j) word =
  (* i <= j *)
  word
    lor  (word lsr (j - i) land     (1 lsl i))
    land (word lsl (j - i) lor lnot (1 lsl j))

Note that the shifts required to align the i-th bit with the j-th one require crucially that i ≤ j. Note also that, strictly speaking, the function sorts bits in a word in descending order, that is, the greater elements (the ones) are moved to the lowest positions (the least significant bits). To apply an exchange network to a binary word, it suffices to fold each exchange box over it:

let sort (n : network) word =
  Array.fold_left (fun word (i, j) -> exchange (i, j) word) word n

With that, a function testing a comparator network is simply:

exception Unsorted of int

let is_sorting_network width (n : network) =
  let tests = 1 lsl width in
  try
    for i = 0 to pred tests do
      if not (is_sorted (sort n i)) then raise (Unsorted i)
    done;
    true
  with Unsorted _ -> false

For instance, the canonical 4-sorting network passes:

# is_sorting_network 4 [|0,1;2,3;0,2;1,3;1,2|] ;;
- : bool = true

But a slight variation thereof doesn't:

# is_sorting_network 4 [|0,1;2,3;0,2;1,3;1,3|] ;;
- : bool = false

I use an exception not only to bail out early from the testing loop, but also because elsewhere I make use of the word that failed to sort in choosing the best individual among a collection of random networks. But about that, more later.