Posts Tagged ‘puzzle’

Programming Praxis – A Programming Puzzle

June 28, 2013

In today’s Programming Praxis exercise, our goal is to write a function such that f (f n) = -n. Let’s get started, shall we?

My first instinct was to define f as a 90 degree rotation using the complex plane, but decided that that was against the spirit of the exercise. The input is plain integers, so the output shouldn’t consist of complex numbers. After that I mucked around for a good while with doubling and halving numbers, which worked on everything except multiples of four. The basic idea (reversing parity and/or signs) was correct, but halving numbers always produced cases where the same condition holds for n and f(n). About an hour and a half after starting on the exercise the solution finally hit me: simply swap each pair of adacent numbers and reverse the sign for the even ones. I replaced the first draft of the correct solution, which had the four conditions written out, with the following more elegant formula.

f :: Integer -> Integer
f n = n * (2 * mod n 2 - 1) + signum n

A test to see if everything is working properly:

main :: IO ()
main = print $ all (\n -> f (f n) == -n) [-1000..1000]

Programming Praxis – NPR Sunday Puzzle

February 19, 2013

In today’s Programming Praxis exercise, our goal is to find two words that consist of the letters A through F and two other letters. Let’s get started, shall we?

import Data.List

Checking if a word is valid is a simple matter of checking whether it has eight letters and whether it contains all six required letters.

npr :: String -> Bool
npr s = length s == 8 && null ("abcdef" \\ s)

With that out of the way, all that’s left to do is to search all the words in the ddictionary for the ones the satisfy the criterium.

main :: IO ()
main = mapM_ print . filter npr . lines =<< readFile "en_US.dic"

As expected, the only words found are boldface and feedback.

Programming Praxis – The 147 Puzzle

February 5, 2013

In today’s Programming Praxis exercise, our goal is to find all combinations of five numbers whose inverses sum up to one. Let’s get started, shall we?

Since we’re working with exact fractions, the Ratio library is an obvious fit.

import Data.Ratio

We solve the problem recursively so that the algorithm will work on other amounts of numbers as well. Once we’ve chosen all but the last number, that remainder must have a numerator of one. For the rest, just try all possibilities that still leave a large enough remainder for the rest, keeping track of the previous choice to prevent duplicates (each choice must be more than or equal to the previous choice.)

puzzle :: Integer -> [[Integer]]
puzzle k = f 2 (k%1) 1 where
    f _ 1 r = if numerator r == 1 then [[denominator r]] else []
    f p n r = concat [map (x : ) $ f x (n-1) r'
                     | x <- [p..floor $ n/r], let r' = r - 1%x, r' > 0]

While writing the solution, I also came up with some variations that worked fine for k = 5, but were very slow for k = 6. To prevent this we test both of them.

main :: IO ()
main = do print . (== 147) . length $ puzzle 5
          print . (== 3462) . length $ puzzle 6

Programming Praxis – Ullman’s Puzzle

December 7, 2010

In today’s Programming Praxis exercise, our task is to write a solution to Ullman’s puzzle, which is to check whether there exists a subsequence of exactly length k of a series of real numbers that sums up to less than a given t. Let’s get started, shall we?

A quick import:

import Data.List

Today’s exercise is a short one. My first attempt was basically converting the problem statement into Haskell syntax:

ullman :: (Num a, Ord a) => a -> Int -> [a] -> Bool
ullman t k = any (\s -> length s == k && sum s < t) . subsequences

The Scheme solution uses a more efficient algorithm, so for the sake of completeness we’ll translate that into Haskell as well. This one runs in O(n log n) rather than O(n!) and it’s shorter to boot.

ullman2 :: (Ord a, Num a) => a -> Int -> [a] -> Bool
ullman2 t k = (< t) . sum . take k . sort

Some tests to see if everything is working properly:

main :: IO ()
main = do let xs = [18.1,55.1, 91.2, 74.6, 73.0, 85.9, 73.9, 81.4,
                    87.1, 49.3, 88.8, 5.7, 26.3, 7.1, 58.2, 31.7,
                    5.8, 76.9, 16.5, 8.1, 48.3, 6.8, 92.4, 83.0, 19.6]
          let ys = [3, 4, 3]
          print $ ullman 98.2 3 xs
          print $ ullman2 98.2 3 xs
          print . not $ ullman 5 2 ys
          print . not $ ullman2 5 2 ys

Looks like it is.

Programming Praxis – 145 Puzzle

April 20, 2010

In today’s Programming Praxis exercise we have to solve a math puzzle. The provided solution is 15 lines, not counting the parser to evaluate the generated strings. Let’s see if we can bring that down a bit.

Some imports:

import Control.Applicative
import qualified Data.List.Key as K
import Text.Parsec

Generating the expressions is pretty simple. If we have at least one digit, prepend the first digit to all the possible expressions for the remaining digits with either nothing or a plus or minus sign in between. If we only have one digit, that digit is the only option.

exprs :: String -> [String]
exprs (x:y:ys) = [x:o++z | o <- ["","+","*"], z <- exprs $ y:ys]
exprs xs       = [xs]

Since we now have more control over the input string (no spaces, subtraction or division), we can make last week’s parser slightly more compact.

eval :: String -> Int
eval = either (const 0) id . parse expr "" where
    expr = chainl1 term ((+) <$ char '+')
    term = chainl1 (read <$> many1 digit) ((*) <$ char '*')

Finding the required statistics is pretty trivial. Just group the expressions by their evaluated results and find the most common one.

main :: IO ()
main = do let mf = K.maximum length . snd . K.sort snd .
                   liftA2 zip id (map eval) $ exprs ['1'..'9']
          print (snd $ head mf, length mf)
          mapM_ putStrLn $ map fst mf

Six lines, not counting the parser. Not bad.

Programming Praxis – $7.11

November 27, 2009

Today’s Programming Praxis problem is an easy one.  We’re supposed to give the prices of four items, that both sum up and multiply to $7.11. Let’s get started.

While we could just do a brute force test on all possible combinations, this would take rather long. So in order to speed things up we only check numbers that are a proper divisor of $7.11.

divs :: [Int]
divs = [x | x <- [1..711], mod (711 * 10^6) x == 0]

Once we have the divisors, solving the problem becomes a fairly trivial list comprehension (the <= bits are another optimization to eliminate some identical combinations).

main :: IO ()
main = print [(a,b,c,d) | a <- divs,         b <- divs, b <= a,
                          c <- divs, c <= b, d <- divs, d <= c,
                          a + b + c + d == 711,
                          a * b * c * d == 711 * 10^6]

If we run this, we find there is only one combination that satisfies both requirements.

Programming Praxis – Feynman’s Puzzle

June 12, 2009

Today’s Programming Praxis problem is about a long division puzzle by Richard Feynman. The provided solution is 14 lines of code. Since both his and my solution are little more than a simple list comprehension, there is not going to be much room for improvement, but let’s see what we can do.

We need a way to refer to specific digits of numbers. The provided solution does so by converting the number to a list of digits. This function just returns the nth digit of a number, starting with the least significant one. For instance, digit 1 1234 equals 4.

digit :: Int -> Int -> Int
nth `digit` n = n `mod` 10 ^ nth `div` 10 ^ (nth - 1)

As mentioned, this problem is most naturally solved with a list comprehension, so that is what we will use as well. The actual conditions are of course nearly identical to the scheme version, with the exception that the condition that a * n1 has four digits is unnecessary, and therefore removed in this version.

feinman :: [(Int, Int)]
feinman = [ (n1, n2)
          | b <- [1..9], a <- [0..9], c <- [0..9],
            d <- [1..9], e <- [0..9], f <- [0..9],
            a /= b, a /= c, a /= d, a /= e, a /= f, e < d,
            let n1 = 100 * b + 10 * a + c,
            let n2 = 1000 * d + 100 * e + 10 * a + f,
            n1 * n2 > 999999, n1 * n2 < 10000000,
            digit 3 (n1 * n2) == a,
            digit 1 (d * n1) == a, digit 2 (d * n1) == a,
            digit 1 (e * n1) == a, digit 3 (a * n1) == a]

To test, we just print the list.

main :: IO ()
main = print feinman

As expected, we get the single result of (484, 7289). Runtime is about 8.5 seconds in ghci and 60 ms compiled (You’ve got to love compilers). The end result is 11 lines of code, so a slight improvement over the scheme version.