I read this quote on reddit, I feel like restating it:

I was surprised to see him seem to say explicitly that monads are a way to pass packets of state around. And that perpetuates the myth that there's some magic to monads that allows you to manipulate state in a pure way. Haskell "gets around" the problem of state by getting you to switch from writing a sequence of state-manipulating commands to composing functions, each of which defines a transformation of the state. That's it. No magic. Nothing clever. And monads don't come into it. But, if you wish, you can use monads to give a really nice notation for structuring those compositions.

Thank you sigfpe, for saying this.

A presentation I want to do at CSE@UNSW at some point soonish.

Let me know your thoughts.

Over the past few days I've been playing a fairly popular game for Google's Android platform on my phone. The game is called Shot. The rules of the game are fairly simple.

In a 7x9 grid, we have a variety of balls at certain positions.

Here's a simple example:

 o 
 o o o
 o 
 o o o o

   o o

 o  

The object of the game is to knock all the balls (except one) out of the grid. We can knock a ball in any of the four directions (up, down, left, right), subject to the following restrictions:

1. You can't move a ball off the edge of the map directly, you must instead send a ball on a collision course with another ball:

Illegal

 ↑
 o

 o

Legal

 o
 ↓
 o

2. You can't move a ball into a ball that is adjacent to it. So moving A down to strike B is illegal here, but moving A to C is legal.

 A→ C
 B

3. When a ball strikes another ball, the moving ball stops, and the stationary ball begins moving in the same direction. Once this happens, Rules 1 and 2 no longer apply for the moving ball.

Example: This move:

o→o oo

Results in this playing out:

 oo→oo

 o ooo→

 o oo

And hey! We've lost a ball. Rince and repeat to solve the puzzle:

Move 2:

 o ←oo

←oo o 

  o o

Move 3:

  o→o

   o

And we solved the puzzle! Admittedly, that example wasn't hard, but I'm sure you can imagine difficult examples (If you can't, play the game!).

I have an annoying tendency with puzzle games to become frustrated with them, to the point of writing solvers for them to save myself the trouble. Of course, once the solver is written, the game is ruined, but at least the solver was fun to write (don't ever ask me to solve a sudoku puzzle =P).

As with all Literate Haskell posts, let's begin the post with our imports, which you can ignore, but are there for the compiler and posterity.

1
2
3
4
5
6
7

module Main where

import Data.Maybe
import Data.List
import Prelude hiding (Left, Right)
import Control.Arrow
import Control.Monad

Okay, so, we're going to need some form of data type to represent the board. I chose a list of ball coordinates over a grid structure, sacrificing a bit of time efficiency in exchange for being able to use the lovely Data.List functions.

1
2
3
4
5
6
7

data Ball = Ball { ballX :: Int
                 , ballY :: Int 
                 } deriving (Show,Eq)

type Board = [Ball]

We'll also need a data type to represent a single step or move in the game. I represent it as:

• the ball that was moved
• the direction is was moved in

1
2
3
4
5
6
7
8
9

data Direction = Up 
               | Down 
               | Left 
               | Right 
               deriving (Show,Eq)

data Step = Step Ball Direction 
          deriving (Show,Eq)

Finally, we will use the Maybe type to encapsulate a series of Steps to represent a solution. Nothing means that there is no solution. In any other case, the series of steps provided will solve the puzzle.

1
2

type Solution = Maybe [Step]

Okay, enough of data types. Let's get on to solving algorithms. Seeing as each move in the game removes exactly one ball from the grid, and the object is to remove n - 1 balls from the grid (where n is the number of balls in the puzzle), I deduced that all solutions have the same length (n - 1), and hence a simple recursive backtracking algorithm will suffice.

That is, given a game state, deduce all the legal moves that can be made, then recursively call on each one with an updated gamestate reflecting the move, stopping after a valid solution is found.

Seeing as Solution is a Maybe type, I use Control.Monad's mplus operator, which, specifically for Maybe values, could be implemented like this:

1
2
3
4
5
6

     -- not part of solver
     mplus :: Maybe a -> Maybe a -> Maybe a
     mplus (Just a) _ = a
     mplus (Nothing) (Just a) = a
     mplus (Nothing) (Nothing) = Nothing

That is, it returns the first Just value it sees, and ignores all Nothing values. Applied to the solver problem, this means I can use it with foldr to select a solution.

1
2
3
4
5
6
7
8
9
10

solve :: Board -> Solution
solve board | isSolved board = Just [] 
solve board = foldr mplus Nothing $ map solver legalMoves 
  where
     solver m = case solve (applyMove m board) of
                     Just r  -> Just (m:r)
                     Nothing -> Nothing
     legalMoves    = filter (isLegal board) possibleMoves
     possibleMoves = concatMap (flip map [Up, Down,Left,Right]) (map Step board)

This function used alot of yet-undefined functions, the first being isLegal, that determines if a given move, given a certain state, is legal. In this function, I use Control.Arrow's >>> operator, which, for functions, is the same as flip (.) . As discussed in the preamble, the two conditions for a move to be legal are:

• The move will be stopped by another ball before reaching the edge of the screen.
• The move is not trying to move into an adjacent ball.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

isLegal ::  Board -> Step -> Bool
isLegal board (Step ball@(Ball x y) dir) = notAdjacent && willBeStopped 
   where
       willBeStopped = any check board
       check = and . \v -> map ($ v) $ checkFor dir
       checkFor Up    = [ballX >>> (==x), ballY >>> (< y)] 
       checkFor Down  = [ballX >>> (==x), ballY >>> (> y)]
       checkFor Left  = [ballX >>> (< x), ballY >>> (==y)]
       checkFor Right = [ballX >>> (> x), ballY >>> (==y)]

       notAdjacent = nextBall `notElem` board
       nextBall    = newCoords dir ball

newCoords :: Direction -> Ball -> Ball
newCoords Up    (Ball x y) = Ball x (y-1)
newCoords Down  (Ball x y) = Ball x (y+1)
newCoords Left  (Ball x y) = Ball (x-1) y
newCoords Right (Ball x y) = Ball (x+1) y

(the newCoords function is top-level as it is used elsewhere later on)

Naturally, the condition for a solved board is that there is only one ball left:

1
2
3

isSolved :: Board -> Bool
isSolved = length >>> (== 1)

(Once again I have used the >>> operator. I think it looks clearer than (\x -> length x == 1) or (==1) . length .

Finally there is the applyMove function, which, given a move and a board, updates the board to reflect the move. This function works as follows:

• Calculate the next position of the ball (the moveBall helper).
• Update the ball's position in a new board.
• If the ball just struck another ball, recursively call oneself, this time moving the struck ball in the same direction.
• If the ball has gone outside the bounds of the grid, remove it.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

applyMove :: Step -> Board -> Board
applyMove step board = filter (not . outsideBounds) $ applyMoveHelper step board
     where 
       applyMoveHelper (Step ball dir) board = let movedBall = moveBall dir ball 
                                                   nextBall  = newCoords dir movedBall
                                                   nextBoard = movedBall:delete ball board 
                                               in if nextBall `elem` board 
                                                   then applyMoveHelper (Step nextBall dir) nextBoard
                                                   else nextBoard

       moveBall dir ball | outsideBounds ball = ball
       moveBall dir ball = let nextBall = newCoords dir ball 
                           in if nextBall `elem` board 
                              then ball
                              else moveBall dir nextBall

       outsideBounds (Ball x y) = x > 6 || x < 0 || y > 7 || y < 0 

Finally, we have two functions used in the IO processing. One to convert strings to a Board representation, and one to do the reverse (with a border). The format looks something like this:

# #
 # #

 #

Producing the data structure: [Ball 0 0, Ball 2 0, Ball 1 1, Ball 3 1, Ball 1 3]

The strToBoard function uses a clever algorithm that assigns numbers (with zip) to each line and each character, then filters out all the non-hash characters, resulting in a simple set of coordinates that can be converted to a Board structure easily.

1
2
3
4
5
6
7
8
9
10
11
12
13
14

strToBoard :: String -> Board       
strToBoard str = rows (lines str) 
   where
     rows lines = concatMap cols $ zip lines [0..] 
     cols (l,y) = map (flip Ball y .snd) $ filter (fst >>> (=='#')) $ zip l [0..]

showBoard :: Board -> String
showBoard board = "+++++++++\n" ++ unlines (map (rowToString) groupedCoords) ++ "+++++++++\n"
   where
     rowToString = (++"+") . ('+':) . map charFor --also attaches border
     groupedCoords = groupBy (\a b -> snd a == snd b) allCoords
     allCoords = [(x,y) | y <- [0..8], x <- [0..6]]      
     charFor (x,y) = if Ball x y `elem` board then '#' else ' ' 

Finally, there remains anther output function to display a Solution in a way that can be digested by humans and copied into the game to solve a puzzle.

1
2
3
4
5
6

prettyPrint :: Board -> [Step] -> String
prettyPrint board moves = concatMap pretty $ zip moves $ boards
  where  
    boards = zipWith applyMove moves (scanl (flip applyMove) board moves) 
    pretty ((Step (Ball x y) dir),board) = show (x,y) ++ "=> " ++ show dir ++ "\n" ++ showBoard board 

The main function is then very straightforward, using the interact function that runs a String->String function through IO.

1
2
3
4
5

main :: IO ()
main = interact solver
  where
    solver str = let board = strToBoard str 
                 in prettyPrint board $ fromJust $ solve board

You can download the unliterate Haskell version of this here!