Archive for July, 2012

Programming Praxis – SEND + MORE = MONEY, Part 1

July 31, 2012

In today’s Programming Praxis exercise, our goal is to provide two different solutions for the well known SEND + MORE = MONEY sum, in which each letter must be replaced by a valid digit to yield a correct sum. Let’s get started, shall we?

A quick import:

import Data.List

I’ll be honest, the only reason I wrote this first solution this way is because the exercise explicitly called for checking all possible solutions using nested loops. It’s so horribly inefficient! Take the test whether all digits are unique for example: normally you’d remove each chosen digit from the list of options for all subsequent ones, but we’re not allowed to do that. I normally also wouldn’t do the multiplications this explicitly, but to avoid overlap with the second solution I left it like this. Unsurprisingly, it takes almost a minute and a half to run.

send1 :: ([Integer], [Integer], [Integer])
send1 = head [([s,e,n,d], [m,o,r,e], [m,o,n,e,y])
             | s <- [1..9], e <- [0..9], n <- [0..9], d <- [0..9]
             , m <- [1..9], o <- [0..9], r <- [0..9], y <- [0..9]
             , length (group $ sort [s,e,n,d,m,o,r,y]) == 8
             , 1000*(s+m) + 100*(e+o) + 10*(n+r) + d+e ==
               10000*m + 1000*o + 100*n + 10*e + y]

This is actually the solution I started with: since all digits need to be unique, you can simply generate the permutations of the numbers 0 through 9, backtracking when s or m are zero or when the numbers don’t add up correctly. By writing a function to do the multiplication and assinging some variables we not only make things more readable, but we also get to use the problem statement directly in the code, which I find conceptually satisfying. I do have the distinct impression that this is what we’re supposed to make in part 2 of this exercise though, since it runs in about a second, which is significantly faster than the two provided solutions.

send2 :: (Integer, Integer, Integer)
send2 = head [ (send, more, money) | (s:e:n:d:m:o:r:y:_) <- permutations [0..9]
             , s /= 0, m /= 0, let fill = foldl ((+) . (* 10)) 0
             , let send = fill [s,e,n,d], let more = fill [m,o,r,e]
             , let money = fill [m,o,n,e,y], send + more == money]

A quick test shows that both algorithms produce the correct solution.

main :: IO ()
main = do print send1
          print send2

Programming Praxis – Min Stack

July 27, 2012

In today’s Programming Praxis exercise, our goal is to create s stack-like data structure that can push, pop and give the minimum element in the stack in O(1). Let’s get started, shall we?

To represent a stack, we can use a basic linked list. We’ll need two of them, one to hold the elements and one to hold the consecutive minimums. I’ve put them in a tuple, though a datatype declaration would’ve been an option as well.

An empty minstack is just two empty lists.

empty :: ([a], [a1])
empty = ([], [])

When pusing a new element we add it at the front of the list and optionally in the list of minimums as well.

push :: Ord a => a -> ([a], [a]) -> ([a], [a])
push x (ms,xs) = (if null ms || x < head ms then x:ms else ms, x: xs)

To pop, we return the popped element (if any) and the new minstack.

pop :: Eq a => ([a], [a]) -> (Maybe a, ([a], [a]))
pop (m:ms,x:xs) = (Just x, (if m == x then ms else m:ms, xs))
pop s           = (Nothing, s)

To find the minimum element we simple take the first element in the list of minimums.

min' :: ([a], [a]) -> Maybe a
min' (m:_, _) = Just m
min' _        = Nothing

Some tests to see if everything is working properly:

main :: IO ()
main = do let top = fst . pop
          let pop' = snd . pop
          let a = push 5 . push 4 $ push 3 empty
          print $ top a == Just 5
          print $ min' a == Just 3
          let b = push 2 $ push 1 a
          print $ top b == Just 2
          print $ min' b == Just 1
          let c = pop' . pop' $ pop' b
          print $ top c == Just 4
          print $ min' c == Just 3
          let d = pop' $ pop' c
          print $ d == empty

Programming Praxis – Zeckendorf Representation

July 24, 2012

In today’s Programming Praxis exercise, our goal is to find a series of non-consecutive fibonacci numbers that sum up to a given number. Let’s get started, shall we?

First, we define the fibonacci sequence:

fibs :: [Integer]
fibs = 1 : scanl (+) 1 fibs

The algorithm to find the numbers is pretty trivial as well: take the largest fibonacci number less than or equal to the target value and repeat on the remainder.

zeck :: Integer -> [Integer]
zeck 0 = []
zeck n = f : zeck (n - f) where f = last $ takeWhile (<= n) fibs

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ zeck 100 == [89,8,3]
          print $ zeck (3^15) == [9227465, 3524578, 1346269,
                                  196418, 46368, 6765, 987, 55, 2]
          print $ zeck $ 10^100

Programming Praxis – Infix Expression Evaluation

July 20, 2012

In today’s Programming Praxis exercise, our goal is to write a function to evaluate mathematical expressions. Let’s get started, shall we?

Basically this exercise boils down to writing a small parser. As always, Parsec is my go-to library for this task.

import Control.Applicative ((<$), (<$>))
import Text.Parsec
import Text.Parsec.Expr
import Text.Parsec.Language
import Text.Parsec.Token

Since parsing mathematical expressions is such a common task, Parsec has some built-in functionality for it. Also, I’m using lexeme parsers so I don’t have to manually deal with whitespace. The reason for choosing the mondrian token parser rather than haskell is that — in Haskell signifies a comment, whereas in this case it means subtracting a negative number. Obviously I could just use the haskell definition and modify the commentLine string, but this was shorter. The reason for using a custom number parser instead of the default one for natural numbers is that we must also deal with numbers in which the digits are separated by whitespace.

eval :: String -> Either ParseError Double
eval = parse expr "" where
    expr  = buildExpressionParser table term
    term  = parens mondrian expr <|> (read <$> many1 (lexeme mondrian digit))
    table = [ [prefix "-" negate]
            , [binary "*" (*), binary "/" (/) ]
            , [binary "+" (+), binary "-" (-) ]
            ]
    prefix name fun = Prefix (fun <$ symbol mondrian name)
    binary name fun = Infix  (fun <$ symbol mondrian name) AssocLeft

To see if everything is working properly, we have a decent-sized test suite:

main :: IO ()
main = mapM_ (print . (\(a,b) -> either (const False) (== b) $ eval a))
           [ ("123",         123)
           , ("-123",        -123)
           , ("(123)",       123)
           , ("(((123)))",   123)
           , ("1 2 3",       123)
           , ("1+2",         1 + 2)
           , ("1+-2",        1 + (-2))
           , ("1-2",         1 - 2)
           , ("1--2",        1 - (-2))
           , ("2*3",         2 * 3)
           , ("2*-3",        2 * (-3))
           , ("2/3",         2 / 3)
           , ("2/-3",        2 / (-3))
           , ("2*3+4",       2 * 3 + 4)
           , ("2-3*4",       2 - 3 * 4)
           , ("2/3+4",       2 / 3 + 4)
           , ("2-3/4",       2 - 3 / 4)
           , ("2*(3+4)",     2 * (3 + 4))
           , ("(2-3)*4",     (2 - 3) * 4)
           , ("2/(3+4)",     2 / (3 + 4))
           , ("(2-3)/4",     (2 - 3) / 4)
           , ("1+2+3+4",     1 + 2 + 3 + 4)
           , ("1-2-3",       1 - 2 - 3)
           , ("1*2*3*4",     1 * 2 * 3 * 4)
           , ("1/2/3",       1 / 2 / 3)
           , ("123+456*789", 123 + 456 * 789)
           ]

Programming Praxis – The Evolution Of Flibs

July 13, 2012

In today’s Programming Praxis exercise, our goal is to implement a genetic algorithm to evolve finite state machines that predict repeating sequences. The solution is one of the longest ones in quite a while, so let’s get started, shall we?

Some imports:

import Control.Monad
import Data.List
import System.Random

First we need something to keep track of the allowable states and inputs. When I wrote it I didn’t quite know how many arguments where going to end up in it, so I made it a datatype rather than a tuple. A difference with the Scheme solution is that the characters used for the state are customisable. It doesn’t serve much purpose, but it allows things to be a bit more generic.

data Args = Args { _symbols :: String, _numSymbols :: Int
                 , _states  :: String, _numStates :: Int }

I started with the function to run a flib since I wanted to know if I understood them correctly. Initially I stored the table in a Map, but after a while I found that keeping them as strings would require less conversion and code when displaying, generating and mutating them.

runFlib :: Args -> (Char, String) -> Char -> ((Char, String), Char)
runFlib (Args smbs nsmbs sts _) (s, m) input = ((s',m), out) where
    (out:s':_) = drop (2 * (nsmbs * index s sts + index input smbs)) m
    index x    = head . elemIndices x

For the score function we cycle the input to the given length and check how many times the next item is predicted correctly.

score :: Int -> Args -> String -> String -> Int
score run args flib input = length . filter id . zipWith (==) (tail input') .
    snd . mapAccumL (runFlib args) (head $ _states args,flib) $ init input'
    where input' = take (run + 1) $ cycle input

Two generic functions we need later on: oneOf chooses a random element of a given list and replace replaces the element with the given index in a list with the new value.

oneOf :: [a] -> IO a
oneOf xs = fmap (xs !!) $ randomRIO (0, length xs - 1)

replace :: Int -> a -> [a] -> [a]
replace i v xs = take i xs ++ v : drop (i + 1) xs

To generate a random flib we simply concatenate the appropriate number of inputs and states.

randomFlib :: Args -> IO String
randomFlib (Args smbs nsmbs sts nsts) = fmap concat $
    replicateM (nsmbs * nsts) (sequence [oneOf smbs, oneOf sts])

To breed two flibs we take the beginning and/or end of one flib and insert the middle of the other.

crossover :: Args -> String -> String -> IO String
crossover (Args _ nsmbs _ nsts) a b = do
    start <- randomRIO (0,         2 * nsmbs * nsts - 2)
    end   <- randomRIO (start + 1, 2 * nsmbs * nsts - 1)
    return $ take start a ++ take (end - start) (drop start b) ++ drop end a

To mutate a flib we replace a random character with a new one of the correct type.

mutate :: Args -> String -> IO String
mutate (Args smbs nsmbs sts nsts) flib = do
    i <- randomRIO (0, 2 * nsmbs * nsts - 1)
    c <- oneOf $ if mod i 2 == 0 then smbs else sts
    return $ replace i c flib

Finally, we have to function that does the actual work of testing and changing the different generations. First we create a random population of the desired size. Each generation, we calculate all the scores, print the best one if it’s an improvement, potentially breed to best and worst flibs, mutate one of the elements and repeat the whole process until we have found one that can correctly predict the entire sequence.

evolve :: String -> Int -> Float -> Int -> String -> IO ()
evolve states popSize breedChance run input =
    nextGen (0, "") =<< replicateM popSize (randomFlib args) where
    args = Args (map head symbols) (length symbols)
                states  (length . group $ sort states)
                where symbols = group $ sort input
    nextGen (top,_) _ | top == run = return ()
    nextGen best pop = do
        let scored = sort $ map (\flib -> (score run args flib input, flib)) pop
        let top = last scored
        breed <- fmap (< breedChance) $ randomRIO (0, 1)
        mix <- crossover args (snd $ head scored) (snd top)
        let newPop = (if breed then replace 0 mix else id) (map snd scored)
        mutIndex <- randomRIO (0, popSize - 1)
        mutant <- mutate args (newPop !! mutIndex)
        when (fst top > fst best) (print top)
        nextGen (max best top) $ replace mutIndex mutant newPop

A test to see if everything is working properly:

main :: IO ()
main = evolve "ABCD" 10 0.3 100 "010011"

Programming Praxis – Sieving For Totients

July 10, 2012

In today’s Programming Praxis exercise, our goal is to calculate the totients of a given range of numbers using a sieve. Let’s get started, shall we?

Due to the way I structured my code, Data.Map is a little more convenient than Data.Vector (since Data.Vector lacks the equivalent of the adjust function).

import qualified Data.Map as M

The sieving can be solved easily with two folds. The outer one to check all the elements in the list, and the inner one to update all the multiples of a given index. One space-saving trick is to realize that you don’t need to treat i and its multiples differently, since i * (1 – 1/i) = i – i/i = i – 1. This saves a separate insert call.

totients :: Integral a => a -> [a]
totients n = M.elems $ foldl (\m i -> if m M.! i == i
    then foldr (M.adjust (\x -> div (x*(i-1)) i)) m [i,2*i..n] else m)
    (M.fromList $ zip [0..n] [0..n]) [2..n]

A test to see if everything is working properly:

main :: IO ()
main = print $ totients 100

Programming Praxis – Fractran

July 6, 2012

In today’s Programming Praxis exercise, our goal is to write an interpreter for the esotreric programming language Fractran and use it to execute a program that generates prime numbers. Let’s get started, shall we?

A quick import:

import Data.List

The fractran interpreter itself is pretty simple. We use tuples to represent the fractions rather than Ratios since this made for slightly more elegant code. Unfortunately the Prelude doesn’t have a function to swap the values of a tuple, or I could’ve use divMod rather than having to repeat the multiplication.

fractran :: [(Integer, Integer)] -> Integer -> [Integer]
fractran xs = unfoldr (\m -> fmap ((,) m) . lookup 0 $
    map (\(n,d) -> (mod (m*n) d, div (m*n) d)) xs)

Since we’re using tuples, we represent the primegame program as a zip.

primegame :: [(Integer, Integer)]
primegame = zip [17,78,19,23,29,77,95,77, 1,11,13,15,15,55]
                [91,85,51,38,33,29,23,19,17,13,11,14, 2, 1]

Finding the primes is a matter of finding the terms in the output of fractran primegame 2 that are powers of two.

primes :: [(Integer, Integer)]
primes = [(i,e) | (i,n) <- zip [1..] $ fractran primegame 2
                , let e = round $ log (fromIntegral n) / log 2, 2^e == n]

A test to see if everything is working properly:

main :: IO ()
main = mapM_ print $ take 26 primes

Programming Praxis – Chopping Words

July 3, 2012

In today’s Programming Praxis exercise, our goal is to reduce a word one letter at a time, where each step must be a new valid word. Let’s get started, shall we?

Some imports:

import Data.Char
import Data.List

First we need a function to determine all the valid words that are one letter shorter.

chop :: Eq a => [[a]] -> [a] -> [[a]]
chop dict xs = filter (`elem` dict) $ zipWith (++) (inits xs) (tail $ tails xs)

Next, we apply this function recursively as long as the remaining word consists of two or more letters. We keep a list of the steps we took.

chain :: Eq a => [[a]] -> [a] -> [[[a]]]
chain dict xs@(_:_:_) = map (xs :) . chain dict =<< chop dict xs
chain _    xs         = [[xs]]

To test if everything is working properly, we load a dictionary (making sure to convert it to lowercase) and print the results for the word “planet”.

main :: IO ()
main = do dict <- fmap (lines . map toLower) $ readFile "74550com.mon"
          mapM_ print $ chain dict "planet"

We get 44 results instead of the 40 Phil got, which seems to be due to the presence of the word “ne” in my word list.