Archive for March, 2011

Programming Praxis – Look And Say, Revisited

March 28, 2011

In today’s Programming Praxis exercise, our goal is to calculate Conway’s constant. Let’s get started, shall we?

First we need to represent the polynomial that we’re going to take the root of.

conway :: Num a => a -> a
conway x = sum $ zipWith (*) (iterate (* x) 1)
    [ -6,  3,-6, 12,-4, 7,-7, 1, 0, 5,-2, -4,-12, 2, 7,12,-7,-10
    , -4,  3, 9, -7, 0,-8,14,-3, 9, 2,-3,-10, -2,-6, 1,10,-3,  1
    ,  7, -7, 7,-12,-5, 8, 6,10,-8,-8,-7, -3,  9, 1, 6, 6,-2, -3
    ,-10, -2, 3,  5, 2,-1,-1,-1,-1,-1, 1,  2,  2,-1,-2,-1, 0,  1]

Next, we calculate the root by halving the interval until the value at the middle is sufficiently close to 0.

root :: (Fractional a, Ord a) => (a -> a) -> a -> a -> a -> a
root f lo hi e | abs (f mid) < e = mid
               | f mid > 0       = root f lo mid e
               | otherwise       = root f mid hi e
               where mid = (lo + hi) / 2

Since we know the root lies somewhere between 1 and 2, we use those as the starting values.

main :: IO ()
main = print $ root conway 1 2 1e-7 == 1.303577269034296

We get the correct answer, so everything seems to be working properly.

Programming Praxis – Sum

March 25, 2011

In today’s Programming Praxis exercise, our goal is to implement a unix checksum utility. Let’s get started, shall we?

Some imports:

import Data.Char
import System.Environment

I made two changes in the checksum algorithm compared to the Scheme version. I included to conversion to a string to remove some duplication and I used a simpler method of dividing and rounding up.

checksum :: String -> String
checksum = (\(s,b) -> show s ++ " " ++ show (div (b + 511) 512)) .
    foldl (\(s,b) c -> (mod (s + ord c) 65535, b + 1)) (0,0)

Depending on whether or not the program was called with any arguments, the checksum is calculated for either the stdin input or the files provided.

main :: IO ()
main = getArgs >>= \args -> case args of
    [] -> interact checksum
    fs -> mapM_ (\f -> putStrLn . (++ ' ':f) . checksum =<< readFile f) fs

Programming Praxis – Two Kaprekar Exercises

March 22, 2011

In today’s Programming Praxis exercise,our goal is to determine the longest possible Kaprekar chain and the Kaprekar numbers below 1000. Let’s get started, shall we?

Some imports:

import Data.List
import qualified Data.List.Key as K
import Text.Printf

The Kaprekar chain algorithm is fairly simple. We use printf for easy padding of the number.

chain :: Int -> [Int]
chain 0 = []
chain 6174 = [6174]
chain n = n : chain (read (reverse p) - read p) where
    p = sort $ printf "%04d" n

Determining whether a number is a Kaprekar number is made easier by realizing that the whole ‘take the first n-1 or n and the last n digits’ bit can be replaced with the divMod function.

isKaprekar :: Integral a => a -> Bool
isKaprekar n = n == uncurry (+) (divMod (n^2) $ 10 ^ length (show n))

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ chain 2011 == [2011, 1998, 8082, 8532, 6174]
          print . K.maximum length $ map chain [0..9999]
          print $ filter isKaprekar [1..999] ==
                  [1, 9, 45, 55, 99, 297, 703, 999]

The chain shown is just one of 2184 possible chains of length 8. The first chain of length 8 starts with 14.

Programming Praxis – Loopy Loops

March 18, 2011

In today’s Programming Praxis, our goal is to print the numbers 1 through 1000 without using loops or conditionals. Let’s get started, shall we?

Some imports:

import Control.Exception
import Control.Monad.State

The problem with this question is that it isn’t very well-defined. For example, the idiomatic way of doing this in Haskell would be the following:

loopy1 :: IO ()
loopy1 = mapM_ print [1..1000]

This has no loops or conditionals in the user’s code. However, the .. construct probably uses a loop and/or conditional internally. So let’s get rid of it:

loopy2 :: IO ()
loopy2 = f 1 where
    f 1000 = print 1000
    f n    = print n >> f (n + 1)

This uses recursion instead of looping and pattern matching instead of conditionals. However, you might consider pattern matching a number to be sufficiently like conditionals to be cheating. Ok, let’s choose another approach.

loopy3 :: IO ()
loopy3 = handle (\DivideByZero -> return ()) $ f 1 where
    f n = seq (div n (1001 - n)) print n >> f (n + 1)

Here we still use recursion, but we now end through exception handling rather than pattern matching. The only thing left to do would be to get rid of recursion, since you could consider that a form of looping.

loopy4 :: IO ()
loopy4 = evalStateT (do10 . do10 . do10 $ next) 1 where
    next = (liftIO . print =<< get) >> modify succ
    do10 f = f >> f >> f >> f >> f >> f >> f >> f >> f >> f

And there we go. No conditionals or looping of any kind as far as I can tell. This is probably the closest to the spirit of the exercise.

Programming Praxis – Look And Say

March 15, 2011

In today’s Programming Praxis exercise, our task is to generate the Look and Say sequence (1, 11, 21, 1211, etc.). Let’s get started, shall we?

A quick import:

import Data.List

The algorithm is pretty straightforward: convert the number to a string, replace each sequence of identical digits with the length followed by the digit and convert the result back to an integer. Repeat indefinitely.

lookAndSay :: Integer -> [Integer]
lookAndSay = iterate (read . f . group . show) where
    f = (>>= \x -> show (length x) ++ take 1 x)

A test to see if everything is working properly:

main :: IO ()
main = print $ take 10 (lookAndSay 1) == [1, 11, 21, 1211, 111221,
    312211, 13112221, 1113213211, 31131211131221, 13211311123113112211]

Yup. Unfortunately there doesn’t appear to be a Haskell Package that does run-length encoding, or I might have been able to do it in one line.

Programming Praxis – Lowest Common Ancestor

March 11, 2011

In today’s Programming Praxis exercise, our goal is to write an algorithm to find the lowest common ancestor of two nodes in a binary tree. Let’s get started, shall we?

First, we define a binary tree data structure.

data BinTree a = Node a (BinTree a) (BinTree a) | Nil

The algorithm is pretty trivial: if the higher value is less than the current node, descend the left branch. If the lower value is higher than the current node, descend the right branch. Otherwise, we’ve found our result.

lca :: Ord a => a -> a -> BinTree a -> a
lca m n ~(Node v l r) | n < v     = lca m n l
                      | m > v     = lca m n r
                      | otherwise = v

Some tests to see if everything is working properly:

main :: IO ()
main = do let tip n = Node n Nil Nil
          let tree = Node 8 (Node 3 (tip 1) (Node 6 (tip 4) (tip 7)))
                            (Node 10 Nil (Node 14 (tip 13) Nil))
          print $ lca 4  7 tree == 6
          print $ lca 4 10 tree == 8
          print $ lca 1  4 tree == 3
          print $ lca 1  3 tree == 3
          print $ lca 3  6 tree == 3

Yup. Simple enough.

Programming Praxis – Reverse Words

March 8, 2011

In today’s Programming Praxis exercise, we’re revisiting the well-known interviewing problem of reversing the words in a string. This time, we have to do the reversal in place and without using any library functions for determining the words. Let’s get started, shall we?

Haskell doesn’t do much in the way of in-place modifications by default. Attempting to modify a string (or indeed the majority of all data structures) will create a copy of it (though part of the new one may refer to same memory occupied by the original). I figured the closest thing to modifying the string in place would be to turn it into a mutable array. It’s not entirely in-place since we still have to convert to and from the array, but it’s the closest we’re going to get.

import Data.Array.IO

We start with a function to switch to characters in a string.

switch :: (MArray a e m, Ix i) => i -> i -> a i e -> m ()
switch i j a = do x <- readArray a i
                  writeArray a i =<< readArray a j
                  writeArray a j x

Next, we make a function to reverse part of a string.

revRange :: Int -> Int -> IOArray Int a -> IO (IOArray Int a)
revRange i j a = mapM_ (\n -> switch n (j+i-n) a) [i..div (i+j) 2] >> return a

The algorithm for reversing the words in a string is the same as in the Scheme version: reverse the entire string, then reverse the individual words.

reverseWords :: String -> IO String
reverseWords xs = do a <- newListArray (0, length xs - 1) xs
                     (s,e) <- getBounds a
                     f 0 e =<< revRange s e a where
    f i e a = if i > e then getElems a else nextSpace i e a >>=
                 \s -> f (s+1) e =<< revRange i (s-1) a
    nextSpace i e a = if i > e then return i else readArray a i >>= \c ->
                      if c == ' ' then return i else nextSpace (i+1) e a

Let’s see if everything is working properly:

main :: IO ()
main = do let a =? b = print . (== b) =<< reverseWords a
          "" =? ""
          " " =? " "
          "  " =? "  "
          "hello" =? "hello"
          "hello " =? " hello"
          " hello" =? "hello "
          "the quick brown fox" =? "fox brown quick the"
          "the quick  brown fox" =? "fox brown  quick the"
          "the quick  brown 42 fox!" =? "fox! 42 brown  quick the"

Yup. Having to do things in place does make the code a lot longer than the original solution though.

Programming Praxis – Chutes And Ladders

March 4, 2011

In today’s Programming Praxis exercise, our goal is to simulate the board game Chutes and Ladders. Let’s get started, shall we?

Some imports:

import Control.Monad
import System.Random

First, we write a function to handle the chutes and ladders. If a player lands on one these squares, he automatically moves to the corresponding destination.

promote :: Num a => a -> a
promote n = maybe n id $ lookup n [(16,6), (47,26), (49,11), (56,53),
    (62,19), (64,60), (87,24), (93,73), (95,75), (98,78), (1,38), (4,14),
    (9,31), (21,42), (28,84), (36,44), (51,67), (71,91), (80,100)]

A single player game consists of throwing dice until you land on the goal.

game :: IO [Int]
game = fmap (tail . turn 0 . randomRs (1,6)) newStdGen where
    turn 100 _       = [100]
    turn n   ~(d:ds) = n : turn (if n+d > 100 then n else promote $ n+d) ds

The length of a multiplayer game can be determined by taking the shortest of k single player games. For the statistics, we look at the shortest game, the longest game and the average length.

stats :: Int -> Int -> IO (Int, Int, Float)
stats k n = fmap (\rs -> (minimum rs, maximum rs, average rs)) .
    replicateM n . fmap minimum . replicateM k $ fmap length game where
        average xs = fromIntegral (sum xs) / fromIntegral n

We simulate the results for games with one to five players.

main :: IO ()
main = do print =<< stats 1 100000
          print =<< stats 2 100000
          print =<< stats 3 100000
          print =<< stats 4 100000
          print =<< stats 5 100000

One run produced the following results:


The results are within tolerance of the ones produced by the Scheme version. As a regular player of board games myself, I must say this seems like a fairly rubbish game. There’s no interaction, no strategy, the winner is determined purely by chance and the game can theoretically last infinitely long. Do yourself a favor and go play a good game instead.

Programming Praxis – An Early LISP Program

March 1, 2011

In today’s Programming Praxis exercise, our goal is to write a function to un-nest a list. Let’s get started, shall we?

Since Haskell is statically typed, the concept of nested lists is a bit more difficult than in Lisp, which is dynamically typed. In a regular list in Haskell all elements must be of the same type, which in a nested list is not the case. There are various ways around this, so I will give three different solutions.

Some pragmas and an import for the third and second solution, respectively:

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances #-}

import Data.Dynamic

Solution 1: create a datatype for nested lists.

First, we define a nested list:

data List a = E a | L [List a]

Collapsing this list is then a fairly trivial task: just collapse each sublist recursively.

collapse_data :: List a -> [a]
collapse_data (E x) = [x]
collapse_data (L xs) = collapse_data =<< xs

Solution 2: Use dynamic typing.

Just because Haskell is a static language doesn’t mean it can’t do dynamic typing. The only downside is that entering the list is a tad laborious with toDyns all over the place.

collapse_dyn :: Typeable a => Dynamic -> [a]
collapse_dyn x = maybe (maybe [] return $ fromDynamic x)
                       (collapse_dyn =<<) (fromDynamic x)

Solution 3: Tuples

Haskell has a way of defining lists that have elements of different types: tuples. The downside is that tuples of different lengths are considered completely different types, and it is therefore necessary to define every function for every possible tuple length. This can be automated by using Template Haskell, but I won’t go into that here. The advantage of this method is that the list literals look almost exactly like the Lisp ones (with the addition of some commas).

First, we define a typeclass for values that can be collapsed.

class Collapsible a b | a -> b where
    collapse :: a -> [b]

Next, we describe how to collapse a tuple. As mentioned, the code for 3-tuples and longer can be generated using Template Haskell.

instance (Collapsible a c, Collapsible b c) => Collapsible (a, b) c where
    collapse (a, b) = collapse a ++ collapse b

We also need to describe how to collapse literals. For production use, the other literals like Int and Float should be defined as well.

instance Collapsible Char Char where
    collapse c = [c]

Some tests to see if everything is working properly:

main :: IO ()
main = do
    print $ collapse_data (L[L[L[L[E 'a', E 'b'], L [L [E 'c']]],
                               L [L [E 'd', L [E 'e', E 'f']],
                                  L [E 'g'], L [L [E 'h']]]]]) == "abcdefgh"
    print $ collapse_dyn (toDyn [toDyn [toDyn 'a', toDyn [toDyn 'b',
              toDyn [toDyn 'c', toDyn [toDyn 'd', toDyn [toDyn 'e']]], 
              toDyn 'f', toDyn [toDyn 'g',
              toDyn [toDyn 'h', toDyn 'j']]]]]) == "abcdefghj"
    print $ collapse (((((('a'), 'b'), 'c'), 'd'), 'e')) == "abcde"

Yep. The first two methods are short to implement but make the actual lists less concise, the third is the other way round. Choose whichever option you prefer.