Archive for December, 2012

Programming Praxis – Three Wise Men

December 28, 2012

In today’s Programming Praxis exercise, our goal is to solve a puzzle in which both the addition and multiplication of three numbers results in 65.52. Let’s get started, shall we?

Assuming each item costs at least one penny, the most expensive item can be at most 65.50. By multiplying each amount by 100 we can avoid any potential inaccuracies resulting from using floating point numbers. By stating that a must be more expensive than b we remove some duplicates and reduce the search space. Once a and b are known c follows automatically, otherwise the addition would be incorrect. Finally, we check if the multiplication works. Since all three numbers have been multiplied by 100, the result must be 65.52 * 100^3.

main :: IO ()
main = print $ head [(a,b,c) | a <- [1..6550], b <- [1..a]
                             , let c = 6552 - a - b
                             , a * b * c == 65520000]

This gives us the amounts $2.00, $0.52 and $63.00. Clearly, two of the wise men are cheapskates.

Programming Praxis – Petals Around The Rose

December 18, 2012

In today’s Programming Praxis exercise, our goal is to implement the well-known “Petals Around the Rose” game. Let’s get started, shall we?

Some imports:

import Control.Monad
import System.Random
import Text.Printf

We’ll need to show the intro text.

showIntro :: IO ()
showIntro = putStrLn
  "Let's play 'Petals Around The Rose.'\n\
  \The name of the game is significant.\n\
  \At each turn I will roll five dice,\n\
  \then ask you for the score, which\n\
  \will always be zero or an even number.\n\
  \After you guess the score, I will tell\n\
  \you if you are right, or tell you the\n\
  \correct score if you are wrong. The game\n\
  \ends when you prove that you know the\n\
  \secret by guessing the score correctly\n\
  \six times in a row.\n"

When playing, we keep a count of the current streak length. After 6 consecutive correct guesses we assume the player has figured out the trick. Otherwise, we roll 5 dice and see if the player’s guess is correct.

play :: Int -> IO ()
play 6      = putStrLn "Congratulations! You are now a member\n\
                       \of the Fraternity of the Petals Around\n\
                       \The Rose. You must pledge never to\n\
                       \reveal the secret to anyone."
play streak = do
    dice <- replicateM 5 $ randomRIO (1,6)
    putStrLn $ "The five dice are: " ++ unwords (map show dice)
    putStr "What is the score? "
    guess <- readLn
    if guess == score dice
    then putStrLn "Correct\n" >> play (streak + 1)
    else printf "The correct answer is %d.\n\n" (score dice) >> play 0

And here’s the heart of the program: the score function. It’s pretty simple, once you know the secret.

score :: [Int] -> Int
score = sum . map ([0,0,0,2,0,4,0] !!)

To play a game, just show the intro and start playing.

main :: IO ()
main = showIntro >> play 0

Programming Praxis – 115132219018763992565095597973971522401

December 14, 2012

In today’s Programming Praxis exercise, our task is to calculate all the narcissistic numbers, also known als the Armstrong numbers or the pluperfect digital invariants, i.e. the sequence of numbers for which the sum of the cubes of the digits is equal to the number itself.

Supposedly, a mathematician by the name of Dik Winters developed an algorithm in 1985 that could generate all 88 numbers in about half an hour, which should theoretically run in seconds on modern day hardware. Unfortunately, neither Phil (the author of the Programming Praxis blog) nor I were able to find the original algorithm. The exercise provides a brute-force solution, which of course will not terminate in anything close to an acceptable time since the highest number in the sequence has 39 digits.

The solution I came up with in the end (after lots of different approaches to speed things up) is significantly faster than the naive brute-force solution, yet still nowhere close to the theoretical solution.

Some imports:

import Data.List
import qualified Data.Vector as V

Since calculating the full sequence takes too long, I added an argument to specify the maximum amount of desired digits for timing purposes.

narcissistic :: Integer -> [Integer]
narcissistic upto = narcs =<< [1..min 39 upto] \\ [2,12,13,15,18,22,26,28,30,36]

When generating the narcissistic numbers, we make a number of improvements to the brute-force algorithm:

  • Since the order of the digits doesn’t matter for the sum of cubes, we only look increasing series of digits, ruling out all permutations
  • Since the power function is relatively expensive, we precalculate all 10 possibilities into a lookup table
  • All digits sequences with a sum that is too low or high for an n-digit number are ignored
narcs :: Integer -> [Integer]
narcs n = sort $ f [] 0 9 n where
    powers = V.fromList $ map (^n) [0..9]
    pow i = powers V.! fromIntegral i
    (lo, hi) = (10^(n-1), 10^n)
    f ds s x 1 = [ s' | i <- [0..x], let s' = s + pow i, s' >= lo
                 , s' < hi, sort (show s') == (show =<< (i:ds))]
    f ds s x d = [0..x] >>= \i -> f (i:ds) (s + pow i) i (d-1)

With this approach, calculating the numbers of 1 through 16 digits takes about 3.4 seconds. 1 through 25 digits takes just over 4 minutes. I have no idea how long the full sequence would take. I’m sure there’s some way to eliminate more options using some mathematical proof, but I haven’t been able to find or come up with one.

main :: IO ()
main = mapM_ print $ narcissistic 16

Programming Praxis – Stepwise Program Development: A Heuristic Algorithm

December 11, 2012

In today’s exercise, our goal is to write an algorithm that, given an alphabet and a length, generates all possible sequences that do not have two adjacent indentical subsequences. Let’s get started, shall we?

Some imports:

import Control.Monad
import Data.List

We build up the list of possible sequences from the end. Whenever we add a character we check that we do not generate a repeated subsequence. This bit could be optimised a little since checking past the first half of the list is pointless, but performance wasn’t a problem so I didn’t bother. Although not explicitly stated in the problem description, two sequences are considered identical if one can be obtained by permuting the other’s alphabet, e.g. 123 is considered the same thing as 321. Therefor we add the criterium that in the final list of permutations all unique characters must occur in ascending order.

nonAdjacent :: Ord a => [a] -> Int -> [[a]]
nonAdjacent xs = sort . filter (and . zipWith (==) xs . nub) . f where
    f 0 = [[]]
    f n = filter (\x -> not . or . tail $ zipWith isPrefixOf (inits x) (tails x)) $
          liftM2 (:) xs (f $ n - 1)

Some tests to see if everything is working properly:

main :: IO ()
main = do mapM_ putStrLn $ nonAdjacent "123" 5
          mapM_ putStrLn $ nonAdjacent "123" 12
          mapM_ putStrLn $ nonAdjacent "123" 20

Programming Praxis – Wirth Problem 15.12

December 7, 2012

In today’s Programming Praxis exercise, our goal is to generate the first 100 terms of a mathematical set defined by Niklaus Wirth. Let’s get started, shall we?

A quick import:

import Data.List.Ordered

Thanks to Haskell’s lazy evaluation, we can simply define the set recursively and we don’t have to bother with a queue of items. Initially I just wrote out the union function (which merges two ascending lists in ascending order) my self, but I then I figured that there was probably a library somewhere that had this function.  A bit of googling revealed Data.List.Ordered.

m :: [Integer]
m = 1 : union (map ((+1) . (*2)) m) (map ((+1) . (*3)) m)

All that’s left to do is to take the first 100 elements of the sequence.

main :: IO ()
main = print $ take 100 m

Programming Praxis – Median Of Five

December 4, 2012

In today’s Programming Praxis exercise, our goal is to determine to median of five numbers using only six comparisons. Let’s get started, shall we?

A quick import:

import Data.List

I didn’t like the element swapping and nested ifs of the provided algorithm, so I tried to come up with something a litte more in the spirit of functional programming. I was initially worried that the case statement would evaluate all three comparisons when the the first one was false, but some testing revealed that Haskell is lazy enough to skip the second comparison in that case.

median5 :: Ord a => [a] -> a
median5 ~[a',b',c,d',e'] = case (b<c, b<d, d<c) of
        (True, True , _    ) -> min c d
        (True, False, _    ) -> min b e
        (False, _   , True ) -> min c e
        (False, _   , False) -> min b d
    where ((_,b), (d,e)) = order (order a' b') (order d' e')
          order x y = if y < x then (y,x) else (x,y)

All that’s left to do is to verify that all permutations of the numbers 1 to 5 result in 3 as the median.

main :: IO ()
main = print . all ((== 3) . median5) $ permutations [1..5]