Haskell Lens Isomorphisms

A small snippet of code I wrote to try and get my head around Van Laarhoven lenses. It shows the isomorphisms between three common representations of lenses.

{-# LANGUAGE RankNTypes #-}

-- Traditional lens as a pair of getter and setter
type Lens a b = (b -> a, b -> a -> b)

-- Lens implemented with a store comonad
data Store a b = Store { get :: a, set :: a -> b }

instance Functor (Store a) where
    fmap f (Store a ab) = Store a (f . ab)

type SLens a b = b -> Store a b

-- Van Laarhoven lens
type VLLens a b = forall g . Functor g => (a -> g a) -> (b -> g b)

-- Lens / SLens isomorphism

lensToSlens :: Lens a b -> SLens a b
lensToSlens (getter, setter) = \b -> Store (getter b) (setter b)

sLensToLens :: SLens a b -> Lens a b
sLensToLens slens = (get . slens, set . slens)

-- SLens / VLLens isomorphism

sLensToVLLens :: SLens a b -> VLLens a b
sLensToVLLens slens = \f b -> let Store a ab = slens b in fmap ab $ f a

vLLensToSLens :: VLLens a b -> SLens a b
vLLensToSLens vllens = \b -> ((flip vllens) b) (\a -> Store a id)

Ubuntu on the Gigabyte P34G Ultrablade

In my previous post on the Gigabyte P34G I looked at my reasons for buying it and first impressions. In this post, I'm going to look at installing and setting up Ubuntu GNU/Linux on this machine.

Installation and Setup

Creating USB installation media

On another Ubuntu machine:

• Download the Ubuntu Live CD ISO.  I started with Ubuntu 13.04, but you are probably better off to go straight to 13.10 for reasons described below.
• Copy to USB stick using usb-creator-gtk (or dd if you're feeling more adventurous, but make sure you don't wipe your hard disk by mistake!).

BIOS settings

To get to the BIOS settings you first need to boot into Windows 8 and then do a proper shutdown (i.e. not a fastboot shutdown).  I used the pre-installed Gigabyte utility to do this as the standard Windows shutdown just went into fastboot mode.

Insert the USB stick then boot into the BIOS by holding down <F2> during startup.
BIOS settings:

• Disable 3D Graphic Acceleration.  The X server won't start unless you do this.  I think it's getting confused about which graphics adapter to use.
• Intel Rapid Start Technology.  Not sure if this is necessary.
• Disable Secure Boot.  Again, not sure that it's necessary.
• Set boot sequence to boot from the USB stick.

Boot the USB stick and select 'Install'.

Note: I originally tried installing Linux Mint 15, but could not get the installation media to boot, even with the BIOS changes described above, which was why I went with Ubuntu instead.

Partitioning

I deleted the Windows partition on the 256GB SSD and replaced it with:

• 25GB Ext4 Linux root (/) partition
• 16GB free space which I will hopefully be able to use with Intel Rapid Start Technology some time in the future (pending Linux kernel support, see http://www.phoronix.com/scan.php?%20page=news_item&px=MTQwMzU)
• Remainder Ext4 partition for /home

There were two partitions for Windows restore, a small 20MB partition at the start and a larger 30GB partition at the end of the SSD.  I kept both of these for now, in case I need to restore Windows 8 for some reason.  I will probably eventually end up removing the 30GB and extending the size of /home. I also kept the EFI boot partition which is required for UEFI boot as the disk uses GPT.

If you want to dual boot Windows 8 and Ubuntu you should be able to shrink the size of the Windows partition to fit the Linux partitions in.

I partitioned the 1TB HDD as

• 16GB for swap.  Unlikely to ever actually use this, but it's there just in case.
• Remainder Ext4 partition to mounted as /data.

Wifi

After booting for the first time I noticed that the wifi card (Intel Centrino 7260) was not detected.  After reading http://askubuntu.com/questions/322511/no-wireless-with-intel-centrino-advanced-n-7260 I determined that I needed to upgrade the Linux kernel to 3.11 (from 3.08), and possibly install some firmware binaries, to get this card to work.  I couldn't find kernel 3.11 packages for Ubuntu 13.04, but noticed that it is the standard kernel in 13.10, which is due for release in just over 2 weeks.  I decided the easiest option was probably to just upgrade to the latest development version of Ubuntu 13.10 which I did by connecting an ethernet cable to my router and running sudo upgrade-manager -d.  If you're installing from scratch, I'd recommend going directly to Ubuntu 13.10 rather than installing 13.04 first.  It may have even been officially released by the time you read this.  Installing the firmware binary was not necessary.  It must have been included either by Ubuntu or an update to the Linux kernel since the above-linked post was written.

The other thing I've noticed about wifi is that it occasionally just stops working.  It's happened maybe two or three times in the week since I've had the laptop.  It's probably a sign that the drivers aren't yet mature.  It can be easily fixed by running sudo rmmod iwlwifi; modprobe iwlwifi to remove and re-insert the wifi driver module.  Hopefully this problem will go away after some future kernel upgrade.

SSD options in fstab

Once you've got the system up there are a couple of flags you need to add to the entries for the SSD partitions in /etc/fstab:

• Add the discard flag to enable TRIM.  The will prevent performance decreasing over time as the drive fills up.
• Add noatime flag to avoid causing a write to the SSD every time you do a read (which will wear the SSD out much faster than necessary).

I'm suprised the Ubuntu installer doesn't set these options by default for SSD drives.

Sound

The first time I tried playing a YouTube video in Ubuntu there was no sound.  I've since noticed that the sound is now working so not sure what was going on there.

Touchpad

The touchpad is very sensitive to accidental palm touches, making typing a frustrating experience. You can easily disable it when necessary using  Fn-F10 key combination. You can also use synclient to configure palm detection, see e.g. http://askubuntu.com/questions/205512/touchpad-palm-sensitivity.  I had to use very low values (PalmMinWidth=3 PalmMinZ=1) to get it to be usable, but YMMV.  You can also use synclient to configure other settings, such as two-finger scrolling and three-finger tap for middle mouse button.

One weird thing I noticed was that the other evening, after I had been playing with BIOS settings trying to work out what the minimum changes were that were needed to get Ubuntu to boot, I booted up and found that the touchpad was no longer working.  Neither xinput nor synclient could find the touchpad at all.  I plugged in a USB mouse which worked, but nothing I tried could get the touchpad to re-appear.  Feeling frustrated, I turned off the computer and went to bed.  Next day when I started it up the touchpad was back.  No idea what happened there and hoping it doesn't happen again.

Bluetooth

Bluetooth is provided by the Intel Centrino 7260 wifi card.  Ubuntu reports that it is working, but in a quick test I could not get it to pair up with my phone.  The phone couldn't see the laptop and neither could the laptop see the phone.  I didn't investigate this too much because I don't really have a need for it.  It may be another sign of driver immaturity for this card.

Suspend

Suspend seems to work.  I have it set to suspend when I close the lid and it has so far always come back ok.  I am hoping a future Linux kernel will support Intel Rapid Start and, as mentioned previously, have left space on the SSD for it.

Still to do

Things I still need to do:

• Install Bumblebee and the NVidia drivers to allow the GTX 760M to work with Optimus.  I'm currently not using it at all and relying on the Intel integrated graphics.  I did briefly try using the latest NVidia driver, which is supposed to have Optimus support without requiring Bumblebee, however, even after re-enabling "graphics acceleration" in the BIOS I could not get the X server to start.  I haven't had time to investigate this further.
• I find that the hard disk occasionally spins up when I'm not using it.  This may be related to the kernel "swappiness" parameter (I have a swap partition there, but it shouldn't be using it with 16GB of RAM), or it may be due to some other activity.  Not sure yet.
• Install XMonad instead of the Unity window manager.
• Check out whether I can get Intel Rapid Start to work.

Gigabyte P34G Ultrablade laptop

Key specifications

• Gigabyte P34G Ultrablade laptop
• 14 inch 1920x1080 AHVA (IPS) matte display
• Intel Haswell Core i7-4700HQ CPU with integrated Intel HD 4600 graphics
• NVidia GeForce GTX 760M discrete graphics with Optimus support
• 16GB DDR3 1600MHz RAM
• 256GB mSATA SSD
• Space for a 2.5 inch x 9.5mm SATA HDD (I purchased and installed a Seagate 1TB 5400rpm SSHD)
• 21mm thickness
• 1.76kg weight (including HDD)

Reasons for choosing it

This laptop is replacing a 5 year old Lenovo Thinkpad T61 which has a brilliant keyboard and touchpad (including middle mouse button) and average 15.4 inch 1680x1050 TFT screen with poor viewing angles and quite dull display.  With its slow (by today's standards) Core 2 Duo CPU, slow 256GB HDD, only 4GB RAM (with no possibility to upgrade) and pretty much dead battery (lucky to get 5 minutes out of it) it was time to upgrade.

I was originally tempted by the 15 inch Macbook Pro Retina, but ruled it out due to the price.  Next I considered the new generation of Haswell Thinkpads, which have been announced, but have not yet been released.  I have only ever owned Thinkpad laptops before (previously an IBM T40) and have always been very happy with them, in particular build quality, keyboard and touchpad, so was a bit hesitant to go for something else.  The models I was considering are the T440s and T440p.

I decided to go for a 14 inch model rather than 15.6 inch because I wanted something a bit thinner and lighter than my current Thinkpad.  Also it seems to have become almost impossible to get a 15 inch laptop without a numeric keypad, even the new Thinkpads have them.  I want to have my right hand on the right-hand side of the keyboard when typing, not over on the left with my wrist twisted into an RSI-inducing position.

Requirements for my ideal laptop

• 14 inch (at least) 1920x1080 (at least) matte IPS display (with good viewing angles and reasonable colour gamut, suitable for photo editing)
• Haswell Core i7 CPU, preferably quad core
• Preferably at least 16GB RAM
• At least 256GB SSD and preferably option for an additional HDD or larger SSD
• No numeric keypad
• Reasonably thin (prefer < 25mm) and light (prefer < 2kg)

Reasons I chose the Gigabyte over the Thinkpad models

• Decent quad core CPU (T440s has a ULV dual core CPU, T440p will probably have the 4700MQ which is not much different to the 4700HQ on the P34G)
• 16GB RAM standard (T440s maxes out at 12GB, T440p supports up to 16GB, but at extra cost)
• Similar size and weight to T440s (T440p is a fair bit thicker and heavier)
• Option for 256 GB SSD and 1TB HDD (in the Thinkpads you have to choose one or the other and 256GB seems a bit small if you're doing lots of photo editing and want space for virtual machines and/or Windows/Linux dual boot)
• It's available now, Thinkpads not expected to be available until at least November.
• At $1700 it's probably about $1000 less than I'd expect to pay for one of the new Thinkpads with similar specs.

First thoughts

• Case feels very solid, despite being so thin and light.  Seems to have very good build quality and no noticeable flex.
• Display is bright and crisp with good viewing angles.  There is some backlight leakage along the bottom and in the top right corner, but only noticeable when looking at a very dark screen in a very dark room.  There is one bright green stuck pixel in the centre-left of the display, but again is only noticeable when looking at very dark images (although I never noticed any stuck/dead pixels on either of my Thinkpads).
• Keyboard is not nearly as good as either of my previous Thinkpad keyboards, but then I don't think anything is these days.  I'm sure it will be ok, although I've noticed that occasionally pressing letters near the centre (e.g. N, M) will result in a double press being registered.  Page Up, Page Down, Home and End keys are only accessible by using the arrow keys with the Fn button pressed.  I think that is pretty typical these days (my colleague's new Dell XPS is the same), but it seems strange given how essential these keys are for navigation.  I think Page Up and Page Down can be emulated via 3-finger swiping on the touchpad, so maybe I'll get used to it.
• Touchpad seems unresponsive at first, especially for two-finger scrolling.  However, after some adjustments it seems to be ok.  I miss the middle mouse button on the Thinkpad, but it can be emulated with a three-finger tap.  Something else to get used to I guess.  The touchpad is huge compared to what I'm used to.  I keep accidentally touching it while typing, which leads to unexpected and annoying behaviour.  Will need to do some tweaking to the palm detection settings to avoid this.
• Windows 8 starts up very quickly and feels snappy, but how do I actually use it?  They seem to have made the most useful functionality deliberately hard to find.  Will need to get Linux on here ASAP.
• Despite having two massive fans, with two massive air vents at the back (one each for the CPU and GPU), the machine is almost silent when idling.  I suspect the fan noise will pick up when I put the CPU and GPU to some serious use.
• The hard drive was very easy to install: remove about 15 screws and take off the back cover.  Plug HDD into the SATA cable and slot into place.  Replace the cover and screws.  I plan to use the HDD as secondary storage for my photos and a Windows VM or two so most of the time it's not spinning and the machine is quiet.  You definitely know when it spins up though – it's quite noisy.

Still to come...

I plan to write a follow-up post on my experience installing Ubuntu GNU/Linux on this machine.

Update 2013-10-3: Blog post on Ubuntu installation is now available. 

Running E-tax 2013 on Ubuntu 13.10

E-tax is the Australian Tax Office's antiquated Windows software for completing and filing personal tax returns. It's possible to run it under Linux using Wine. Here are the steps for Ubuntu 13.10. It should also work on older versions of Ubuntu and possibly other Debian derivatives.

• export WINEARCH=win32
• sudo apt-get install winetricks
• winetricks msxml4
• wget http://www.ato.gov.au/misc/downloads/etax2013/etax2013_1.msi
• msiexec /i etax2013_1.msi

Update 14/10/2013

When filling out my spouse's details I noticed that the radio buttons for spouse's gender were disabled.  At the time I just assumed they no longer considered the question relevant and didn't think more of it.  However, when I went to lodge my tax return I got the cryptic error

V2357 - Spouse's ATI amount for income test purposes is incorrect.

I couldn't work out what the problem was so eventually ended up booting up an old laptop with Windows Vista, installing e-Tax on it and copying my tax file across.  That didn't resolve the error, but at least I could view the error description in the help docs, which basically just said call the ATO personal tax help line if you get this error.

Of course I was doing this on a Saturday afternoon and the help line is only open 8am to 6pm Monday to Friday so I had to wait until Monday morning.  I called the help line, got transferred to e-Tax technical support then back to the help line before I got someone who was able to help.  After 45 minutes on the phone, we eventually determined that the problem was with the aforementioned spouse's gender radio button.  It turns out that on Vista the buttons do work and once I entered the correct gender the error went away.

Note to the ATO's e-Tax developers: would it have been so hard to supply a meaningful error message so I didn't have to waste so much of my time and your help desk's time on this trivial issue?

References

• http://forums.whirlpool.net.au/forum-replies.cfm?t=2122383&p=4
• http://appdb.winehq.org/objectManager.php?sClass=version&iId=28504
• http://forum.winehq.org/viewtopic.php?t=9074

A Haskell Sudoku Solver using Finite Domain Constraints

In a previous post we looked at how to write a finite domain constraint solver in Haskell. Now we're going to look at how to use this solver to solve Sudoku puzzles. First we give the module header and define a useful type:

module Sudoku (Puzzle, printSudoku, displayPuzzle, sudoku) where

import Control.Monad
import Data.List (transpose)
import FD

type Puzzle = [Int]

We represent both unsolved and solved puzzles as a list of 81 Ints. In an unsolved puzzle, we use 0 to represent a blank square. The numbers 1 to 9 represent squares with known values. Here is an example of an unsolved puzzle that I copied from the local newspaper:

test :: Puzzle
test = [
    0, 0, 0, 0, 8, 0, 0, 0, 0,
    0, 0, 0, 1, 0, 6, 5, 0, 7,
    4, 0, 2, 7, 0, 0, 0, 0, 0,
    0, 8, 0, 3, 0, 0, 1, 0, 0,
    0, 0, 3, 0, 0, 0, 8, 0, 0,
    0, 0, 5, 0, 0, 9, 0, 7, 0,
    0, 5, 0, 0, 0, 8, 0, 0, 6,
    3, 0, 1, 2, 0, 4, 0, 0, 0,
    0, 0, 6, 0, 1, 0, 0, 0, 0 ]

The function displayPuzzle displays a puzzle for us in rows and columns. The function printSudoku will solve a puzzle by calling sudoku, which we will define below. It then prints each solution.

displayPuzzle :: Puzzle -> String
displayPuzzle = unlines . map show . chunk 9

printSudoku :: Puzzle -> IO ()
printSudoku = putStr . unlines . map displayPuzzle . sudoku

chunk :: Int -> [a] -> [[a]]
chunk _ [] = []
chunk n xs = ys : chunk n zs where
    (ys, zs) = splitAt n xs

We now present the code to actually solve the puzzle:

sudoku :: Puzzle -> [Puzzle]
sudoku puzzle = runFD $ do
    vars <- newVars 81 [1..9]
    zipWithM_ (\x n -> when (n > 0) (x `hasValue` n)) vars puzzle
    mapM_ allDifferent (rows vars)
    mapM_ allDifferent (columns vars)
    mapM_ allDifferent (boxes vars)
    labelling vars

rows, columns, boxes :: [a] -> [[a]]
rows = chunk 9
columns = transpose . rows
boxes = concat . map (map concat . transpose) . chunk 3 . chunk 3 . chunk 3

We start by initialising 81 new solver variables, one for each square in the puzzle. Next, we constrain each known square in the puzzle to its given value. The next three lines create the Sudoku constraints: each number 1 to 9 may occur only once in each row, column and 3x3 box. The functions for grouping the variables into rows, columns and boxes are given below the main function. Finally, we call labelling to search for solutions.

Let's see how this performs with our test puzzle, running on a 2.4GHz Intel Core 2 Duo with 4GB RAM:

> ghc --make -O2 test
[1 of 3] Compiling FD               ( FD.hs, FD.o )
[2 of 3] Compiling Sudoku           ( Sudoku.hs, Sudoku.o )
[3 of 3] Compiling Main             ( test.hs, test.o )
Linking test ...
> time ./test
[5,6,7,4,8,3,2,9,1]
[9,3,8,1,2,6,5,4,7]
[4,1,2,7,9,5,3,6,8]
[6,8,9,3,7,2,1,5,4]
[7,4,3,6,5,1,8,2,9]
[1,2,5,8,4,9,6,7,3]
[2,5,4,9,3,8,7,1,6]
[3,7,1,2,6,4,9,8,5]
[8,9,6,5,1,7,4,3,2]


real 0m6.518s
user 0m6.480s
sys 0m0.032s

So it takes around 6.5 seconds to find all solutions to this puzzle (of which there is exactly one, as expected). Can we do any better than that? Yes we can, actually. Recall our earlier definition of the function different which constrains two variables to have different values, and is used by the allDifferent function which features prominently in our Sudoku solving code:

different :: FDVar s -> FDVar s -> FD s ()
different = addBinaryConstraint $ \x y -> do
    xv <- lookup x
    yv <- lookup y
    guard $ IntSet.size xv > 1 || IntSet.size yv > 1 || xv /= yv

Notice how this function doesn't try to constrain the domains of the variables or do any constraint propagation. That's because, in the general case, we don't have enough information to do this, we just have to store the constraint and retest it each time the domains are changed. This means that in our Sudoku solver, the labelling step will effectively try each value 1 to 9 in turn for each blank square and then test whether the allDifferent constraints still hold. This is almost a brute force algorithm.

However, we have overlooked one case where we can further constrain the variables: if the domain of one variable is a singleton set, then we can remove that value from the domain of the other variable. This should drastically reduce the number of tests we need to do during labelling. Here's the modified function:

different = addBinaryConstraint $ \x y -> do
    xv <- lookup x
    yv <- lookup y
    guard $ IntSet.size xv > 1 || IntSet.size yv > 1 || xv /= yv
    when (IntSet.size xv == 1 && xv `IntSet.isProperSubsetOf` yv) $
        update y (yv `IntSet.difference` xv)
    when (IntSet.size yv == 1 && yv `IntSet.isProperSubsetOf` xv) $
        update x (xv `IntSet.difference` yv)

Here are the times with the modified funtion:

> time ./test
[5,6,7,4,8,3,2,9,1]
[9,3,8,1,2,6,5,4,7]
[4,1,2,7,9,5,3,6,8]
[6,8,9,3,7,2,1,5,4]
[7,4,3,6,5,1,8,2,9]
[1,2,5,8,4,9,6,7,3]
[2,5,4,9,3,8,7,1,6]
[3,7,1,2,6,4,9,8,5]
[8,9,6,5,1,7,4,3,2]


real 0m0.180s
user 0m0.160s
sys 0m0.020s

That's a 36-fold improvement. Not bad for adding four lines of code!

Constraint Programming in Haskell

Having had a bit of free time in the evenings lately, I've finally got around to starting one of the things on my list of cool Haskell projects I'd like to get around to one day. Since my time working on Mercury and HAL, I've been interested in logic programming and constraint logic programming and I've been wanting to find out how close I can get to something that looks like a constraint logic programming system in Haskell.

The Haskell list monad already allows a style of programming that feels somewhat like non-deterministic logic programming, with backtracking to do a depth-first left-to-right search. I'm going to build a monad on top of the list monad to do finite domain constraint programming. I'm aiming for a nice clean interface and a simple implementation, so this is not going to be as efficient as it could be, but that's ok for a proof of concept. If I get time later, I'll go back and try to make it more efficient.

In a finite domain solver the variables represent a finite set of (usually integer) values to which the programmer can add various constraints. They are particularly useful for scheduling and timetabling problems. They are also good for solving puzzles such as Sudoku, which I will detail in a later post.

An example of the kind of constraint program we're aiming to be able to write is

runTest = runFD test

test = do
    x <- newVar [0..3]
    y <- newVar [0..3]
    (( x .<. y) `mplus` (x `same` y))
    x `hasValue` 2
    labelling [x, y]

Here we create two finite domain variables x and y, each with an initial domain of {0, 1, 2, 3}. We then add a constraint that says either x is less than y or x is the same as y. We then further constrain x to have the value 2. Finally, the call to labelling will search for all possible solutions that satisfy the given constraints. When we evaluate runTest we get the result [[2,3],[2,2]] which represents the two possible solutions {x = 2, y = 3} and {x = 2, y = 2}.

Finite domain solvers also allow constraints to contain arithmetic expressions involving constraint variables and integers. To keep things simple, we'll leave them out for now. The interface we are going to implement is shown below.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module FD (
    -- Types
    FD,           -- Monad for finite domain constraint solver
    FDVar,        -- Finite domain solver variable

    -- Functions
    runFD,        -- Run the monad and return a list of solutions.
    newVar,       -- Create a new FDVar
    newVars,      -- Create multiple FDVars
    hasValue,     -- Constrain a FDVar to a specific value
    same,         -- Constrain two FDVars to be the same
    different,    -- Constrain two FDVars to be different
    allDifferent, -- Constrain a list of FDVars to be different
    (.<.),        -- Constrain one FDVar to be less than another
    labelling     -- Backtracking search for all solutions
    ) where

Modules we need to import:

import Prelude hiding (lookup)
import Control.Monad.State.Lazy
import Control.Monad.Trans
import qualified Data.Map as Map
import Data.Map ((!), Map)
import qualified Data.IntSet as IntSet
import Data.IntSet (IntSet)

Below we define the types for the solver.

-- The FD monad
newtype FD s a = FD { unFD :: StateT (FDState s) [] a }
    deriving (Monad, MonadPlus, MonadState (FDState s))

-- FD variables
newtype FDVar s = FDVar { unFDVar :: Int } deriving (Ord, Eq)

type VarSupply s = FDVar s
data VarInfo s = VarInfo
     { delayedConstraints :: FD s (), values :: IntSet }
type VarMap s = Map (FDVar s) (VarInfo s)
data FDState s = FDState
     { varSupply :: VarSupply s, varMap :: VarMap s }

The type FD s a is our constraint solver monad. It contains a list monad to provide the search capability. This is wrapped in a StateT monad transformer which threads through the constraint store FDState s. The type variable s is a phantom type. We will see later how this can be used to prevent any of the implementation detail "leaking out" of the monad.

Our constraint store FDState s contains a supply of fresh constraint variables and also keeps track of the information we need to know about existing variables. For each existing variable we record its set of possible values (its domain) and a set of constraints on it. Whenever the domain of a variable changes, we need to execute its constraints to check that they are still satisfied. This, in turn, may further constrain the domain of other variables. This is known as constraint propagation.

-- Run the FD monad and produce a lazy list of possible solutions.
runFD :: (forall s . FD s a) -> [a]
runFD fd = evalStateT (unFD fd) initState

initState :: FDState s
initState = FDState { varSupply = FDVar 0, varMap = Map.empty }

The function runFD runs a constraint solver, starting with an initially empty constraint store, and return a list of all possible solutions. The type (forall s . FD s a) -> [a] ensures that any values of a type containing the phantom type variable s can't "escape" from the monad. This means that we can't take a constraint variable from one monad and use it inside another one, thus ensuring, through the type system, that the monad is used safely.

-- Get a new FDVar
newVar :: [Int] -> FD s (FDVar s)
newVar domain= do
    v <- nextVar
    v `isOneOf` domain
    return v
    where
        nextVar :: FD s (FDVar s)
        nextVar = do
            s <- get
            let v = varSupply s
            put $ s { varSupply = FDVar (unFDVar v + 1) }
            return v
        isOneOf :: FDVar s -> [Int] -> FD s ()
        x `isOneOf` domain=
            modify $ \s ->
                let vm = varMap s
                    vi = VarInfo {
                        delayedConstraints = return (),
                        values = IntSet.fromList domain}
                in
                s { varMap = Map.insert x vi vm }

newVars :: Int -> [Int] -> FD s [FDVar s]
newVars n domain = replicateM n (newVar domain)

The function newVar domain creates a new constraint variable constrained to values in domain. The function newVars n domain is a convenient way of creating multiple variables with the same domain.

Some helper functions which are not exported, but are used when we define the constraint functions:

-- Lookup the current domain of a variable.
lookup :: FDVar s -> FD s IntSet
lookup x = do
    s <- get
    return . values $ varMap s ! x

-- Update the domain of a variable and fire all delayed constraints
-- associated with that variable.
update :: FDVar s -> IntSet -> FD s ()
update x i = do
    s <- get
    let vm = varMap s
    let vi = vm ! x
    put $ s { varMap = Map.insert x (vi { values = i}) vm }
    delayedConstraints vi

-- Add a new constraint for a variable to the constraint store.
addConstraint :: FDVar s -> FD s () -> FD s ()
addConstraint x constraint = do
    s <- get
    let vm = varMap s
    let vi = vm ! x
    let cs = delayedConstraints vi
    put $ s { varMap =
        Map.insert x (vi { delayedConstraints = cs >> constraint }) vm }
 
-- Useful helper function for adding binary constraints between FDVars.
type BinaryConstraint s = FDVar s -> FDVar s -> FD s ()
addBinaryConstraint :: BinaryConstraint s -> BinaryConstraint s
addBinaryConstraint f x y = do
    let constraint  = f x y
    constraint
    addConstraint x constraint
    addConstraint y constraint

The function lookup returns the current domain for a variable; update updates the domain for a variable and propagates the change into all constraints on that variable; addConstraint inserts a constraint into the constraint store; addBinaryConstraint tests a constraint on two variable and then adds it to the constraint store for each variable.

Now we can define the actual constraint functions:

-- Constrain a variable to a particular value.
hasValue :: FDVar s -> Int -> FD s ()
var `hasValue` val = do
    vals <- lookup var
    guard $ val `IntSet.member` vals
    let i = IntSet.singleton val
    when (i /= vals) $ update var i

In hasValue we lookup the current domain of the variable and test that the value to be set is within the domain. If the domain has changed, we update the constraint store and propagate the change. The other constraints are defined similarly:

-- Constrain two variables to have the same value.
same :: FDVar s -> FDVar s -> FD s ()
same = addBinaryConstraint $ \x y -> do
    xv <- lookup x
    yv <- lookup y
    let i = IntSet.intersection xv yv
    guard $ not $ IntSet.null i
    when (i /= xv) $ update x i
    when (i /= yv) $ update y i

-- Constrain two variables to have different values.
different :: FDVar s -> FDVar s -> FD s ()
different = addBinaryConstraint $ \x y -> do
    xv <- lookup x
    yv <- lookup y
    guard $ IntSet.size xv > 1 || IntSet.size yv > 1 || xv /= yv

-- Constrain a list of variables to all have different values.
allDifferent :: [FDVar s] -> FD s ()
allDifferent (x:xs) = do
    mapM_ (different x) xs
    allDifferent xs
allDifferent _ = return ()

-- Constrain one variable to have a value less than the value of another
-- variable.
(.<.) :: FDVar s -> FDVar s -> FD s ()
(.<.) = addBinaryConstraint $ \x y -> do
    xv <- lookup x
    yv <- lookup y
    let xv' = IntSet.filter (< IntSet.findMax yv) xv
    let yv' = IntSet.filter (> IntSet.findMin xv) yv
    guard $ not $ IntSet.null xv'
    guard $ not $ IntSet.null yv'
    when (xv /= xv') $ update x xv'
    when (yv /= yv') $ update y yv'

Finally, in the labelling function we make use of the underlying list monad to search for all solutions for the given set of variables.

-- Label variables using a depth-first left-to-right search.
labelling :: [FDVar s] -> FD s [Int]
labelling = mapM label where
    label var = do
        vals <- lookup var
        val <- FD . lift $ IntSet.toList vals
        var `hasValue` val
        return val

In a later posts I plan to show how to use this finite domain solver monad to write a solver for Sudoku puzzles, and extend the monad to support arithmetic expressions.

Off to Kiwiland

Yes, the rumours you may have been hearing are true. Just when you thought we'd finally decided which country to live in, we've gone and (temporarily) changed our minds again. We'll be spending most of the next six months in Auckland, courtesy of Deloitte.

Moana left today (via Sydney and Christchurch, but that's another story) and I'll be following her in about a month. Of course we have to be back in Melbourne when Christine comes to visit from Wellington in July and when Peter and Lynne come over from Dunedin in October. I'll also be back a couple more times so that the people I work for don't forget that I exist. Apparently things weren't complicated enough already.

This has all happened very suddenly and I think we are both still feeling a bit shell-shocked. We were just getting used to our new house, and staying in the one place. But hey, it's a good opportunity for Moana work-wise, and NZ is a great place to take photographs, so I'm happy. Now I just have to brush up on my accent and learn a bit about rugby and under-arm bowling....