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.