A solution to John D. Cook's roman numerals puzzle

RomanNumerals.hs

-- written for a puzzle presented by John D. Cook:
--   http://www.johndcook.com/blog/2012/01/14/roman-numeral-puzzle/
--
-- Copyright (C) 2012, John Bartholomew.
-- You may use this code for any purpose, WITHOUT WARRANTY.

module Main where

import Control.Monad
import Data.Char
import Data.List

{-

Combinatorial:

Rules: restrictive subtraction rules. I'll also add a rule that a
smaller value cannot appear before a larger value except as a subtraction.

The alphabet contains 7 characters, which are (in order from lowest-value
to highest-value): I, V, X, L, C, D, and M.

V, L, D and M can never be subtracted, but may be included or not.

I, X and C each have four possibilities: they can be skipped; they can
appear in their positive position, or they can appear in one of two negative
positions.

Those choices lead to 2**4 * 4**3 = 2**10 possibilities. Howeve, that assumes
all the choices are independent, which they are not. If 'V' does not appear,
then 'I' cannot be subtracted from it; if 'X' is subtracted from 'L' or 'C',
then 'I' cannot be subtracted from 'X', and so on.

So let's start again. We can split the possibilities into four cases,
based on the number of subtractions in each one. Given N subtractions,
we have 2^(7-2N) possibilities. This comes from having 7 - 2N positive
value characters that can (each, independently) be chosen to appear or
not appear in the string. For the case of N = 0, we subtract 1 to remove
the possibility of the empty string.

0 subtractions: 2^7 - 1
1  subtraction: 6 * 2^5
2 subtractions: 8 * 2^3
(IV,XL ; IV,XC; IV,CD; IV,CM; IX,CD ; IX,CM; XL,CD ; XL,CM)
3 subtractions: 2 * 2
(IV,XL,CD ; IV,XL,CM)

Total possibilities: 2^7 + 6*2^5 + 8*2^3 + 4 - 1 = 387

This matches the number of results emitted by the code in my previous
comment, which gives me a lot of confidence that the result is correct.

-----------

Excluding CMD, XCL and IXV:

0 subtractions: 2^7 - 1
1  subtraction: 3 * 2^5 + 3 * 2^4
2 subtractions: 3 * 2^3 + 4 * 2^2 + 2
(IV,XL ; IV,XC ; IV,CD; IV,CM ; IX,CD ; IX,CM ; XL,CD ; XL,CM)
3 subtractions: 3
(IV,XL,CD ; IV,XL,CM)

Total possibilities: 2^7 + 3 * 2^5 + 3 * 2^4 + 3 * 2^3 + 4 * 2^2 + 2 + 3 - 1 = 316

-}

romanNumerals
  = "(M? D? C? | M? CD | CM D?) ((L? X? | XL) (V? I? | IV) | L? IX V?) | M? D? XC L? (V? I? | IV)"

-- this excludes CMD, XCL and IXV
romanNumerals2
  = "(M? D? C? | M? CD | CM) ((L? X? | XL) (V? I? | IV) | L? IX) | M? D? XC (V? I? | IV)"

totalNumerals = 2^7 + 6*2^5 + 8*2^3 + 4 - 1
totalNumerals2 = 2^7 + 3 * 2^5 + 3 * 2^4 + 3 * 2^3 + 4 * 2^2 + 2 + 3 - 1

enumerateRegex = nub . fst . go1 . filter (not . isSpace)
  where
    go1 = go [""] [""]
    go :: [String] -> [String] -> String -> ([String], String)
    go prefix atom ('(':xs) = let (a,b) = go1 xs in go (allPairs prefix atom) a b
    go prefix atom (')':xs) = (allPairs prefix atom, xs)
    go prefix atom ('|':xs) = let (a,b) = go1 xs in (allPairs prefix atom ++ a, b)
    go prefix atom ('?':xs) = go (allPairs prefix (atom ++ [""])) [""] xs
    --go prefix atom ('?':xs) = go prefix atom xs
    go prefix atom ( c :xs) = go (allPairs prefix atom) [[c]] xs
    go prefix atom []       = (allPairs prefix atom, "")
    allPairs :: [String] -> [String] -> [String]
    allPairs a b = concatMap (\x -> map (x ++) b) a

main = do
  let numerals = enumerateRegex romanNumerals2
  forM_ numerals putStrLn
  putStrLn ("total should be " ++ show totalNumerals2)
  putStrLn ("and is actually " ++ show (length numerals - 1))