Monadic Golf

Reading Bonsai Code's solutions to Programming Praxis's weekly puzzles (which I can't recommend highly enough) makes me feel acutely aware of how verbose OCaml is, and how inadequate its standard library when compared to Haskell's. However, I've found that the latest puzzles yield concisely to a monadic style over the lists.

Breaking with my usual literate top-down presentation I'll concentrate on the code required to solve the puzzles and leave the obvious scaffolding to the reader. I'll still putt over the par, especially if scored against Remco's brutally terse solutions, but I hope that what is missing is straightforward to fill in. I've written about point-free style and its limitations in the face of OCaml's value restriction. In this case I'll use monadic style for the solutions as a way to show that procedural expression too has its place in functional programming.

This week's problems are drawn from the International Mathematical Olympiads and are very much in the spirit of Project Euler's problems, yielding nicely to brute-force search. The first:

Determine all three-digit numbers N having the property that N is divisible by 11, and N/11 is equal to the sum of the squares of the digits of N.

can be solved simply by:

let imo_1960_01 =
  range 1 99 >>= fun i ->
  let n = 11 * i in
  guard (sum % fmap square % digits $ n = i) >>
  return n

In this solution and the ones that follow I express the problem in monadic terms via fmap, return, bind (and the two synonyms >>= and >>) and guard. Here % is composition, and range, sum, square and digits are obvious. Equally pythy is the solution to the second problem:

Find the smallest natural number n which has the following properties:

1. Its decimal representation has 6 as the last digit.
2. If the last digit 6 is erased and placed in front of the remaining digits, the resulting number is four times as large as the original number n.

Since n = 10*k + 6, the condition is equivalent to asking that 4*(10*k + 6) = 6*10^b + k, where b = ν(k) the number of decimal digits in k. Simplifying, the problem is equivalent to finding the smallest integer k = 2/13*(10^b - 4) with exactly b digits. In code:

let imo_1962_01 =
  range 1 9 >>= fun b ->
  let e = pow 10 b in
  guard (e mod 13 = 4) >>
  let k = (e - 4) / 13 * 2 in
  guard (List.length % digits $ k = b) >>
  return (10 * k + 6)

The number is not too large, and a 31-bit version of pow is sufficient. The third problem will require more scaffolding:

Five students, A, B, C, D, E, took part in a contest. One prediction was that the contestants would finish in the order ABCDE. This prediction was very poor. In fact no contestant finished in the position predicted, and no two contestants predicted to finish consecutively actually did so. A second prediction had the contestants finishing in the order DAECB. This prediction was better. Exactly two of the contestants finished in the places predicted, and two disjoint pairs of students predicted to finish consecutively actually did so. Determine the order in which the contestants finished.

This is more of a word problem than a combinatorial one, and as the latter is not very straightforward and to brute force it I'll need a number of auxiliary functions. A way to list all permutations is first:

let rec selections = function
| [] -> []
| x :: xs ->
  (x, xs) :: List.fold_right (fun (y, ys) l ->
    (y, x :: ys) :: l) (selections xs) []

let rec permutations = function
| ([] | [_]) as l -> [l]
| l ->
  List.fold_right (fun (y, ys) ->
    List.fold_right (fun zs l -> (y :: zs) :: l)
    (permutations ys)) (selections l) []

The first condition asks for permutations having no fixed points, or derangements. I need a way to single derangements out:

let count_fixpoints l p =
  List.fold_left (fun s (x, y) ->
    if x = y then succ s else s) 0 (List.combine l p)

let is_derangement l p = count_fixpoints l p = 0

Lastly, in order to filter consecutive positions, I need a way to generate them and filter them out:

let intersect l m = List.filter (fun x -> List.mem x l) m

let rec pairup = function
| [] | [_] -> []
| x :: (y :: _ as xs) -> (x, y) :: pairup xs

The solution to the problem is a word-for-word translation of the problem's conditions:

let imo_1963_01 =
  let prediction  = ['D'; 'A'; 'E'; 'C'; 'B'] in
  let contestants = List.sort compare prediction in
  let all_pairs   = pairup contestants
  and pred_pairs  = pairup prediction in
  permutations contestants >>= fun p ->
  guard (is_derangement  contestants p
      && count_fixpoints prediction  p = 2) >>
  let pp = pairup p in
  guard (List.length (intersect all_pairs pp) = 0) >>
  guard (match intersect pred_pairs pp with
  | [(x, y); (z, t)] -> y <> z && t <> x
  | _ -> false) >>
  return p

that is, the solution is to be found among all the permutations of the contestants which are derangements and have exactly two positions in common with the prediction. Of these candidates they must have no pair in common with the pairs in the sorted list of contestants, and has to have two disjoint pairs in common with the prediction.

Some would argue, I'm sure, that monadic code is not purely functional, or that it is too rigidly laid out by the sequential nature of monadic binding. I think that it is ideal to solve these word problems since I find that the solution closely follows the conditions laid out in the statement. All in all I've left out less than 40 lines of perfectly obvious support code, and gave solutions with 5, 7 and 30-odd lines. It was a fun exercise.