Posts Tagged ‘game’

Programming Praxis – Petals Around The Rose

December 18, 2012

In today’s Programming Praxis exercise, our goal is to implement the well-known “Petals Around the Rose” game. Let’s get started, shall we?

Some imports:

import Control.Monad
import System.Random
import Text.Printf

We’ll need to show the intro text.

showIntro :: IO ()
showIntro = putStrLn
  "Let's play 'Petals Around The Rose.'\n\
  \The name of the game is significant.\n\
  \At each turn I will roll five dice,\n\
  \then ask you for the score, which\n\
  \will always be zero or an even number.\n\
  \After you guess the score, I will tell\n\
  \you if you are right, or tell you the\n\
  \correct score if you are wrong. The game\n\
  \ends when you prove that you know the\n\
  \secret by guessing the score correctly\n\
  \six times in a row.\n"

When playing, we keep a count of the current streak length. After 6 consecutive correct guesses we assume the player has figured out the trick. Otherwise, we roll 5 dice and see if the player’s guess is correct.

play :: Int -> IO ()
play 6      = putStrLn "Congratulations! You are now a member\n\
                       \of the Fraternity of the Petals Around\n\
                       \The Rose. You must pledge never to\n\
                       \reveal the secret to anyone."
play streak = do
    dice <- replicateM 5 $ randomRIO (1,6)
    putStrLn $ "The five dice are: " ++ unwords (map show dice)
    putStr "What is the score? "
    guess <- readLn
    if guess == score dice
    then putStrLn "Correct\n" >> play (streak + 1)
    else printf "The correct answer is %d.\n\n" (score dice) >> play 0

And here’s the heart of the program: the score function. It’s pretty simple, once you know the secret.

score :: [Int] -> Int
score = sum . map ([0,0,0,2,0,4,0] !!)

To play a game, just show the intro and start playing.

main :: IO ()
main = showIntro >> play 0
Advertisements

Programming Praxis – A Dozen Lines Of Code

January 24, 2012

In today’s Programming Praxis exercise, our goal is to make any program we want, as long as it’s cool and it fits within 12 lines of code. I decided to make an implementation of Conway’s Game of Life: it’s interesting, it’s visual, it’s Turing complete… how much cooler can you get? Let’s get started, shall we?

First, some imports. I’m not counting these as lines of code since to me a line of code is something that can contain a bug.

import qualified Data.List.Key as K
import qualified Data.Map as M

First we define the rule that the game of life is based on: cells stay alive if they have 2 or 3 neighbors, and they become alive if they have 3 neighbors.

rule (cy,cx) m = elem ns $ if alive (cy,cx) then [2,3] else [3] where
    ns = sum [1 | y <- [-1..1], x <- [-1..1], (y,x) /= (0,0), alive (cy+y,cx+x)]
    alive c = M.lookup c m == Just 'x'

We calculate the next generation of a grid by determining the rectangle that holds the active cells, adding a one-cell border (since that’s the furthest influence distance) and calculating the new state for each cell in the resulting rectangle.

step m = if null on then M.empty else M.fromList
    [((y,x),if rule (y,x) m then 'x' else '.') | y <- range fst, x <- range snd]
    where on = M.keys $ M.filter (== 'x') m
          range f = [minimum (map f on) - 1..maximum (map f on) + 1]

Next, we need some functions to load and show a generation:

load s = M.fromList [((y,x),c) | (y,l)<-zip [0..] $ lines s, (x,c)<-zip [0..] l]

display = mapM_ (putStrLn . map snd) . ([] 🙂 . K.group (fst . fst) . M.assocs

The program reads the input from a text file that holds the starting situation, e.g.

.....
.xxx.
.x...
..x..
.....

and then prints all of the subsequent generations until the pattern stabilizes, i.e. it finds two subsequent identical generations.

main = mapM_ (display . snd) . takeWhile (uncurry (/=)) .
    (\l -> zip l $ tail l) . iterate step . load =<< readFile "life.txt"

And that’s it. A cool little program that’s even one line under our budget of 12.

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:

(7,232,39.391)
(7,127,26.2546)
(7,91,21.8529)
(7,73,19.3968)
(7,57,17.7395)

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 – Slots

January 14, 2011

In today’s Programming Praxis exercise, our goal is to create a game that simulates a slot machine. Let’s get started, shall we?

Some imports:

import Control.Monad
import Data.List
import System.Random
import Text.Printf
import Text.Read.HT

Pulling the lever spins the wheels, prints the result and returns the amount of money gained or lost.

pull :: Int -> IO Int
pull n = do ws <- replicateM 3 $ randomRIO (0,5)
            putStrLn . unwords $ map (wheel !!) ws
            result . group $ sort ws where
    wheel = words "BAR BELL ORANGE LEMON PLUM CHERRY"                
    result [[0,0,0]] = win "JACKPOT" 101
    result [_]       = win "TOP DOLLAR" 11
    result [[0,0],_] = win "DOUBLE BAR" 6
    result [_,_]     = win "DOUBLE" 3
    result _         = printf "YOU LOSE $%d\n" n >> return (-n)
    win msg d = printf "***%s***\nYOU WIN $%d\n" msg (n*d) >> return (n*d)

In order not to have to repeat ourselves in the main loop, we create a function that gets a valid bet.

prompt :: IO Int
prompt = do putStr "ENTER YOUR BET: "
            maybe prompt check . maybeRead =<< getLine where
    check bet | bet < 0   = prompt
              | bet > 100 = putStrLn "HOUSE LIMIT $100" >> prompt
              | otherwise = return bet

Playing the game shows the instructions and starts playing. After every pull of the lever, the current balance is shown. Quitting the game (by betting $0) prints the final balance.

main :: IO ()
main = instructions >> loop 0 where
    instructions = putStrLn "WELCOME TO THE CASINO\n\
        \BET IN INCREMENTS OF $1 FROM $1 TO $100\n\
        \BET $0 WHEN YOU ARE FINISHED"
    loop purse = prompt >>= \bet -> if bet == 0 then quit purse
        else fmap (+ purse) (pull bet) >>= \n -> status n >> loop n
    status n | n > 0     = printf "YOU HAVE $%d\n" n
             | n < 0     = printf "YOU OWE $%d\n" (-n)
             | otherwise = putStrLn "YOU ARE EVEN"
    quit total | total > 0 = printf "COLLECT $%d FROM THE CASHIER\n" total
               | total < 0 = printf "PLACE $%d ON THE KEYBOARD\n" (-total)
               | otherwise = putStrLn "YOU BROKE EVEN"

Here’s a sample game:

WELCOME TO THE CASINO
BET IN INCREMENTS OF $1 FROM $1 TO $100
BET $0 WHEN YOU ARE FINISHED
ENTER YOUR BET: 100
LEMON BELL BELL
***DOUBLE***
YOU WIN $300
YOU HAVE $300
ENTER YOUR BET: 100
BAR ORANGE PLUM
YOU LOSE $100
YOU HAVE $200
ENTER YOUR BET: 100
BELL PLUM BELL
***DOUBLE***
YOU WIN $300
YOU HAVE $500
ENTER YOUR BET: 100
BAR CHERRY BAR
***DOUBLE BAR***
YOU WIN $600
YOU HAVE $1100
ENTER YOUR BET: 0
COLLECT $1100 FROM THE CASHIER

If only real slot machines were this profitable 🙂

Programming Praxis – Conway’s game of life

May 11, 2010

With the author of Programming Praxis currently hospitalized, I’ll be posting some programming exercises in his stead until he’s recovered.

Conway’s game of life is the most well-known example of cellular automata. It consists of a 2D grid where each cell is either alive or dead. Alive cells stay alive if they have 2 or 3 alive neighbors, otherwise they die. Dead cells become alive when they have 3 alive neighbors. Other rule variations exist, but Conway’s version is the most commonly used one. These simple rules result in a lot of complexity. In fact, the game of life is equivalent to a universal Turing machine.

Theoretically, Conway’s game of life takes place on an infinite grid, but for practical reasons the size of the grid is often limited, with cells beyond the edges being assumed dead.

In today’s exercise, your task is to write an algorithm that takes a starting situation and can produce an arbitrary number of subsequent generations. When you are finished, you are welcome to read a suggested solution below, or to post your own solution or discuss the exercise in the comments below (to post code, put it between [code][/code] tags).

 
 

First, some imports.

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

Cells stay/become alive if they have 3 neighbors, or 2 if they’re already alive. Anything else dies.

rule :: (Num a) => Char -> a -> Bool
rule c n = c == 'x' && n == 2 || n == 3

Since the algorithm needs to check a cell’s neighbors, we need to know what they are.

neighbours :: (Int, Int) -> [(Int, Int)]
neighbours (y,x) = [(y', x') | y' <- [y-1..y+1], x' <- [x-1..x+1],
                               (y', x') /= (y, x)]

We will need a way to load the starting situation.

load :: String -> M.Map (Int, Int) Char
load = M.fromList . concat . zipWith (\y -> zipWith (\x c ->
           ((y, x), c)) [1..]) [1..] . lines

To obtain the next generation, we just apply the rule to every cell.

next :: M.Map (Int, Int) Char -> M.Map (Int, Int) Char
next b = M.mapWithKey (\k a -> if rule a . length .
             filter (\p -> M.findWithDefault '.' p b == 'x') $
             neighbours k then 'x' else '.') b

Next, we need a function to show a generation in a more readable format.

display :: M.Map (Int, Int) Char -> String
display b = unlines . chunk (snd . fst $ M.findMax b) $ M.elems b

And, finally, something to show multiple subsequent generations.

run :: Int -> M.Map (Int, Int) Char -> IO ()
run n = mapM_ (putStrLn . display) . take n . iterate next

Let’s test to see if everything’s working correctly.

main :: IO ()
main = run 10 $ load ".........\n\
                     \.xx......\n\
                     \.xx..xxx.\n\
                     \.....x...\n\
                     \......x..\n\
                     \..x......\n\
                     \..x......\n\
                     \..x......"

If you implemented everything correctly, the last generation should look like this:

.....xx..
....x..x.
.....xx..
.........
..xx.....
.x..x....
.x.x.....
..x......

Programming Praxis – Spectacular Seven

May 4, 2010

In today’s Programming Praxis exercise our task is to run a simulation of a ballgame to see if the scoring mechanic is fair. The provided Scheme solution clocks in at 25 lines. Let’s see if we can do any better.

First, some imports.

import Control.Applicative
import Control.Monad
import Data.List
import System.Random

After a match, the winner gets a point and the loser is moved to the end of the queue.

match :: Int -> [(a, Int)] -> Int -> [(a, Int)]
match ps ~(x:y:r) w = (p,s + if ps > 7 then 2 else 1) : r ++ [c]
    where ((p,s), c) = if w == 0 then (x,y) else (y,x)

A game ends when one of the teams has 7 or more points.

game :: IO Int
game = f 0 (zip [1..8] [0,0..]) . randomRs (0,1) <$> newStdGen
       where f ps a ~(x:xs) = maybe (f (ps+1) (match ps a x) xs) fst $
                              find ((>= 7) . snd) a

To simulate the game, we play a number of games and calculate the winning percentages of each team.

simulate :: Int -> IO [Float]
simulate n = (\ws -> map (\x -> 100 * (l x - 1) / l ws) . group .
                     sort $ ws ++ [1..8]) <$> replicateM n game
             where l = fromIntegral . length

All that’s left is to run the simulation.

main :: IO ()
main = mapM_ print =<< simulate 10000

That leaves us with 7 lines, more than a two thirds reduction compared to the Scheme solution. That’ll do nicely.

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!

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