Archive for the ‘Non-CHP’ Category

Sharp Cards in Haskell: Drawing Cards

August 23, 2010 3 comments

Following on from my previous post on dice, in this post I’ll look at the support for cards that I am going to add to the next release of my game-probability library. So, cards: to work out the probability of drawing a particular sequence of cards from a deck of cards, you first need to specify which sequences you are interested in. How might you specify this, in Haskell? Here’s one way:

type DrawSpec card = (Int, [card] -> Bool)

That’s the sequence length paired with a function that decides whether a given sequence of that length is one we are interested in. There are two problems with this solution, though. Firstly, it requires fixing the length of the sequence upfront; we cannot decide how many cards to continue drawing based on the ones we have drawn. Secondly, it needs to be fed all the cards it requires at once, which means we must supply it with each possible permutations of cards separately, which will be quite inefficient.

Iterative Drawing: DrawF

Both of these problems can be solved with a more iterative approach:

data DrawF card = DrawFail | Done | DrawOne (card -> DrawF card)
                  | DrawAny (DrawF card)

So we have several options for the state of a draw: it can be successful, it can have failed, or it can need another card: DrawAny is like DrawOne . const, but can be much more efficient, as we’ll see in a future post. Let’s say we want to specify drawing N cards that are the same:

drawSameF :: Eq card => Int -> DrawF card
drawSameF n = if n <= 0 then DrawFail else DrawOne (drawMatch (n-1))

drawMatchF :: Eq card => Int -> card -> DrawF card
drawMatchF 0 _ = Done
drawMatchF n tgt
  = DrawOne (\x -> if x == tgt then drawMatchF (n-1) tgt else DrawFail)

With these sorts of specifications, we can much more easily narrow down the possibilities. Imagine you have a deck with multiple copies of each of ten distinct cards and you want to know the chance of drawing 5 the same. You can feed all ten to this function and get ten DrawOne results, which can be thought of as ten branches in a search. Then when you feed the ten cards again to each of those branches, only one card will not cause a failure, so you will still have ten branches. And the same the next time. So you will try 10*(10+10+10+10) cards in all: 400. This compares well to the 10^5=10,000 combinations you would trawl through if considering all possible permutations.

You can use this functional-style (hence the F suffix) Draw type to describe all draws relatively easily, using some function like this at the top level to ask for the probability of achieving that draw given a collection of cards:

chance :: [card] -> DrawF card -> Rational

Expanding the draw: DrawM

But there is one slight limitation. Let’s imagine that you want to return some result from the draw; for example, you may want to know what card it was that you drew many of, or you may want to return a count of cards. Currently DrawF has no way to return such a result. But we could add one by adding a value to the Done constructor:

data DrawM card a = DrawFail | Done a | DrawOne (card -> DrawM card a)
                  | DrawAny (DrawM card a)

As you may guess by the new M suffix, and important result of this is that we can make the type a monad. The instance practically writes itself:

instance Monad (DrawM card) where
  return = Done
  (>>=) DrawFail _ = DrawFail
  (>>=) (Done x) k = k x
  (>>=) (DrawAny m) k = DrawAny (m >>= k)
  (>>=) (DrawOne f) k = DrawOne (\x -> f x >>= k)
  fail _ = DrawFail

We use the Done constructor for returning values, and we make DrawFail short-circuit the draw, ignoring anything that comes after. We push the binds for DrawOne and DrawAny inside their constructors. There are several useful helper functions we can define in this new DrawM type:

draw :: DrawM card card
draw = DrawOne return

drawAny :: DrawM card ()
drawAny = DrawAny (return ())

drawWhere :: (card -> Bool) -> DrawM card card
drawWhere f = DrawOne (\x -> if f x then return x else DrawFail)

I couldn’t decide whether Done or return was clearer above, so swap them mentally if that helps. The drawMatch function from earlier goes from recursion to replicate:

drawMatch :: Eq card => Int -> card -> DrawM card ()
drawMatch n tgt = replicateM_ n (drawWhere (== tgt))

I like the monadic interface; drawing cards is inherently a sequence of steps, so seeing it written in do-notation makes it clearer than the nested style of the earlier type.

An Example: Pontoon

As an example, we’ll use Pontoon, a British variant on Blackjack. The general idea is the same as Blackjack (be closest to 21, but not over), with an added rule about five-card tricks (five cards with a total <= 21), which beat any non-Pontoon hand (Pontoon being 21 with two cards). We’ll leave aside the rules on splitting a pair to keep the example short. We’ll start with some quick definitions of a deck of playing cards (some Haskell that could come out of a beginner’s text-book):

data Rank = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten
  | Jack | Queen | King | Ace
  deriving (Bounded, Enum, Eq, Ord, Show, Read)

data Suit = Clubs | Diamonds | Hearts | Spades
  deriving (Eq, Ord, Show, Read)

data PlayingCard = PlayingCard {rank :: Rank, suit :: Suit}
  deriving (Eq, Ord, Show, Read)

deck :: Cards PlayingCard
deck = makeCards [PlayingCard r s | r <- [minBound .. maxBound],
                                    s <- [Clubs, Diamonds, Hearts, Spades]]

Now we can move on to the Pontoon-specific parts. First we will need a function that calculates the possible totals of a set of cards. Since aces can be low (worth 1) or high (worth 11) at the player’s choice, there are potentially multiple different totals that each hand can have:

values :: [Rank] -> [Int]
values [] = [0]
values (Ace:xs) = concat [[1 + v, 11 + v] | v <- values xs]
values (x:xs)
  | x `elem` [Jack, Queen, King] = map (10 +) (values xs)
  | otherwise = map ((fromEnum x + 2) +) (values xs)

The slightly awkward bit is the fromEnum part; since fromEnum Two == 0, we have to add 2 to get the right value. We can also define a data-type to hold the different non-bust results for a hand in Pontoon:

data Result = StuckOn Int | FiveCardTrick | Pontoon
  deriving (Eq, Ord, Show)

Note that the derived Ord instance will actually give a proper ordering of which hand is best: pontoon beats five-card trick beats the other results which are ordered by their numerical result (higher is better).

Pontoon Draw Strategy

The missing part is now a function to represent drawing cards in Pontoon. We’ll define a function corresponding to a fairly simplistic strategy: while we haven’t reached exactly 21 (or a five-card trick) with our hand, we’ll keep drawing as long as we’re below a constant upper limit (e.g. 15):

drawStrategy :: Int -> DrawM Rank Result
drawStrategy stickMin
  = do firstTwo <- replicateM 2 draw
       if 21 `elem` values firstTwo
         then return Pontoon
         else keepGoing firstTwo
    keepGoing cur
      | all (> 21) totals = badHand -- Bust!
      | length cur == 5 = return FiveCardTrick
      | 21 `elem` totals = return $ StuckOn 21
      | any (< stickMin) totals = do {c <- draw; keepGoing (c:cur)}
      | otherwise = return $ StuckOn (maximum $ filter (<= 21) totals)
        totals = values cur

To begin with, we draw two cards. If we can immediately achieve 21, that’s Pontoon and we stop. Otherwise we consider whether to keep drawing. We then have five choices listed in order (the guards of the inner function). If every possible total is above 21, we’re bust (badHand = DrawFail). If we have five cards (and aren’t bust), we have a five-card trick and we stop. If we’ve otherwise hit 21, we have a normal 21 with either three or four cards. The final two guards cover our decision: if we’re below our upper limit we keep drawing, and otherwise we stick with the best total we can manage that’s 21 or under.

So that fairly neatly lays out all the possibilities involved in drawing a hand of Pontoon. Now that we have this specification, we can calculate some odds. I’ll show the code and results here, but I will return to how the probabilities are calculated in my next post (to avoid this one growing too long):

main :: IO ()
main = do print $ to3dp <$> chanceMapOn rank deck (optional $ drawStrategy 14)
          print $ to3dp <$> chanceMapOn rank deck (optional $ drawStrategy 16)
          print $ to3dp <$>
            compareEvent (eventDrawOn rank deck (optional $ drawStrategy 14))
                         (eventDrawOn rank deck (optional $ drawStrategy 16))
    to3dp :: Rational -> String
    to3dp x = printf "%.3f" (fromRational x :: Double)

The optional function effectively maps successful draws into Just values and failed draws (i.e. bust) into Nothing; see the notes at the end of this post if you want more detail. This code will print three lines (which I’ve re-flowed below): the first will have a map from result to probability (which by that point will be a String) when we draw with less than 14, and the second will be the same when we draw with less than 16; the third will give the probability of the first strategy producing a worse, equal or better result than the second:

  [(Nothing,"0.086"), (Just (StuckOn 14),"0.125"), (Just (StuckOn 15),"0.122"),
   (Just (StuckOn 16),"0.114"), (Just (StuckOn 17),"0.110"),
   (Just (StuckOn 18),"0.101"), (Just (StuckOn 19),"0.095"),
   (Just (StuckOn 20),"0.135"), (Just (StuckOn 21),"0.050"),
   (Just FiveCardTrick,"0.013"), (Just Pontoon,"0.048")]

   (Just (StuckOn 16),"0.132"), (Just (StuckOn 17),"0.128"),
   (Just (StuckOn 18),"0.119"), (Just (StuckOn 19),"0.113"),
   (Just (StuckOn 20),"0.152"), (Just (StuckOn 21),"0.069"),
   (Just FiveCardTrick,"0.022"), (Just Pontoon,"0.048")]

fromList [(LT,"0.485"), (EQ,"0.097"), (GT,"0.418")]

So even though we can see from the first two sections that the first strategy (drawing again when less than 14) is much less likely to leave you bust (the Nothing outcome), we can see from the third section that in general it is more likely to lose (the LT outcome) against the second strategy (drawing again when less than 16) than win (the GT outcome). That’s a useful result, from what I hope is relatively readable code!

In the next post, we’ll take a look at how the probabilities are calculated.


  • The DrawM monad is a little reminiscent of iteratees, with all chunks being size 1. Generally, iteratees are designed to receive chunks of data as they become available. What this work does is take a DrawM item and supply with it many different possible next inputs to see what happens. I don’t know if much has been done with iteratees in this vein: it is somewhat like fuzzing iteratees to see what happens with different data.
  • This work looks at permutations of cards rather than combinations. Obviously looking at combinations could be much faster since there are a lot less of them (factorial in the number of cards drawn). Permutations is the more general case, and allows for testing based on the sequence of cards. In the Pontoon example, the sequencing and choice of drawing more is vital. In other scenarios, it isn’t needed, and examining all permutations merely adds computational overhead: win some, lose some.
  • The Pontoon example combines two aspects: one is the rules on scoring and stopping, and the other is the strategy for when to draw more. This is primarily convenience for the example: it would not be hard to alter the function to not take the stickMin parameter, and instead take a function that replaces the entire any (< stickMin) totals guard, thus parameterising the function by the user-defined strategy.
  • The optional call in the example uses the Alternative instance for DrawM card, which allows choice between draws to be expressed, and is given here:
    instance Alternative (DrawM card) where
      empty = DrawFail
      (<|>) DrawFail x = x
      (<|>) (Done x) _ = Done x
      (<|>) (DrawAny m) (DrawAny n) = DrawAny $ m <|> n
      (<|>) (DrawOne f) (DrawOne g) = DrawOne $ \x -> f x <|> g x
      (<|>) (DrawAny m) (DrawOne g) = DrawOne $ \x -> m <|> g x
      (<|>) (DrawOne f) (DrawAny n) = DrawOne $ \x -> f x <|> n
      -- Done or DrawFail on RHS:
      (<|>) (DrawAny m) n = DrawAny $ m <|> n
      (<|>) (DrawOne f) n = DrawOne $ \x -> f x <|> n

    The top few cases are straightforward: the empty choice is to fail, choosing between failure and anything will be anything, and choosing between success and anything will be success — the docs for Alternative don’t specify this, but I always take the operator to be left-biased. If we choose between DrawAny and DrawOne, we do need to know what card is next because the DrawOne needs to know. However, in all the other cases, neither side cares what the card is, so we can stick with DrawAny.

Categories: Non-CHP Tags:


January 14, 2010 2 comments

This post is tangentially related to CHP.

Version control is a key tool when programming. Recently, much work has gone into distributed version control systems (DVCS) that dispense with the requirement to have a single central repository, and allow a distributed, loosely-connected network of repositories. There are many DVCS systems out there, but I use darcs (which happens to be written in Haskell) whenever I can. All my Haskell code lives in darcs repositories, and this post is intended to detail a little of how I use it.

Darcs and CHP

Here is the structure of my darcs repositories for CHP across my three development machines (no prizes for guessing my machine naming scheme) for the past few weeks:

Each box is a repository, with the thin arrow-less lines indicating the directory structure. The empty-headed arrows indicate the ways in which patches are pushed and pulled (they are pushed in the direction of the arrow, and pulled in the opposite direction). The directions of the horizontal arrows are far from arbitrary; while both my laptop and university machine can SSH into my home machine (middle), neither of the outer two can be contacted via SSH. Hence they also cannot push and pull directly between each other.

I have about ten repositories in that diagram, which is probably typical for CHP. I tend not to do much work in the top three (the main repositories on each machine, akin to trunks), they are mainly pass-through repositories as I shift patches around. All the work is done in the lower repositories (branches, if you like), which may exist on several of the machines (e.g. the split repository for the recent 2.0 split) and have patches passed between them regularly, or may exist only on one machine. I am usually logged in to two of the machines at once, so that I can push my patches across and test them on several different GHC versions (until last week, all three machines had distinct versions of GHC: 6.8, 6.10, 6.12).

For my other major Haskell project, Tock (which I will also make a post about soon), I could make a similar diagram, but extended on to it are the repositories of the maintainer, Adam. He accepts my emailed patches into one repository to examine them, then he pushes to his main repository, and then later on pushes the patches to the webserver. So my working copy can be about seven repositories away from the publicly visible “trunk”, but it’s absolutely painless for both of us. There is a limit on how many branches is sensible of course, but darcs makes branching so easy that the branch of a branch is no trouble, even when that might make you uneasy in older version control systems.

I should probably make the CHP repository available on a webserver somewhere — please say if that’s something you’d be interested in. But such a public repository is unlikely to be much more up to date than the latest release. This is a combination of keeping my work in branches, and of my fairly regular release policy. You can see from the above diagram that I don’t necessarily release from the top middle repository (which is the closest I have to a “trunk”), although generally all the changes do eventually reach that repository.

Branch and Merge: Hunky

Darcs has easy branching and merging (especially compared to VCS systems like Subversion). One use I often make of branching is to get a clean copy of the repository. darcs get . foo will create a clean copy in the foo directory — i.e. a copy without any unrecorded changes. This is useful, for example, when you discover a bug and want to know if it was there before you made your current changes.

Darcs record has a particularly useful hunk-oriented interface. It interactively shows you all the changes you’ve made, and you can pick which ones you want to form a part of the current commit. This nicely reflects the fact that just because you made two changes to the same file, it doesn’t mean they have to end up in the same commit: for example, they may be fixing different bugs, but you happened to notice the presence of one while fixing another. So you can fix them both, then record them separately. This page shows an example. And I gather that hunk-splitting (which would make them even better) is coming in the next major release.

Other uses for Darcs

It’s not just Haskell code — in fact, even my home directory is a darcs repository (with my settings files recorded in it):

neil@beast ~: darcs show files

That way, when I get access to a new machine, I just darcs get from my home machine and I have the settings for my favourite editors and for bash (once I source that bash file in my .bashrc on the local machine). It’s an amazingly useful idea (thanks to Adam Sampson), and it means that if I modify any settings on any machine, I can record a patch and push it to my main home machine, then pull it onto all the other machines at a later date. So all my editor macros and so on can be easily kept up to date on all my machines, and I can rollback any change I make later on, if needed.

Summary and Donations

I imagine many Haskell programmers are already using darcs, and are aware of its usefulness. The Darcs team are currently running a bit of a fund-raising drive. If you use darcs as much as I do, perhaps you can consider donating a little by way of thanks. If you’re not a darcs and/or DVCS user, hopefully this post shows why it’s useful.

Categories: Non-CHP Tags:

Text.Printf and monad transformers

November 6, 2009 4 comments

(This post is about Haskell, but unrelated to CHP.)

A little while ago, Bryan O’Sullivan was developing his Criterion benchmark suite, and had trouble with using the Text.Printf module in a monad transformer on top of IO. I thought I knew how to solve this, but my first idea didn’t work — and nor did my second or third. Eventually I figured out how to do it, and the patches made it into the new Criterion release. I’m posting about it here in case anyone else has the same trouble in future.

My solution achieves two things. It allows the use of (equivalents to) printf and hPrintf in the monad ReaderT Config IO, but also allows you to decide whether to print based on that Config item — for example, based on a verbosity level stored in the config. If you had StateT Config IO, or various other transformers and combinations thereof, this approach should still work.

So, why is this problematic in the first place? If you are willing to annotate every use of hPrintf with liftIO, you get the first behaviour already:

liftIO $ printf "String: %s, Int: %d" "hello" 42

However, you can’t just define a helper:

myPrintf = liftIO . printf

Because that breaks the magic of printf. Printf works by letting the return type of printf "some string" vary; it can either be IO a, if there are no more arguments to feed to printf, or it can be a -> r, where a is the type of the next argument to printf, and r is again a varying type. So adding liftIO . on the front forces printf to have the IO a type straight away, thus breaking the vararg tricks.

We must add a new type-class with the same basic idea as printf, but with some adjustments. This is made harder because the implementation of printf and hPrintf (which we still want to use, rather than re-implement) is hidden in the Text.Printf module and is unavailable to us.

What we do is construct something a bit like a list fold. Here is the type of the standard foldl function, with some more descriptive type names than usual:

foldl :: (agg -> listItem -> agg) -> agg -> [listItem] -> agg

We can conceive of a slightly different interface:

data Fold agg listItem = Fold agg (listItem -> Fold agg listItem)

foldl :: Fold agg listItem -> [listItem] -> agg

The data-type Fold contains the current aggregate value (the first item of Fold) to use if there are no more list items, and a function that, given the next list item, will return the next Fold instance (the second item of Fold).

We can create an analogous type for printf (if you think of printf doing a left fold over its variable number of arguments):

data PrintfFold = PrintfFold (IO ()) (PrintfArg a => a -> PrintfFold)

(Note that this requires Rank2Types.) The first item, of type IO (), represents the “print now with all the arguments you’ve got so far” item, whereas the second, of type PrintfArg a => a -> PrintfFold is the “here’s one more argument, now give me a new PrintfFold” item. To implement our wrapper around printf that supports varargs, we will need our own type-class that is based around this PrintfFold type:

class PrintfWrapper a where
  wrapPrintf :: (Config -> Bool) -> PrintfFold -> a

The wrapPrintf function takes a decision function (given this config, should the item be printed?), our PrintfFold and becomes the type that is the parameter to the class (this part mirrors printf’s vararg magic). The base instance, for acting in the ReaderT Config IO monad, is:

instance PrintfWrapper (ReaderT Config IO a) where
  wrapPrintf check (PrintfFold now _f)
    = do x <- ask
         when (check x) (liftIO now)
         return undefined

This checks, based on the value of the config, whether to print the item — the printing is done using the now action from our PrintfFold type. Finally, we return an undefined value, which is what printf does too (printf allows its return type to vary to avoid upsetting the type inference). Our instance for when another argument is passed is very simple:

instance (PrintfWrapper r, PrintfArg a) => PrintfWrapper (a -> r) where
  wrapPrintf check (PrintfFold _now f) x = wrapPrintf check (f x)

This just continues the pseudo-fold by adding this argument. The final piece of the puzzle is the top-level new printf function. We can use this one new type-class defined above to write replacements for printf and hPrintf; I’m showing the hPrintf version:

chPrintf :: PrintfWrapper r => (Config -> Bool) -> Handle -> String -> r
chPrintf check h s = wrapPrintf check $ make (hPrintf h s) (hPrintf h s)
    make :: IO () -> (forall a r. (PrintfArg a, HPrintfType r) => a -> r) -> PrintfFold
    make asIs oneMore = PrintfFold asIs (\x -> make (oneMore x) (oneMore x))

The interesting bit here is the make function that constructs a PrintfFold. It takes two arguments: the action to execute if there are no further arguments to printf, and the function to get a new fold when you feed it another argument. These two arguments always come from the same code, but the code can take on the two types because of the way printf can have these two different types.

Our new chPrintf function can be used just like hPrintf, but in the ReaderT Config IO monad:

data Config = Config {decide :: Bool}

main :: IO ()
main = flip runReaderT (Config True) $
  do chPrintf decide stdout "String %s, Int %d" "hello" (42::Int)
     chPrintf decide stdout "No Args"

If you change that True to False, the text will not be printed. It should be easy to see how an instance could be defined to use my approach with the StateT Config IO monad or similar. It is also possible to define an instance to use the exact same chPrintf function in the normal IO monad (which will ignore the check based on the config, since it has no config item available to check):

instance PrintfWrapper (IO a) where
  wrapPrintf _check (PrintfFold now _f) = now >> return undefined

This is useful if in some places in your code you want to use a wrapper function based on the chPrintf function in the IO monad (Criterion does this in a couple of places). Now that you have chPrintf, it becomes easy to define a wrapper function that prints some vararg bits when the verbosity is above a certain level; here is some code from Criterion that does just that:

note :: (PrintfWrapper r) => String -> r
note = chPrintf ((> Quiet) . fromLJ cfgVerbosity) stdout

This can then be used like printf:

note "bootstrapping with %d resamples\n" numResamples

Other variations on the pattern presented here are possible; the Handle could be retrieved from a StateT monad (if you make both the items in the PrintfFold take a Handle as a parameter), or a standard prefix added to all printed text — where the text is similarly taken from some reader or state monad transformer. The good thing from a code standpoint is that I didn’t need to duplicate any of the printing functionality from the Text.Printf module, nor did I need anything more than its normal publicly visible interface; I just needed to arm-wrestle the type system for a while — and use Rank2Types.

Categories: Non-CHP