Archive for January, 2010

Programming Praxis – Straddling Checkerboard

January 29, 2010

In today’s Programming Praxis problem we have to implement the straddling checkerboard cipher. Let’s get started.

We’ll need two imports:

import Data.Char
import Data.List

Our alphabet for the checkerboard consists of letters and a space.

alphabet :: String
alphabet = ['A'..'Z'] ++ " "

The algorithm cannot deal with anything other than letters, numbers or spaces.

clean :: String -> String
clean = filter (`elem` alphabet ++ ['0'..'9']) . map toUpper

To create the checkerboard (without indices, since we need to the lookups both ways), we need to put the three extra spaces in the correct place and the numbers in the correct positions.

board :: String -> [Int] -> String
board key = spaces (replace =<< nub (clean key ++ alphabet))
    where spaces    = foldl (\a x -> take x a ++ "_" ++ drop x a)
          replace c = c : (maybe "" id . lookup c $ zip alphabet
                              (map show [1..9] ++ "0" : repeat ""))

As you can see below, encrypting and decrypting are really the same thing in this algorithm, only one adds and subtracts. So we factor out all of the work into one function. The reason for not making all the sub-functions into top-level functions is that it saves us from having to pass the five cipher parameters all over the place.

run :: (Int -> Int -> Int) -> String -> [Int] -> Int -> String -> String
run op text ss add key = f $ show =<<
    zipWith (\a b -> mod (op (read [a]) b) 10)
            (toIndex =<< clean text)
            (cycle . map digitToInt $ show add) where
    f []       = []
    f (a:xs)   = if elem (digitToInt a) ss
                 then fromIndex ([a], take 1 xs) ++ f (tail xs)
                 else fromIndex ("" , [a]      ) ++ f xs
    fromIndex  = maybe "" return . look id
    toIndex    = maybe "" (uncurry (++)) . look flip
    look dir k = lookup k . dir zip indices $ board key ss
    indices    = [(y, show x) | y <- "" : map show ss, x <- [0..9]]

With that out of the way, encrypting and decrypting is trivial:

encipher :: String -> Int -> Int -> Int -> Int -> String -> String
encipher xs s1 s2 s3 = run (+) xs [s1, s2, s3]

decipher :: String -> Int -> Int -> Int -> Int -> String -> String
decipher xs s1 s2 s3 = run (-) xs [s1, s2, s3]

Let’s see if our encryption works correctly:

main :: IO ()
main = do print $ go encipher "bonsai code"
          print $ go decipher "2B1ABA71OB1H2LBB"
       where go f text = f text 2 5 9 2641 "pablo picasso"

Yup. And at about a third of the Scheme solution size, I’d say that wraps things up nicely.

Power programming

January 27, 2010

Yesterday I read called Power Programming, in which the author gives solutions for this Google Code Jam problem in Python, Perl, Arc and C++. I figured I’d have a go at providing a solution in Haskell to see how it stacks up.

Since converting the given tree to a tuple won’t work in Haskell (it might with Data.Dynamic, but that’s not exactly standard practice), we’ll have to settle for writing a parser. Fortunately, Parsec makes this really easy.

First, we need some imports.

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

We’ll also have to define the structure of the decision tree.

data Tree = Node Double String Tree Tree | Leaf Double

Since we need a parser for the decision trees anyway, we might as well write a parser for the complete test case input. Because the tokens we’ll be getting are pretty much the same as in most programming languages, we can just use the existing haskell tokenizer to parse the tree.

input    = count' testCase
testCase = (,) <$> (natural h >> tree) <*> count' animal
tree     = parens h $ try node <|> leaf
node     = Node <$> float h <*> identifier h <*> tree <*> tree
leaf     = Leaf <$> float h
animal   = identifier h >> count' (identifier h)
h        = haskell
count' p = flip count p =<< (fromIntegral <$> natural h)

Once we have the tree and the animals, calculating the cuteness of one of them is just a matter of taking the correct branches and multiplying all the values.

cute (Leaf x) _        = x
cute (Node x f l r) fs = x * cute (if elem f fs then l else r) fs

Showing the result just requires a bit of printf use.

output = mapM_ (\(i, (t, as)) -> printf "Case #%d:\n" i >>
             mapM_ (printf "%1.7f\n" . cute t) as) . zip [1::Int ..]

And finally a function that combines the required steps.

solve = either print output . parse input ""

A test to see if everything works correctly (for the sake of brevity, we read the input from a file, but using getContents to read from the console or a plain string literal will work as well):

main = solve =<< readFile "input.txt"

Not bad I reckon. Obivously, it’s not quite as brief as the Perl solution, but at least to me it’s a whole lot more readable. It’s roughly the same size as the Arc solution, which seems about right to me.

Programming Praxis – Phases Of The Moon

January 22, 2010

In today’s Programming Praxis exercise we have to write a program to calculate the phase of the moon on a given day. Let’s get started.

Some imports:

import Data.Time
import Data.Time.Calendar.Julian
import Data.Fixed

The algorithm is pretty simple: take the difference in days between the given date and Jan 6th 2000 (on which there was a new moon), modulo that by the moon cycle length, and then find the lunar phase associated with the remainder.

moonPhase :: Integer -> Int -> Int -> String
moonPhase y m d = phase . flip mod' 29.530588853 . fromIntegral $
    diffDays (fromJulian y m d) (fromJulian 2000 1 6) where
    phase x | x <  1.84566 = "New"
            | x <  5.53699 = "Waxing crescent"
            | x <  9.22831 = "First quarter"
            | x < 12.91963 = "Waxing gibbous"
            | x < 16.61096 = "Full"
            | x < 20.30228 = "Waning gibbous"
            | x < 23.99361 = "Last quarter"
            | x < 27.68493 = "Waning crescent"
            | otherwise    = "New"

A quick test reveals it’s working correctly:

main :: IO ()
main = do print $ moonPhase 2000 1 6
          print $ moonPhase 2010 1 22

Programming Praxis – Flight Planning

January 19, 2010

In today’s Programming Praxis exercise we have to implement two algorithms for flight planning.

Our import:

import Data.Fixed

We will need to some degree-radian conversion, so let’s define some convenience functions.

toDeg, toRad :: Floating a => a -> a
toDeg d = d * 180 / pi
toRad d = d * pi / 180

Both navigation algorithms are really nothing more than a lot of math, so it’s just a matter of converting the math to Haskell notation.

navigate1 :: Float -> Float -> Float -> Float -> Float -> [Int]
navigate1 d gt wn ws as = map round [gs, a, th, ft] where
    b  = toRad $ gt - wn + 180
    a  = toDeg $ asin (ws * sin b / as)
    th = mod' (gt + a) 360
    gs = (cos . toRad $ th - gt) * as + ws * cos b
    ft = d / gs * 60

navigate2 :: Float -> Float -> Float -> Float -> Float -> [Int]
navigate2 d gt wn ws as = if det < 0 || gs < 0 then error "strange"
                          else map round [gs, a, th, ft] where
    b   = mod' (gt - wn + 180) 360
    x   = ws * cos (toRad b)
    det = x^2 - ws^2 + as^2
    gs  = x + sqrt det
    a   = (if b < 180 then id else negate) . toDeg . acos $
          (as^2 + gs^2 - ws^2) / (2 * gs * as)
    th  = gt + a
    ft  = d / gs * 60

A test shows that everything is working correctly.

main :: IO ()
main = do print $ navigate1 180 90 90 20 90
          print $ navigate2 180 90 90 20 90

Programming Praxis – Three Binary Algorithms

January 15, 2010

In today’s Programming Praxis we have to implement binary algorithms for multiplying, dividing, and finding the greatest common divisor of two numbers. Let’s get started.

Since all our functions require the Bits typeclass, for which Haskell doesn’t do type defaulting, we use the following language pragma so we don’t have to specify types in the tests.

{-# LANGUAGE ExtendedDefaultRules #-}

We need an import to do bitshifting.

import Data.Bits

And because we’re going to be doing quite a bit of it, two quick convenience convenience functions for doubling and halving numbers:

left, right :: Bits a => a -> a
left = flip shiftL 1
right = flip shiftR 1

Binary multiplication. Piece of cake.

binmult :: (Bits a, Integral a) => a -> a -> a
binmult 1 b = b
binmult a b = binmult (right a) (left b) + if odd a then b else 0

Binary division. By using the until function we don’t have use explicit recursion to find t.

bindiv :: (Bits a, Ord a) => a -> a -> (a, a)
bindiv n d = f (right $ until (> n) left d) 0 n where
    f t q r | t < d     = (q, r)
            | t <= r    = f (right t) (left q + 1) (r - t)
            | otherwise = f (right t) (left q)     r

Binary gcd. A lot of different conditions, but all very straightforward.

bingcd :: (Bits a, Integral a) => a -> a -> a
bingcd a 0 = a
bingcd 0 b = b
bingcd a b | even a && even b = 2 * bingcd (right a) (right b)
           | even a           = bingcd (right a) b
           | even b           = bingcd a (right b)
           | a > b            = bingcd (a - b) b
           | otherwise        = bingcd a (b - a)

A quick test shows that everything is working correctly:

main :: IO ()
main = do print $ binmult 14 12
          print $ bindiv 837 43
          print $ bingcd 2322 654

Programming Praxis – Calculating Sines

January 12, 2010

In today’s Programming Praxis exercise we have to implement two ways of calculating sines. Let’s get started.

A quick import:

import Data.Fixed

The only real trick we use for the Taylor sine function is to not calculate the factorial for each number, but to keep reusing the previous result so that each new entry only requires two multiplications instead of n.

taylorSin :: Double -> Double
taylorSin x = sum . useful $ zipWith (/)
    (map (\k -> (mod' x (2*pi)) ** (2*k + 1) * (-1) ** k) [0..])
    (scanl (\a k -> a * k * (k - 1)) 1 [3,5..]) where
    useful ~(a:b:c) = a : if abs (a-b) > 1e-7 then useful (b:c) else []

For the recursive solution we use the fact that lim(x -> 0) sin x = x

recSin :: Double -> Double
recSin = f . flip mod' (2 * pi) where
    f x = if abs x < 1e-7 then x else
          let s = f (x / 3) in 3 * s - 4 * s**3

A quick test shows that everything is working correctly.

main = do mapM_ (print . taylorSin) [1, pi / 2, 10]
          mapM_ (print . recSin)    [1, pi / 2, 10]

Programming Praxis – Nim

January 8, 2010

In today’s Programming Praxis we have to program the game Nim. Let’s get started.

First, some imports:

import Data.Bits
import System.Random
import Text.Printf

We need a way to check if a move is valid to prevent illegal player input.

valid :: (Int, Int) -> [Int] -> Bool
valid (p, t) ps = and [p >= 0, p < length ps, t > 0, t <= ps !! p]

When the computer makes a move, we need to show it to the player.

showMove :: (Int, Int) -> IO ()
showMove (p, t) = printf "I remove %d stone%s from pile %d\n" t
                      (if t > 1 then "s" else "") (p + 1)

For the computer’s ai, use the xor approach or make a random move if there is no winning move.

cpu :: [Int] -> IO (Int, Int)
cpu ps = do p <- randomRIO (0, length ps - 1)
            t <- randomRIO (1, ps !! p)
            let n = foldl xor 0 ps
            let r = if n == 0 then (p, t) else (length a, b - xor b n)
                        where (a,b:_) = break (\x -> xor x n < x) ps
            if valid r ps then showMove r >> return r else cpu ps

A quick convenience function to make getting player input easier:

prompt :: Read a => String -> IO a
prompt s = putStr (s ++ " ") >> fmap read getLine

The player’s move is pretty straightforward.

human :: [Int] -> IO (Int, Int)
human ps = do p <- fmap pred $ prompt "Pile?"
              t <- prompt "Stones?"
              if valid (p, t) ps then return (p, t) else human ps

Each turn, check if the game is over. If not, show the board and let the correct player take a turn. The lazy pattern match in the turn function (the tilde) is to prevent the complaint about not matching [], since we’re going to feed this function with an infinite list anyway.

display :: [Int] -> String
display = unlines . zipWith (printf "%d: %d") [1 :: Int ..]

makeMove :: (Int, Int) -> [Int] -> [Int]
makeMove (p, t) = (\(a,b:c) -> a ++ b - t:c) . splitAt p

turn :: [([Int] -> IO (Int, Int), [Char])] -> [Int] -> IO ()
turn ~((f, w):ms) b = if all (== 0) b then putStrLn $ w ++ " win"
                      else do putStr $ display b
                              turn ms . flip makeMove b =<< f b

When starting a new game, we need to determine the correct turn order.

nim :: [Int] -> IO ()
nim ps = do f <- prompt "Enter 1 to move first or 2 to move second:"
            turn (drop f $ cycle [(cpu, "You"), (human, "I")]) ps

Let’s see if everything’s working correctly:

main :: IO ()
main = nim [3,4,5]

Yup. Have fun playing!

Programming Praxis – The Sum Of Two Squares

January 5, 2010

In today’s Programming Praxis exercise we have to find all the ways a given number can be written as the sum of the squares of two other numbers. Let’s get started.

All we really have to do is to convert the four cases of Dijkstra’s algorithm (listed on the second page of the exercise) from English to Haskell, which is trivial. To avoid repeating ourselves, we pattern match on the result of the comparison between x*x + y*y and n instead of recalculating it three times.

squareSum :: Integer -> [(Integer, Integer)]
squareSum n = b (ceiling . sqrt $ fromIntegral n) 0 where
    b x y = if x < y then [] else case compare (x*x + y*y) n of
                LT -> b x (y + 1)
                EQ -> (x, y) : b (x - 1) (y + 1)
                GT -> b (x - 1) y

A quick test shows us that everything’s working correctly.

main :: IO ()
main = do print $ squareSum 50
          print $ squareSum 48612265
          print $ squareSum 999

Programming Praxis – Cal

January 1, 2010

Happy new year everyone!

In today’s Programming Praxis exercise we have to implement the Unix utility cal, which prints calendars. Let’s get started.

First we need a bunch of imports:

import Data.List
import Data.List.Split
import qualified Data.Text as T
import Data.Time
import System.Environment
import System.Locale

Let’s start by determining which days are in a given month.

days :: Integer -> Int -> [Day]
days y m = map (fromGregorian y m) [1..gregorianMonthLength y m]

We’re going to need to do a bunch of date formatting, and since the required locale is fairly long we make a quick helper function.

fmt :: FormatTime t => String -> t -> String
fmt = formatTime defaultTimeLocale

On to the real meat of the application: the function that creates the calendar for the given year and month. Basically, just build the header, start printing the day numbers at the correct weekday by prepending some spaces, and also put some blank spaces at the end so that each month is 6 rows high. This is needed so that when we start printing months next to each other everything stays in the correct place.

monthCal :: Integer -> Int -> String
monthCal y m = unlines $ (T.unpack . (T.center 20 ' ') . T.pack .
    fmt "%B %Y" $ fromGregorian y m 1) : "Su Mo Tu We Th Fr Sa" :
    (map unwords . take 6 . chunk 7 $
        replicate (read . fmt "%w" . head $ days y m) "  " ++
        map (fmt "%e") (days y m) ++ repeat "  ")

Showing multiple months next to each other requires some string manipulation.

showCal :: [String] -> IO ()
showCal = putStrLn . unlines . map (unlines . map
            (intercalate "  ") . transpose . map lines) . chunk 3

Finally, we need a function to determine which months to show when the -3 argument is used.

surround :: UTCTime -> [String]
surround d = map ((\(y, m, _) -> monthCal y m) . toGregorian .
               (`addGregorianMonthsRollOver` utctDay d)) [-1..1]

All that’s left to do is to check the arguments and show the appropriate calendar.

main :: IO ()
main = do args <- getArgs
          now  <- getCurrentTime
          let (curYear, curMonth) = read $ fmt "(%Y,%m)" now
          case args of
              [y,m]  -> showCal [monthCal (read y) (read m)]
              ["-3"] -> showCal $ surround now
              [y]    -> showCal $ map (monthCal $ read y) [1..12]
              []     -> showCal [monthCal curYear curMonth]
              _      -> error "Invalid parameters"