Solving an arithmetic puzzle with Haskell

[EDIT: since this post still seems to get a good deal of traffic, I should note that (as you can see if you read the comments) the code I gave here is not quite correct. Still, it's interesting enough that I'll leave it up.]

JD2718 posted a puzzle the other day: the idea is to count how many possible results you can get by combining the numbers 4,3,2,1 (in that order) with the four arithmetic operators and parentheses. Naturally I decided to write some Haskell code to solve this one.

First, instead of thinking in terms of possibly using parentheses, I just generate all possible postfix expressions. But instead of creating some sort of algebraic data type to represent expressions, generating all possible expressions, and evaluating, I sort of interleaved the processes. First, I generate the list 4,3,2,1 with operations optionally applied along the way in all possible ways, then reduce them in all possible ways to a single result, discarding duplicates the whole time. Here’s the code:

import Data.Ratio
import Data.List

type Op = (Rational -> Rational -> Rational)
type Stack = [Rational]

-- make a special kind of division to ignore division by zero. This
-- doesn't give any spurious results since if we can get zero as one
-- of the arguments, we can legitimately create another zero by
-- multiplying.
(//) :: Rational -> Rational -> Rational
a // 0 = 0
a // b = a / b

-- turn a normal binary operator into a function which operates 
-- on the top two elements of a stack.
mkStackOp :: Op -> Stack -> Stack
mkStackOp op (x1:x2:xs) = (x2 `op` x1) : xs
mkStackOp op s = s

negateTop :: Stack -> Stack
negateTop (x:xs) = (negate x) : xs

-- operations that reduce a stack (i.e. binary operations)
stackReducers :: [Stack -> Stack]
stackReducers = map mkStackOp [(+), (-), (*), (//)]

-- operations that transform a stack without reducing it (unary
-- operations).  to allow unary negation, just add negateTop to the
-- list.
stackTransformers :: [Stack -> Stack]
stackTransformers = [id]

allStackOps = stackReducers ++ stackTransformers

-- build up a stack by adding one more element (applying all possible
-- stack transformers), while applying all possible operations to the
-- previous elements.
build :: Rational -> Stack -> [Stack]
build n []  =     [ f [n]             | f  <- stackTransformers ]
build n stk = nub [ f [n] ++ (f' stk) | f  <- stackTransformers,
                                        f' <- allStackOps       ]

-- perform one reduction on a stack in all possible ways.
reduce1 :: Stack -> [Stack]
reduce1 [x] = [[x]]
reduce1 stk = [ f stk | f <- stackReducers ]

-- like >>=, but discarding duplicates.  Ideally we would
--   do this with a Monad instance of Data.Set, but that's
--   currently not possible without doing some contortions
--   to redefine the Monad class (since currently there's no
--   way to define a monad over a subcategory of Haskell types,
--   like we would need to define a Data.Set monad over only
--   Eq types).  See http://www.randomhacks.net/articles/
--   2007/03/15/data-set-monad-haskell-macros.
l >>- f = nub $ concatMap f l

-- completely reduce a stack to a single number in all possible ways.
reduce :: Stack -> [Stack]
reduce [x] = [[x]]
reduce stk = reduce1 stk >>- reduce

-- build up stacks with the given rationals, then reduce.
buildAndReduce :: [Rational] -> Stack -> [Stack]
buildAndReduce [] = reduce
buildAndReduce (r:rs) = s -> (build r s >>- buildAndReduce rs)

-- given a list of starting numbers, return the list of all possible
-- results using arithmetic operators and parentheses on the numbers
-- in the given order.
results :: [Rational] -> [Rational]
results rs = sort $ concat $ buildAndReduce rs []

There’s a little ambiguity in the description of the problem: are we allowed to use – as prefix negation, or just as binary subtraction? The code above treats it only as binary subtraction. In that case we get 52 distinct results ranging from -5 = 4 – 3 * (2+1) to 36 = 4 * 3 * (2+1). 8 are negative, 28 are integers:

Prelude> :l fours
[1 of 1] Compiling Main             ( fours.hs, interpreted )
Ok, modules loaded: Main.
*Main> results [4,3,2,1]
[(-5)%1,(-3)%1,(-2)%1,(-5)%3,(-1)%1,(-2)%3,(-1)%2,(-1)%3,
0%1,1%3,4%9,1%2,4%7,2%3,4%5,1%1,4%3,3%2,8%5,5%3,
2%1,7%3,5%2,8%3,3%1,10%3,7%2,11%3,4%1,13%3,9%2,
5%1,11%2,6%1,13%2,7%1,8%1,9%1,10%1,11%1,12%1,13%1,
14%1,15%1,16%1,20%1,21%1,23%1,24%1,25%1,28%1,36%1]
*Main> length it
52
*Main> length $ filter ((1==) . denominator) $ results [4,3,2,1]
28
*Main> length $ filter (<0) $ results [4,3,2,1]
8

If we allow unary negation, then we get 87 distinct possibilities, 47 of which are integers (and, of course, exactly half of the nonzero possibilities are negative, since they are just the negations of the positive possibilities).

About these ads
This entry was posted in haskell, math, puzzle. Bookmark the permalink.

7 Responses to Solving an arithmetic puzzle with Haskell

  1. cdsmith says:

    Hmm, you seem to be missing (-23) = (1 – ((2 * 3) * 4)). In fact, I get 101 answers without unary negation.

    Here’s some (ridiculously unreadable) code to solve the problem.

    import Data.List
    bin f (a:b:xs) = (f a b):xs
    partials [x] = [[x]]
    partials (x:xs) = concatMap (addOp (x:)) (partials xs)
    addOp x p = x p : if (length p == 1) then [] else binR (addOp x) p
    finish p = if (length p == 1) then [head p] else binR finish p
    binR f p = concatMap (f . flip id p) [bin (+), bin (-), bin (*), bin (/)]
    ans = sort $ nub (concatMap finish (partials [1, 2, 3, 4]) :: [Rational])

  2. cdsmith says:

    Oops, never mind. Misread the problem.

  3. cdsmith says:

    Much closer now. You still seem to be missing:

    (-1)%5 = (4 / (3 + 2)) – 1
    19%1 = (4 * (3 + 2)) – 1
    9%5 = (4 / (3 + 2)) + 1

    code:

    import Data.List
    import Data.Maybe
    bin f (a:b:xs) = do { c

  4. cdsmith says:

    Trying this again:

    import Data.List
    import Data.Maybe
    bin f (a:b:xs) = do { c <- a; d <- b; Just $ (f c d) } :xs
    divide (a:b:xs) = do { c <- a; d <- b; Just $ if d == 0 then 0 else c / d } :xs
    partials [x] = [[Just x]]
    partials (x:xs) = concatMap (addOp ((Just x):)) (partials xs)
    addOp x p = x p : if (length p == 1) then [] else binR (addOp x) p
    finish p = if (length p == 1) then [head p] else binR finish p
    binR f p = concatMap (f . flip id p) [bin (+), bin (-), bin (*), divide]
    ans = catMaybes $ sort $ nub
    (concatMap finish (partials [4,3,2,1]) :: [Maybe Rational])

  5. Brent says:

    Oops, you’re right, I did miss some. I only managed to insert at most one postfix operation between each operand, which means I missed expressions such as (4 / (3 + 2)) – 1, i.e. 4 3 2 + / 1 -. Thanks for the fix, although I’m still trying to decipher your code. =)

  6. cdsmith says:

    Still trying to decipher my code? So am I! :)

    It’ll be easier if I explain the first version of my code (first comment), but you should replace bin (/) with your special division… and, of course, [1,2,3,4] with [4,3,2,1].

    Essentially, it’s working in prefix notation. The partials function processes a list and determines all possible stacks that might result from it. It stops when there are no more numbers to process. So, essentially, the operations are all on stacks, but in a right to left direction, so the computation is performed bottom up.

    binR acts as a sort of modified ($) operator, but unlike ($), it applies all four binary operators to the stack before passing it it to f. addOp, essentially, means generate all possibilities that end with a given function over the stack (which is always pushing a literal) and have some number of binary operations beforehand. finish means just do the binary operations until there’s only one stack term first. Both are defined in terms of binR.

    So then ans (the entry point to the whole thing) calls partials to get a list of all the stacks up to the point of pushing all the numbers, then calls finish to reduce them all to a single value, sorts, and displays them.

    Parts of it are fuzzy. I was, to some great extent, intentionally gaming the code to be very short. Clearly not good quality, but it was fun to write!

  7. Pingback: helping math make sense

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s