Programming Praxis – $7.11

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 – Master Mind, Part 1

…aaaand we’re back. Sorry for the delay, life can get really busy. In yesterday’s Programming Praxis problem we have to create a program that will answer guesses for the game Master Mind. Let’s get to it, shall we?

As usual, some imports:

import Data.List
import System.Random

First, we need a function to determine how good the player’s guess was:

match :: [Int] -> [Int] -> String
match code guess = concat $ zipWith replicate [bs, ws, ds] "BW."
    where bs = length . filter id $ zipWith (==) code guess
          ds = length (foldr delete code guess)
          ws = length code - bs - ds

Next, we write the guess loop:

go :: [Int] -> IO ()
go code = do hits <- fmap (match code) readLn
             if all (== 'B') hits then putStrLn "You Win!"
                else putStr (hits ++ "\nTry again: ") >> go code

A game can be started either with a predefined code or a random one if none has been provided.

play :: Maybe [Int] -> IO ()
play code = do putStr "Enter your guess as a list: "
               rnd <- fmap (take 4 . randomRs (1, 8)) getStdGen
               go $ maybe rnd id code

To test, start a game with a random code:

main :: IO ()
main = play Nothing

And that’s it for this week. Have fun playing!

Programming Praxis – Two Sub-Quadratic Sorts

In yesterday’s Programming Praxis problem we have to implement two sort algorithms. Let’s get started.

First, some imports:

import Control.Monad
import Data.List
import Data.List.HT
import Data.Array.IO
import Data.Array.MArray

For the Comb sort algorithm, we’re going to need a function to swap two elements of an array.

swap :: (MArray a e m, Ix i, Ord e) => i -> i -> a i e -> m ()
swap i j a = do x <- readArray a i
                y <- readArray a j
                when (y < x) $ writeArray a i y >> writeArray a j x

The Comb sort algorithm itself:

combSort :: Ord a => [a] -> IO [a]
combSort [] = return []
combSort xs = comb (s-1) =<< newListArray (1, s) xs where
    comb :: Ord a => Int -> IOArray Int a -> IO [a]
    comb 0 a = getElems a
    comb n a = mapM_ (\i -> swap i (i+n) a) [1..s-n] >> comb (n-1) a
    s = length xs

We don’t need array access for the Shell sort algorithm, so that saves some code. It’s in the IO monad so we can use the same test function, but the algorithm itself is pure.

shellSort :: Ord a => [a] -> IO [a]
shellSort [] = return []
shellSort xs = return $ shell (last . takeWhile (< length xs) $
                               iterate (succ . (*3)) 1) xs where
    shell 1 = foldr insert []
    shell n = shell (div (n-1) 3) . concatMap (shell 1) . sliceHorizontal n

A little test harness to see of everything’s working:

test :: ([Int] -> IO [Int]) -> IO ()
test f = do print . null =<< f []
            print . (== [1..9]) =<< f [4,7,3,9,1,5,2,6,8]

main :: IO ()
main = do test combSort
          test shellSort

Looks like it is.

Programming Praxis – Growable Arrays

Due to another conference (can’t they distribute them a bit more evenly around the year?) I won’t be here for the next three exercises.

In today’s Programming Praxis we’re going to implement a growable array, which is a data structure with logarithmic access where elements can be added without needing reallocation. Basically it’s little more than a binary tree. Let’s get started.

We’ll use a fairly standard binary tree for our data structure:

data Grow a = Empty | Grow { val :: a, l :: Grow a, r:: Grow a }

Next, we want a function that handles taking the correct branches, since we don’t want to have to repeat ourselves.

walk :: (Int -> Grow a -> b) -> Int -> Grow a -> b
walk f i = f (div i 2) . if even i then l else r

We also define another convenience function that handles updating the tree. Unfortunately Haskell doesn’t have first class records yet, so there is some duplication of logic here.

modify :: Grow a -> (Int -> Grow a -> Grow a) -> Int -> Grow a -> Grow a
modify d _ _ Empty         = d
modify _ f i g | even i    = g { l = walk f i g }
               | otherwise = g { r = walk f i g }

Now for the three functions we had to implement: get, put and hirem. Thanks to walk and modify, these are all fairly trivial.

get :: Int -> Grow a -> Maybe a
get _ Empty = Nothing
get 1 g     = Just $ val g
get i g     = walk get i g

put :: Int -> a -> Grow a -> Grow a
put 1 x Empty = Grow x Empty Empty
put 1 x g     = g { val = x }
put i x g     = modify (error "array out of bounds") (`put` x) i g

hirem :: Int -> Grow a -> Grow a
hirem 1 = const Empty
hirem i = modify Empty hirem i

And of course we have to test if we made any mistakes:

main :: IO ()
main = do let arr = foldl (flip (uncurry put)) Empty $ zip [1..]
                    ["alfa", "bravo", "charlie", "delta",
                     "echo", "foxtrot", "golf"]
          print $ get 7 arr
          print $ get 12 arr
          print . get 7 $ hirem (size arr) arr
       where size Empty = 0
             size g     = 1 + size (l g) + size (r g)

Looks like everything is working correctly. See you guys in two weeks!

Programming Praxis – Bifid Cipher

Today’s Programming Praxis problem is another cipher, specifically Bifid’s cipher. Let’s get started, shall we?

Some imports:

import Data.Char
import Data.List
import Data.List.HT hiding (unzip)
import Data.Map ((!), fromList)

There’s no J in the Bifid alphabet.

alphabet :: String
alphabet = delete 'J' ['A'..'Z']

Next we need some functions to get the index from a character and vice versa. The second line in fromIndex is only to get rid of a compiler warning; you can leave it out if you want to.

indices :: [(Int, Int)]
indices = zip (concatMap (replicate 5) [1..5]) (cycle [1..5])

toIndex :: Char -> (Int, Int)
toIndex c = fromList (zip alphabet indices) ! c

fromIndex :: [Int] -> Char
fromIndex [x, y] = fromList (zip indices alphabet) ! (x, y)
fromIndex _      = undefined

Next, we need a way to prepare the strings for the algorithm.

prepare :: String -> String
prepare = filter (`elem` alphabet) . replace "J" "I" . map toUpper

The basic structure of encode and decode is the same, only the way of getting the intermediate data in the right order differs.

encode :: String -> String
encode = map fromIndex . sliceVertical 2 . uncurry (++) .
         unzip . map toIndex . prepare

decode :: String -> String
decode xs = map fromIndex . sliceHorizontal (length xs) .
            concatMap ((\(x, y) -> [x, y]) . toIndex) $ prepare xs

And, as usual, some tests to see if everything’s working properly:

main :: IO ()
main = do print $ encode "BONSAICODE"
          print . decode $ encode "BONSAICODE"

Looks like it is. Another one down.

Programming Praxis – Calculating Pi

In today’s Programming Praxis problem we have to implement two ways of calculating pi. Let’s get started, shall we?

Some imports:

import Control.Monad
import System.Random

The first algorithm is the Monte Carlo method. Sadly, the need for monads and the int-float conversion make this code less concise than it could be.

monteCarloPi :: Int -> IO ()
monteCarloPi n = do
    hits <- fmap sum $ liftM2 (zipWith checkHit) rs rs
    print $ fromIntegral hits / fromIntegral n
    where rs = replicateM n $ randomRIO (0,1 :: Double)
          checkHit x y = if x*x + y*y < 1 then 4 else 0

Next up is Archimedes’ algorithm.

boundPi :: Int -> (Double, Double)
boundPi n = iterate f (3/2 * sqrt 3, 3 * sqrt 3) !! (n - 1)
            where f (b, a) = let x = 2 / (1 / a + 1 / b)
                             in (sqrt $ b * x, x)

A quick test to see if everything is working correctly:

main :: IO ()
main = do monteCarloPi 10000
          print $ boundPi 6

Everything seems to be in order. Of course, we could just say

main = print pi

Programming Praxis – MapReduce

In today’s Programming Praxis exercise, we have to implement the famous MapReduce algorithm. Let’s get going, shall we?

First, some imports:

import Control.Arrow
import Data.Char
import Data.List
import qualified Data.Map as M

Since I wasn’t here for the Red-Black Tree exercise, I’ll just use Maps.

mapReduce :: Ord k => (a -> (k, v)) -> (v -> v -> v) ->
                      (k -> k -> Bool) -> [a] -> [(k, v)]
mapReduce m r lt = sortBy (\(a,_) (b,_) -> if lt a b then LT else GT) .
                   M.assocs . M.map (foldl1 r) .
                   M.fromListWith (++) . map (second return . m)

With that, the version that works on files is trivial.

mapReduceInput :: Ord k => (a -> (k, v)) -> (v -> v -> v) ->
    (k -> k -> Bool) -> (String -> [a]) -> FilePath -> IO [(k, v)]
mapReduceInput m r lt g = fmap (mapReduce m r lt . g) . readFile

In order to test our algorithm, let’s reproduce the tests from Programming Praxis:

anagrams = map snd . mapReduce (sort &&& id) (\a b -> a ++ " " ++ b) (<)

getWords = concat . zipWith (\i -> map (\w -> (w, [i])) . words) [1..] .
           map (map clean) . lines where
           clean c = if isAlphaNum c || isSpace c then c else ' '

xref = mapReduceInput id (flip union) (<) getWords

main = do print $ mapReduce (\x -> (x, 1)) (+) (<) "banana"
          print $ anagrams ["time", "stop", "pots", "cars", "emit"]
          print =<< xref "mapreduce.txt"

Everything’s working correctly.

Programming Praxis – Grep

Before we begin, a small note: I’ll be on conference in Istanbul next week, so I won’t be here for the next two exercises.

In today’s Programming Praxis exercise we’re supposed to implement grep based on the regex matching functions we wrote in previous exercises. Let’s get started.

First, some imports.

import System.Environment
import Text.Printf

Obviously, we’re going to need the code we wrote in the previous two exercises.

--Code from the previous two exercises goes here

grepString shows all the lines of the input that (don’t) contain the regular expression, prefixed by the filename if one is provided.

grepString :: Bool -> Maybe String -> [Chunk] -> String -> IO ()
grepString b p cs = mapM_ (printf "%s%s\n" $ maybe "" (++ ": ") p) .
                    filter ((== b) . match cs) . lines

grep searches all the given files, or the standard input if none are provided, for the regular expression.

grep :: Bool -> [String] -> IO ()
grep _ []     = error "Not enough arguments provided"
grep b (r:ps) = either print (f ps) $ parseRegex r where
    f [] cs = grepString b Nothing cs =<< getLine
    f _  cs = mapM_ (\p -> grepString b (Just p) cs =<< readFile p) ps

Finally, main checks whether to display the lines that do or do not match.

main :: IO ()
main = f =<< getArgs where
           f ("-v":args) = grep False args
           f args        = grep True  args

And that’s it. See you guys in a week.

Programming Praxis – Regular Expressions, Part 2

Last time we wrote a parser for simple regular expressions. In today’s exercise, we have to write the matcher that checks if the input string matches the parsed regex. Since we wrote a similar matcher in the Beautiful Code exercise, this is mostly going to be a retread of that code. Still, let’s have a look.

A quick import:

import Data.List

This is the data structure we defined last time. Obviously we’re going to need it here again.

data Elem = Lit Char | Esc Char | Any | Set Bool [Elem] deriving Show
data Chunk = Elem Elem | BoL | EoL | Star Elem deriving Show

matchElem is the only new function, because, since we now have two additional cases, it’s clearer to make a separate function out of it.

matchElem :: Elem -> Char -> Bool
matchElem e c = case e of Lit l    -> l == c
                          Esc s    -> show c == '\\':[s]
                          Set b es -> b == any (`matchElem` c) es
                          Any      -> True

The other three functions have only received some small tweaks compared to the previous version. The logic remains unchanged.

matchHere :: [Chunk] -> String -> Bool
matchHere (Elem r:rs) (x:xs) = matchElem r x && matchHere rs xs
matchHere (Star e:r)  xs     = matchStar e r xs
matchHere [EoL]       xs     = null xs
matchHere r           _      = null r

matchStar :: Elem -> [Chunk] -> String -> Bool
matchStar _ r xs     | matchHere r xs = True
matchStar e r (x:xs) = matchElem e x && matchStar e r xs
matchStar _ _ _      = False

match :: [Chunk] -> String -> Bool
match (BoL:r) = matchHere r
match r       = any (matchHere r) . tails

A quick test shows everything working correctly:

main :: IO ()
main = do
    expect False [Elem digit, Star digit]
    expect True  [BoL, Elem Any, Star Any, EoL]
    expect True  hello
    expect True  ([BoL, Star $ Lit ' '] ++ hello ++ [Star $ Lit ' ', EoL])
    expect False [BoL, Elem $ Set False [Lit 'x'], Star Any,
                  Elem digit, Star $ Lit ' ', Elem $ Lit 'x', EoL]
    where expect b cs = print $ match cs "hello" == b
          digit = Set True $ map Lit ['0'..'9']
          hello = map (Elem . Lit) "hello"

Piece of cake.

Programming Praxis – Regular Expressions, Part 1

In today’s Programming Praxis problem our task is to write a parser for simple regular expressions. Since Haskell has a very good parser library called Parsec, we’re going to be using that. Let’s get started.

First, some imports:

import Control.Applicative ((<$>), (*>), (<*), (<*>))
import Data.Char
import Text.Parsec
import Text.Parsec.String

Next we define our data structure. There are seven constructs we have to implement, split into two groups based on whether or not they can be followed by a star or not.

data Elem = Lit Char | Esc Char | Any | Set Bool [Elem] deriving Show
data Chunk = Elem Elem | BoL | EoL | Star Elem deriving Show

The parser itself is not too difficult if you know how the operators from Control.Applicative work. <$> means apply the function on the left to the result of the parser on the right. <*, *> and <*> take only the result on the left, right and both sides respectively.

regex :: Parser [Chunk]
regex = (++) <$> bol <*> many chunk where
    bol = option [] (const [BoL] <$> char '^')
    chunk = choice [Star <$> try (element <* char '*'),
                    const EoL <$> try (char '$' <* eof),
                    Elem <$> element]
    element = choice [esc <$> try (char '\\' *> anyChar),
                      const Any <$> char '.',
                      Set False . expandSet <$> set "[^",
                      Set True . expandSet <$> set "[",
                      Lit <$> noneOf "]"]
    esc c = if elem c "nt" then Esc c else Lit c
    set s = try (string s *> many1 element <* char ']')
    expandSet (Lit a:Lit '-':Lit b:xs)
        | validRange a b = map Lit [a..b] ++ expandSet xs
    expandSet (x:xs) = x : expandSet xs
    expandSet _ = []
    validRange a b = b > a && ((isLower a && isLower b) ||
                               (isUpper a && isUpper b) ||
                               (isDigit a && isDigit b))

With the parser written, the function to parse a string is trivial:

parseRegex :: String -> Either ParseError [Chunk]
parseRegex = parse regex ""

Some tests to see if everything is working properly:

main :: IO ()
main = mapM_ print [parseRegex "[0-9][0-9]*",
                    parseRegex "^..*$",
                    parseRegex "hello",
                    parseRegex "^ *hello *$",
                    parseRegex "^[^x].*[0-9] *x$"]

Piece of cake. Next time we do the implementation.