public
Created

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

  • Download Gist
RomanNumerals.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
-- 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))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.