Archive for April, 2009

Programming Praxis – Morse code

April 28, 2009

Today’s Programming Praxis problem is about morse code. We’re supposed to write a program to convert back and forth between plain text and morse code. Shouldn’t be too hard, so let’s go.

First our imports:

import Data.List
import Data.List.Split
import qualified Data.Map as M

Next we need to define the morse code. Unlike the solution posted by the Programming Praxis author, however, we’re not going to specify the translations both ways, as that would go against the DRY (Don’t Repeat Yourself) principle (or Once And Only Once, whichever you prefer). So instead we just make two lists of the valid characters, making sure to match the order.

plain :: [Char]
plain = ['A'..'Z'] ++ ['0'..'9']

morse :: [String]
morse = words ".- -... -.-. -.. . ..-. --. .... .. .--- -.- .-.. -- \
              \-. --- .--. --.- .-. ... - ..- ...- .-- -..- -.-- --.. \
              \.---- ..--- ...-- ....- ..... -.... --... ---.. ----. -----"

Converting a character to a morse symbol or vice versa is then simply a matter of:

convert :: Ord a => [a] -> [b] -> a -> b
convert from to x = M.fromList (zip from to) M.! x

The functions to convert between whole strings also involve some mucking about with the spaces.

toMorse :: String -> String
toMorse = intercalate "  " . map (unwords .
              map (convert plain morse . toUpper)) . words

fromMorse :: String -> String
fromMorse = unwords . map (map (convert morse plain) . words) . splitOn "  "

And that’s all you need. To test you just use something like:

main :: IO ()
main = do print $ toMorse "Programming Praxis"
          print $ fromMorse ".--. .-. --- --. .-. .- -- -- .. -. --.  \
                            \.--. .-. .- -..- .. ..."

And there we go. Three (nearly) one-liners and some data. Piece of cake 🙂

Advertisements

Forcing evaluation in Haskell

April 27, 2009

As you might know, Haskell is a lazy language. This means that nothing is evaluated until it is actually needed. This allows you to do nice things like

foo = take 10 [0..]

without taking infinity to evaluate the list. Until yesterday, however, I didn’t fully appreciate quite how literally Haskell takes this concept. I was working on a BMP importer and had the following data structure:

data Image = Image { width :: Int, height :: Int, pixels :: [[Pixel]] }

data Pixel = Pixel { red :: Int, green :: Int, blue :: Int, alpha :: Int }
             deriving Show

Pretty simple. Now let’s make a function that generates a bitmap:

makeImage :: Int -> Int -> Image
makeImage w h = Image w h . replicate h . replicate w $ Pixel 255 0 0 255

Let’s jump to ghci to test working with a reasonable sized bitmap.

> :set +s

This makes ghci report how long everything takes and how much memory it requires.

> width $ makeImage 800 600
800
(0.05 secs, 527520 bytes)

As the more perceptive of you may have noticed, we have 800 * 600 = 480000 pixels. Each pixel has four ints, which are 4 bytes each, so the full data structure should take 480000 * 16 = 7680000 bytes, or 7 MB at the very least. Our command only took 527 KB, so obviously it’s not evaluating the whole thing, which is logical. It doesn’t need the pixels, so it doesn’t evaluate them.

So how do we make it evaluate all the pixels? Until yesterday i thought getting the last pixel via (last . last) would work, figuring it should have to evaluate the whole thing to give me the last element. Let’s try that.

> last . last . pixels $ makeImage 800 600
Pixel {red = 255, green = 0, blue = 0, alpha = 255}
(0.00 secs, 522388 bytes)

Well, that was fast. But if we look at the memory used we see the obvious problem: it’s still not nearly enough. GHC is a clever compiler, so it skips doing the work for all the other pixels because it sees it doesn’t have to. Unfortunately it took me a whole lot longer to see this problem since I was testing a bigger section of code, which took a lot more memory, obscuring this problem.

Fortunately the kind people in the #haskell IRC channel pointed out this problem and also provided a way to force the evaluation of an object, namely the rnf function in Control.Parallel.Strategies. So let’s try that:

import Control.Parallel.Strategies

Go to ghci again and type

> rnf . pixels $ makeImage 800 600
    No instance for (NFData Pixel)
      arising from a use of `rnf' at :1:0-2
    Possible fix: add an instance declaration for (NFData Pixel)
    In the first argument of `(.)', namely `rnf'
    In the first argument of `($)', namely `rnf . pixels'
    In the expression: rnf . pixels $ makeImage 800 600

Hm. We’ll need to make Pixel an instance of NFData. Had this instead been a [[Int]] or another common data type it would have worked out of the box. Now we could just say

instance NFData Image

but this would tell only part of the story. If we look at the source code for Control.Parallel.Strategies we see that rnf does nothing by default. Using this version we would indeed evaluate the whole list (because the instance for lists has been correctly defined), but leave the pixels themselves unevaluated. In my test this resulted in a reported time of about 5 seconds instead of the 9-10 it actually took to fully load the image. Another look at the source code reveals that the correct implementation is very simple: just seq everything together.

instance NFData Pixel where
    rnf (Pixel r g b a) = rnf r `seq` rnf g `seq` rnf b `seq` rnf a

Let’s also make Image an instance of NFData for good measure.

instance NFData Image where
    rnf (Image w h ps) = rnf w `seq` rnf h `seq` rnf ps

Let’s try evaluating the image again:

> rnf $ makeImage 800 600
()
(1.78 secs, 92503000 bytes)

Quite a difference. Now we have a realistic memory use and the actual time it takes to fully evalutate the image. So if you’re ever unsure if something has been fully evaluated or if your compiler is just being sneaky, remember the rnf function. It might save you a few hours of confusion 🙂

Programming Praxis – Word hypenation

April 24, 2009

Today’s Programming Praxis problem is about word hyphenation. Let’s see what we can come up with.

First some imports

import Data.Char
import Data.List
import Data.List.HT

We define the exceptions by making a lookup table that zips the plain words to their hyphenated form.

exceptions :: [(String, String)]
exceptions = zip (map (filter isLetter) ws) ws
    where ws = words "as-so-ciate as-so-ciates dec-li-na-tion \
                     \oblig-a-tory phil-an-thropic present presents \
                     \project projects reci-procity re-cog-ni-zance \
                     \ref-or-ma-tion ret-ri-bu-tion ta-ble"

The program consists of loading the patterns and testing two inputs.

main :: IO ()
main = do patterns <- fmap words $ readFile "patterns.txt"
          print $ hyphenate patterns "hyphenation"
          print $ hyphenate patterns "associate"

To hyphenate a word, we first check if it’s an exception, otherwise we do the actual hyphenation.

hyphenate :: [String] -> String -> String
hyphenate ps s = maybe (hyphenate' s ps) id $ lookup s exceptions

First we prepare the input and then we try to apply all the patterns we have. For example, the word hyphenation would result in .0h0y3p0h0e2n5a4t2i0o0n0. (see the Programming Praxis page for more detail). Then we replace all the odd numbers with hyphens and remove all the useless characters.

hyphenate' :: String -> [String] -> String
hyphenate' s = concat . intersperse "-" . map (filter isLetter) .
               chop (\c -> isDigit c && odd (digitToInt c)) .
               foldl (flip (tryPattern . format)) ("." ++ format s ++ ".")

Formatting makes sure that a string consists of alternating letters and numbers (e.g. abc2d becomes a0b0c2d)

format :: String -> String
format (x:y:xs) | all isLetter [x, y] = x : '0' : format (y:xs)
format (x:xs)   = x : format xs
format []       = []

Trying a pattern means overlaying it everywhere it matches.

tryPattern :: String -> String -> String
tryPattern _ [] = []
tryPattern p s  = x : tryPattern p xs
                  where (x:xs) = if match p s then overlay p s else s

When matching a pattern we ignore the numbers.

match :: String -> String -> Bool
match (x:xs) (y:ys) = (all isDigit [x, y] || x == y) && match xs ys
match xs     _      = null xs

When overlaying two numbers, we are keep the highest one.

overlay :: String -> String -> String
overlay p = zipWith max (p ++ repeat '0')

And there we go; a hyphenation algorithm in 40 lines. Not quite as short as I’d like, but it’s the best I could come up with.

HPong 0.1.2

April 23, 2009

About two days ago the beta version of the Haskell Platform was released. Since it comes with an OpenGL library, it is now trivially easy to start making OpenGL programs with Haskell. To test this, I decided to make a simple Pong clone for two reasons:

  • To experiment with making an OpenGL game
  • I chose to use the GLFW instead of the GLUT library because GLUT doesn’t respond to closing a window with the close button very well. However, I could only find one piece of sample code for GLFW. Because of that, I decided to make a small game that others can use as a starting point for their own games.

The controls are very simple: The up and down arrow keys move your paddle and Esc quits the game.

Below is the complete code for HPong; 136 lines, including blank lines. Basic concepts include rendering the game, showing FPS and responding to keyboard input. The code is published as GPL and available from Hackage here. Have fun making your own games!

{-# LANGUAGE TemplateHaskell #-}

import Control.Monad
import Data.Accessor
import Data.Accessor.Basic (T)
import Data.Accessor.Template
import Data.IORef
import Graphics.Rendering.OpenGL
import Graphics.UI.GLFW

data Game = Game { scorePlayer_ :: Int, scoreCPU_ :: Int,
                   playerY_ :: Double, cpuY_ :: Double,
                   ballX_ :: Double, ballY_ :: Double,
                   ballVX_ :: Double, ballVY_ :: Double }
$( deriveAccessors ''Game )

windowW, windowH, paddleW, paddleH, paddleX, ballSize, ballSpeed :: Double
(windowW, windowH) = (640, 400)
(paddleW, paddleH, paddleX) = (20, 100, 50)
(ballSize, ballSpeed) = (20, 2)

main :: IO ()
main = do
    let newGame = resetBall $ Game 0 0 200 200 0 0 1 1
    game <- newIORef newGame
    initGL (floor $ windowW) (floor $ windowH)
    get time >>= newIORef >>= mainLoop game
    closeWindow
    terminate

initGL :: GLsizei -> GLsizei -> IO ()
initGL w h = do
    initialize
    openWindow (Size w h) [DisplayAlphaBits 8] Window
    windowTitle $= "HPong"
    lineSmooth  $= Enabled
    blend       $= Enabled
    blendFunc   $= (SrcAlpha, OneMinusSrcAlpha)
    windowSizeCallback $= windowResize

windowResize :: Size -> IO ()
windowResize s@(Size w h) = do
    viewport   $= (Position 0 0, s)
    matrixMode $= Projection
    loadIdentity
    ortho2D 0 (realToFrac w) 0 (realToFrac h)

mainLoop :: IORef Game -> IORef Double -> IO ()
mainLoop game lastFrame = do
    dt <- liftM2 (-) (get time) (get lastFrame)
    get time >>= writeIORef lastFrame

    handleInput (dt * 100) game
    game $~ update (dt * 100)
    render game
    displayFPS dt
    swapBuffers
    unless `pressed` ESC $ do
        sleep 0.001
        windowOpenStatus <- get $ windowParam Opened
        unless (windowOpenStatus == 0) $ mainLoop game lastFrame

handleInput :: Double -> IORef Game -> IO ()
handleInput dt game = do
    when `pressed` UP   $ game $~ movePaddle playerY dt
    when `pressed` DOWN $ game $~ movePaddle playerY (-dt)

movePaddle :: T r Double -> Double -> r -> r
movePaddle p d = p ^: min (windowH - paddleH / 2) . max (paddleH / 2) . (+ d)

update :: Double -> Game -> Game
update dt g = moveAI dt $ checkScore $ bounce $
              ballX ^: (+ g ^. ballVX * ballSpeed * dt) $
              ballY ^: (+ g ^. ballVY * ballSpeed * dt) $ g

moveAI :: Double -> Game -> Game
moveAI dt g = movePaddle cpuY (signum (g ^. ballY - g ^. cpuY) * dt) g

bounce :: Game -> Game
bounce g@(Game _ _ py cy bx by _ _)
    | by < 0       = ballVY ^: negate $ ballY ^= ballSize - by $ g
    | by > windowH = ballVY ^: negate $ ballY ^= 2 * windowH - ballSize - by $ g
    | hitPaddle bx by paddleX py && bx > paddleX
    = ballVX ^: negate $ ballX ^= paddleX + paddleBallDist $ g
    | hitPaddle bx by (windowW - paddleX) cy && bx < (windowW - paddleX)
    = ballVX ^: negate $ ballX ^= windowW - paddleX - paddleBallDist $ g
    | otherwise = g
    where paddleBallDist = paddleW / 2 + ballSize / 2

checkScore :: Game -> Game
checkScore g | g ^. ballX < 0       = resetBall $ scoreCPU ^: succ $ g
             | g ^. ballX > windowW = resetBall $ scorePlayer ^: succ $ g
             | otherwise            = g

hitPaddle :: Double -> Double -> Double -> Double -> Bool
hitPaddle bx by px py = abs (bx - px) <= ballSize / 2 + paddleW / 2 &&

                        abs (by - py) <= ballSize / 2 + paddleH / 2

resetBall :: Game -> Game
resetBall game@(Game sp sc _ _ _ _ _ _) =
    ballX ^= windowW / 2 $ ballY ^= windowH / 2 $
    ballVX ^= fromIntegral (1 - 2 * mod (sp + sc) 2) $ game

render :: IORef Game -> IO ()
render game = do
    (Game ps cs py cy bx by _ _) <- get game
    clear [ColorBuffer, DepthBuffer]
    color $ color3 1 0 0
    rectangle paddleX py paddleW paddleH
    color $ color3 0 0 1
    rectangle (windowW - paddleX) cy paddleW paddleH
    color $ color3 1 1 1
    rectangle bx by ballSize ballSize
    preservingMatrix $ do
        translate $ Vector3 50 350 (0 :: Float)
        renderString Fixed8x16 . ("You: " ++) $ show ps
        translate $ Vector3 450 0 (0 :: Float)
        renderString Fixed8x16 . ("CPU: " ++) $ show cs

displayFPS :: Double -> IO ()
displayFPS dt = do color $ color3 1 1 1
                   renderString Fixed8x16 . ("FPS: " ++) $ show (1 / dt)

pressed :: (Enum a) => (Bool -> b -> IO c) -> a -> b -> IO c
pressed cond key f = getKey key >>= flip cond f . (== Press)

rectangle :: Double -> Double -> Double -> Double -> IO ()
rectangle x y w h = renderPrimitive Quads $ mapM_ (vertex . vert2D)
                        [(x - w / 2, y - h / 2), (x + w / 2, y - h / 2),
                         (x + w / 2, y + h / 2), (x - w / 2, y + h / 2)]

color3 :: Double -> Double -> Double -> Color3 Double
color3 = Color3

vert2D :: (Double, Double) -> Vertex3 Double
vert2D (x,y) = Vertex3 x y 0

Hello world!

April 23, 2009

It wouldn’t be a programming blog without a Hello world post, now would it? 🙂