Thursday, May 07, 2009

What I've been reading

I read a bit. Typically have a book or two I'm working on scattered around my house in different places where I might end up reading for a while. From time to time I'll post on what I'm reading.

My current (or recent) selections includes:

Dreadnought by Robert K. Massie - a massive (> 1000 pages) history of England and Germany in the years leading up to the first world war. For some reason I've been reading a bit about the first world war a lot and find it very interesting and this book is no exception. The book focuses on the various personalities and especially on the people influencing the navies of the two countries. It is a bit scattershot for someone like me who doesn't know a bit more about the history of the time, bouncing from one personality to another, but is generally a good read and gives a nice overview of the people involved.

Bioinformatics by Volker Sperschneider - I do voluntary book reviews for Computing Reviews and this was a recent choice. I try to pick books on topics I'd like to know more about as well as on topics that I do know something about and this was mostly new material for me. I found it tough going most of the time and not as illuminating as I might like. For instance he starts out without really framing the problem (analysis and construction of DNA) sequences and alternates between very formal discussions and sketchy views of things. It is published by Springer and I'm finding the books published by Springer to be generally poor in quality, but with some exceptions that are excellent.

Mage Guard of Hamor - L.E. Modesitt Jr. A couple of years back I picked up six of the "Magic of Recluse" series by Modesitt and found them eminently readable. Since then as I've found new books in the series I've picked them up and read them. They often get tagged as "young adult" but are good reads for most anyone who likes fantasy. They do tend to be a bit repetive (boy discovers magic powers, boy has trouble with magic powers and the current power structure, boy rises above it all), but the magic involved makes a certain amount of sense in contest and is not unlimited - that is, there are few places where suddenly the magicians suddenly discover powers that come from nowhere. And Modesitt is a good storyteller and that makes up for a lot of the deficiencies. Even better, while the story takes place in a single world, each book is more or less self contained (with a few of the stories spanning two books) and each gives a different view of the world.

One nice thing is that the stories jump back and forth in history, so you get another view of what happens. In the first few books the heros tend to focus on "black magicians" and the "white magicians" are portrayed as being more or less evil, but as the series progresses we also get views of white magicians that manage to portray them as being good as well. I've not started any of his other fantasy novels, but if more get published in this series I'll probably read them as well.



Wednesday, May 06, 2009

Kenken Comments

My (previously posted) simple kenken solver solved every kenken puzzle I tried it on but two (where I think I transcribed the problem wrong). For the most part it seemed fast enough - taking about a half a second per puzzle. Profiling shows that most of the work goes into checking the various constraints, so they might benefit from tuning.

I thought it might help to sort the cells before solving the puzzle to see if there was a benefit to (for instance) doing the cells in division and subtraction constraints first. It turns out that that doesn't help much. Worse yet, if the cells are sorted so that addition and multiplication are first the run time goes from less than a second to hours. I had expected the run time to increase, but the size of the increase was startling. After a bit of consideration though, the reason became apparent.

Currently the cells are processed along the top row, then the second row and so on, which means that once the top left cell has been assigned a tentative value, the cells in the first row (and first column) are already constrained by the row/column constraints as well as by the (local) constraints imposed by the blocks. Thus fewer possibilities need to be considered. If we have a puzzle in which there are two division constraints at two diagonally opposite corners, and these are considered first, then the row and column constraints will have little (or no) effect and the solver will be forced to consider many more possible values for the cells.

Thus, solving a row at a time from left to right is probably about as good an ordering as you can get for this (not very smart) solver.

Tuesday, May 05, 2009

Whole Kenken program

Here is the complete program including all the bits previously posted as well as some helper functions and the main driver. It is set up in such a way that you can load it into ghci and then run "doPuzzle filename" to run a puzzle.


import System
import Char
import Maybe
import Control.Monad.State

-- a puzzle has a size (so we know the limit of values to use)
-- its original input as a list of strings (just in case we want to print it)
-- a list of constraints
-- and a list of cells with position/label
-- the cells could be a list of lists, but doing the lookup in a data set
-- this size isn't likely to be the limiting factor and we'll abstract
-- over getting a cell by x,y coordinates anyway

data Puzzle = Puzzle {
psize :: Int,
origInput :: [String],
constraints :: [Constraint],
pcells :: [Cell]
}

-- constraints have labels (from the input description)
-- operations (the arithmetic operators as strings)
-- target values
-- and a list of the cells that make up the constraint
data Constraint = Constraint
{ conlabel :: String,
conop :: String,
contarget :: Int,
concells :: [Cell]
}
deriving Show

-- each cell in the puzzle has a position (cx, cy) and a label
-- corresponding to the constraint it is in
data Cell = Cell {
clabel :: String,
cx :: Int,
cy :: Int
}
deriving (Eq, Show)

-- an assignment is, well, an assignment of a value to a cell

data Assignment = Assignment { acell :: Cell, avalue :: Int }
deriving (Show, Eq)

-- a possibility represents a "possible" solution to the puzzle

type Possibility = [ Assignment ]

-- The PuzzleM type contains the base puzzle

type PuzzleM = StateT Puzzle IO

getPuzzle :: PuzzleM Puzzle
getPuzzle = get

getConstraints = do
p <- getPuzzle
return $ constraints p

-- not a fancy show, but shows the pieces - quick and easy
instance Show Puzzle where
show (Puzzle{psize=s, origInput=inp,constraints=cos,pcells=ces}) =
unlines $ ["Puzzle::", "size="++(show s)]
++ inp
++ (map show cos)
++ (map show ces)


strip l = sl
where
sl = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace l

parse :: String -> Puzzle
parse s = Puzzle {psize=size, origInput=plines, constraints=constraintList, pcells=cellList}
where
plines = map strip $ lines s
(cellLines, constraintLines) = break ([]==) plines
size = length cellLines
cellList = doCellLines 0 cellLines
constraintList = parseConstraintLines cellList $ tail constraintLines

doCellLines :: Int -> [String] -> [Cell]
doCellLines i [] = []
doCellLines i (l:ls) = let l1 = zip [0..] l
mkcell (xpos, y) = Cell { clabel=[y], cx=xpos, cy=i}
l2 = map mkcell l1
in l2 ++ (doCellLines (i+1) ls)

parseConstraintLines cells lines = map (parseConstraint cells) (filter ("" /=) lines)

parseConstraint cells l = Constraint {conlabel= label,
conop = op,
contarget = target,
concells = clist }
where
(label,rest) = break ('='==) l
(starget, op) = break (not.isDigit) $ tail rest
target = read starget
clist = filter (\c -> clabel c == label) cells

showPuzzle = do
p <- getPuzzle
liftIO $ putStrLn $ show p

solve :: [Cell] -> Possibility -> PuzzleM Possibility
solve [] assList = return assList
solve cl@(c:cs) assList = do
s <- psize `liftM` getPuzzle
let pass = map (\v -> Assignment{ acell=c, avalue=v}) [1..s]
passes = map (:assList) pass
solve1 cs passes

solve1 cells [] = return []
solve1 cells pl@(p:ps) = do
good <- okSoFar p
if good
then do solved <- solve cells p
if solved /= []
then return solved
else solve1 cells ps
else solve1 cells ps

allRowsOK p = do
s <- psize `liftM` getPuzzle
return $ and $ map (rowOK s p) [0..s-1]

allColsOK p = do
s <- psize `liftM` getPuzzle
return $ and $ map (colOK s p) [0..s-1]

rowOK s plist row = allDifferent (map avalue inrow)
where
inrow = filter (\x -> (row == (cy $ acell x))) plist

colOK s plist col = allDifferent (map avalue incol)
where
incol = filter (\x -> (col == (cx $ acell x))) plist

allDifferent [] = True
allDifferent (x:xs) = (not $ elem x xs) && allDifferent xs

allConsOK p = do
conlist <- constraints `liftM` getPuzzle
return $ and $ map (conOK p) conlist

conOK p constraint = checkCon convals contype target cl
where
concl = concells constraint
convals = map avalue $ filter (\x -> ( acell x) `elem` concl) p
contype = conop constraint
target = contarget constraint
cl = length concl

checkCon [] _ tgt _ = True
checkCon cl "=" tgt _ = tgt == cl !! 0
checkCon cl "*" tgt l = if length cl == l
then tgt == product cl
else 0== tgt `mod` (product cl)
checkCon cl "+" tgt l = if length cl == l
then tgt == sum cl
else tgt >= sum cl
checkCon cl "-" tgt _
| length cl > 2 = False
| length cl == 2 = abs(cl !! 0 - cl !! 1) == tgt
| length cl == 1 = True

checkCon cl "/" tgt _
| length cl > 2 = False
| length cl == 1 = True
| length cl == 2 = let a = cl !! 0
b = cl !! 1
in (a `div` b) == tgt || (b `div` a) == tgt

okSoFar p = do
rowsOK <- allRowsOK p
colsOK <- allColsOK p
consOK <- allConsOK p
return $ rowsOK && colsOK && consOK

showKnownCells al s = unlines $ map getRow [0..s-1]
where
getCellByRowCol al r c = filter (\x -> (r == (cy $ acell x)) && (c == (cx $ acell x))) al
getRow r = unwords $ map doCell $ map (getCellByRowCol al r) [0..s-1]
doCell [] = " "
doCell (x:xs) = show $ avalue x


runPuzzle = do
{- showPuzzle -}
cl <- pcells `liftM` getPuzzle
solve cl []

showPossibles p = unlines $ map show p

main = do
args <- getArgs
doPuzzle (args !! 0)


doPuzzle fn = do
inp <- readFile fn
let puzzle = parse inp

putStrLn inp
putStrLn "about to evalState puzzle..."
(soln,p) <- runStateT runPuzzle puzzle
putStrLn $ showKnownCells soln 6

Monday, May 04, 2009

Kenken Solver

The solver is the remaining major piece of the kenken program. It is simple enough here - the function solve takes a list of cells that are not yet assigned values, a list of cells with values (a "Possibility") and returns a "Possibility" that should, if not null, result in a solution. To do this it takes the next unassigned cell from the list of cells, makes a list of all the possible values it might take (that is the values from 1 up to the size of the puzzle - no culling is attempted) and tries to solve the puzzle with each of those values being assigned to the cell.

This looks like :

solve :: [Cell] -> Possibility -> PuzzleM Possibility
solve [] assList = return assList
solve cl@(c:cs) assList = do
s <- psize `liftM` getPuzzle
let pass = map (\v -> Assignment{ acell=c, avalue=v}) [1..s]
passes = map (:assList) pass
solve1 cs passes

solve1 cells [] = return []
solve1 cells pl@(p:ps) = do
good <- okSoFar p
if good
then do solved <- solve cells p
if solved /= []
then return solved
else solve1 cells ps
else solve1 cells ps


I think that if I used List as the base monad in the stack (instead of IO) I could have used the nondeterminism aspect to simplify this, but I did not, so here's what I have.