Instantly share code, notes, and snippets.

# johnbartholomew/RomanNumerals.hs Created Jan 15, 2012

A solution to John D. Cook's roman numerals puzzle
 -- 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))
to join this conversation on GitHub. Already have an account? Sign in to comment