(Dis)Functional Bowling

It is saddening to see people invested so heavily in cargo-cult programming practices that they cannot see natural solutions to simple problems after having their thoughts twisted by object-orientation as an ends and TDD as a fighting technique. Uncle Bob is struggling (and failing) to approach functional programming in the natural way by what seems to be his biases and commercial interests. His Bowling Game Kata (warning, PPT; right-click to download) is to find the score of a 10-frame bowling game:

The game consists of 10 frames as shown above. In each frame the player has two opportunities to knock down 10 pins. The score for the frame is the total number of pins knocked down, plus bonuses for strikes and spares.

A spare is when the player knocks down all 10 pins in two tries. The bonus for that frame is the number of pins knocked down by the next roll. So in frame 3 above, the score is 10 (the total number knocked down) plus a bonus of 5 (the number of pins knocked down on the next roll.)

A strike is when the player knocks down all 10 pins on his first try. The bonus for that frame is the value of the next two balls rolled.

In the tenth frame a player who rolls a spare or strike is allowed to roll the extra balls to complete the frame. However no more than three balls can be rolled in tenth frame.

In order to sidestep the problem of validating games for length, I'll consider a bowling game as an infinite number of balls, a finite prefix of which is non-zero:

let repeat x = let rec l = x :: l in l

let game strikes = strikes @ repeat 0

Scoring a frame according to the rules is a matter of pattern matching on the first few balls. According to the result, a complete frame is removed and the rest of the game returned:

let score_frame = function
| 10 :: (n :: m :: _ as g) -> 10 + n + m, g
| n :: m :: (r :: _ as g) when n + m = 10 -> 10 + r, g
| n :: m :: g -> n + m, g

To score a game, I keep track of how many frames I'm into the game, and stop at the tenth:

let rec score frame g =
 if frame = 10 then 0 else
 let n, g = score_frame g in
 n + score (succ frame) g

The game begins at the zeroth-frame, obviously:

# score 0 (game [1; 4; 4; 5; 6; 4; 5; 5; 10; 0; 1; 7; 3; 6; 4; 10; 2; 8; 6]) ;;
- : int = 133

10 minutes of thinking, and some looking around to realize that I had mistyped the scorecard. What TDD do you need, Uncle Bob?


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.