Tuesday, January 22, 2008

Unmonad Tutorial: IO in Haskell without understanding monads

Forget monads!

These days, I hear a lot of "what kind of language makes you learn category theory to do IO" and "monads are a kludge to allow IO in a pure language."

Both of these ideas are rubbish. You can do IO without understanding monads, and monads aren't a way of doing IO. The usual way to demonstrate this is to write yet another monad tutorial. But I'm bored of monad tutorials: half of them don't make sense, and anyway, I just want to do some frickin' IO.

It's pretty simple. Haskell introduces a datatype for IO actions, and a DSL for creating them. The fact that IO is an instance of the Monad typeclass is irrelevant for our purposes. I just want to do some frickin' IO.

The DSL is simple: do introduces an IO action. IO actions are formatted either as brace-enclosed, semicolon-delimited (like C) or indented, newline-delimited statements (like Python). Each statement is one of the following:

  • let n = v binds n to the value v.

  • n <- a executes the action a and binds the name n to the result.

  • a, on its own, executes the action a.

This is all rather similar to an imperative language, except that two types of assignment are distinguished.

The result of running your newly constructed action is the result of the last action in your do block. Which leaves just one more thing you'll need return. This is not like the return of other languages: it's not a flow control statement. return x is an IO action that does nothing but yield x when executed.

Notice that the let n = v form is actually unneeded: it is equivalent to n <- return v. So there's really only one type of assignment, if you prefer to look at it that way.

You may be wondering how you pass arguments to an IO action. You don't. You make a function which takes arguments and returns an IO action.

As a short example, I'll write a program that reads in some integers, and outputs a running total.

totalLoop takes the old total, and produces an IO action which reads a line from standard input, converts it to an integer, prints the total, and then runs itself with the new total. It loops forever, so we give it the return type (), the empty tuple, which is used like void in Haskell.

> totalLoop :: Integer -> IO ()
> totalLoop oldTotal =
> do
> input <- getLine -- getLine :: IO String
> let number = read input -- read :: String -> Integer
> let newTotal = oldTotal + number
> print newTotal -- print :: Integer -> IO ()
> totalLoop newTotal

main simply runs totalLoop with a zero total.

> main :: IO ()
> main =
> do
> totalLoop 0

And there you have it: an IO-performing (if uninteresting) Haskell program, without any understanding of what monads are.

Friday, January 18, 2008

First player wins Superghost

Inspired by the XKCD's blag post on the solution to Ghost, I first verified his results, and then moved onto the somewhat harder task of solving Ghost's wicked step-sister, Superghost.

Briefly, the rules of Superghost: the first player names a letter; then, each player in turn either adds a letter to the beginning ("conses" a letter) or to the end ("snocs" a letter; the words "cons" and "snoc" are not game terminology, but functional-programming jargon). The first player to create a string of letters which is not part of a real word, or completes a real word, loses. I consider only the two-player version.

The solver is written in Haskell, and uses the Ubuntu British English word list. Only words with four or more letters are considered. Words containing capital or accented letters are ignored.

The program took about 22.5 seconds to find the solution: The first player wins, by playing a, i, o, s, or v.

The winning responses for the second player:

('b',[Snoc 'w'])
('c',[Cons 'g',Cons 'w',Snoc 'd',Snoc 'q'])
('d',[Cons 'c',Cons 'f',Cons 'g',Snoc 'w'])
('e',[Snoc 'r'])
('f',[Cons 'f',Cons 'h',Cons 'l',Cons 'x',Snoc 'd',Snoc 'f',Snoc 'g',Snoc 'n',Snoc 'p',Snoc 'w'])
('g',[Cons 'f',Cons 'h',Cons 'l',Cons 'x',Snoc 'c',Snoc 'd',Snoc 'j',Snoc 'm',Snoc 'w',Snoc 'z'])
('h',[Cons 'm',Cons 'n',Cons 'x',Snoc 'f',Snoc 'g',Snoc 'k',Snoc 'q'])
('j',[Cons 'g',Cons 'k',Cons 'p',Cons 'r',Cons 'u'])
('k',[Cons 'h',Cons 'k',Cons 't',Cons 'w',Cons 'y',Snoc 'j',Snoc 'k'])
('l',[Cons 'w',Cons 'x',Snoc 'f',Snoc 'g'])
('m',[Cons 'g',Snoc 'h'])
('n',[Cons 'f',Cons 'x',Snoc 'h',Snoc 'w',Snoc 'x'])
('p',[Cons 'f',Snoc 'j'])
('q',[Cons 'c',Cons 'h',Cons 'x'])
('r',[Cons 'e',Cons 'r',Snoc 'j',Snoc 'r'])
('t',[Snoc 'k'])
('u',[Snoc 'j'])
('w',[Cons 'b',Cons 'd',Cons 'f',Cons 'g',Cons 'n',Cons 'w',Snoc 'c',Snoc 'k',Snoc 'l',Snoc 'w',Snoc 'y'])
('x',[Cons 'n',Snoc 'f',Snoc 'g',Snoc 'h',Snoc 'l',Snoc 'n',Snoc 'q'])
('y',[Cons 'w',Snoc 'k'])
('z',[Cons 'g'])

Byorgey wanted code... he gets code. Sorry about the lack of comments, but this is a for-fun hack.

module Main where

import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.List as L
import Data.Maybe (fromMaybe)
import Control.Applicative

type SuperghostDict = M.Map String (S.Set String)

data Play = Cons Char | Snoc Char deriving (Show, Eq, Ord)

getWords :: IO [String]
getWords = filter (all (`elem` ['a'..'z'])) <$>
lines <$>
readFile "/usr/share/dict/words"

makeDict :: [String] -> SuperghostDict
makeDict words = M.unionWith S.union
(M.fromListWith S.union $
concatMap (\word -> let tails = L.tails word in
zip (tail tails) $ map S.singleton tails)
(M.fromAscList $ map (\x -> (x, S.empty)) $ words)

wordsEnding :: String -> SuperghostDict -> S.Set String
wordsEnding word dict = (fromMaybe S.empty $ M.lookup word dict)

wordsStarting :: String -> SuperghostDict -> S.Set String
wordsStarting word dict = S.fromAscList $
(takeWhile (word `L.isPrefixOf`) $ map fst $
M.toAscList $ snd $ M.split word dict)

wordsMiddling :: String -> SuperghostDict -> S.Set String
wordsMiddling word dict = (foldr S.union S.empty
(map snd $ takeWhile ((word `L.isPrefixOf`) . fst) $
M.toAscList $ snd $ M.split word dict))

wordsWith :: String -> SuperghostDict -> S.Set String
wordsWith word dict = (wordsEnding word dict) `S.union`
(wordsStarting word dict) `S.union`
(wordsMiddling word dict)

plays :: String -> SuperghostDict -> S.Set Play
plays word dict = (S.map (\ w -> (Snoc $ w !! (length word))) $
wordsStarting word dict)
`S.union` (S.map (\ w -> Cons $ head w)
$ wordsEnding word dict)
`S.union` (S.map (\ w -> Cons $ head w)
$ wordsMiddling word dict)

apply :: String -> Play -> String
apply word (Snoc c) = word ++ [c]
apply word (Cons c) = c:word

winnable :: SuperghostDict -> String -> Bool
winnable dict word = let moves = S.toList $ plays word dict in
if null moves then
any (not . (winnable dict) . (apply word)) moves

winningPlays :: SuperghostDict -> String -> [Play]
winningPlays dict word = let moves = S.toList $ plays word dict in
filter (not . (winnable dict) . (apply word)) moves

forever :: (Monad m) => m a -> m ()
forever x = x >> forever x

main = do
dict <- makeDict <$> filter ((> 3) . length) <$> getWords
print $ winningPlays dict ""