Craft3e 0.2.0.4 → 0.2.0.5

raw patch · 31 files changed

+3721/−1417 lines, 31 filesdep +randomPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: random

API changes (from Hackage documentation)

Files

• Chapter18.hs +16/−218
• Chapter19.hs +303/−0
• Chapter19/ParseLib.hs +0/−143
• Chapter19/Pic.hs +0/−63
• Chapter19/Pictures.hs +0/−256
• Chapter19/QC.hs +0/−133
• Chapter19/QCfuns.hs +0/−37
• Chapter19/RegExp.hs +0/−133
• Chapter20/Chapter20.hs +0/−237
• Chapter20/PerformanceI.hs +0/−37
• Chapter20/PerformanceIA.hs +0/−37
• Chapter20/PerformanceIS.hs +0/−37
• Chapter20/Pic.hs +63/−0
• Chapter20/Pictures.hs +256/−0
• Chapter20/QC.hs +133/−0
• Chapter20/QCfuns.hs +37/−0
• Chapter20/RegExp.hs +133/−0
• Chapter21/Chapter21.hs +237/−0
• Chapter21/PerformanceI.hs +37/−0
• Chapter21/PerformanceIA.hs +37/−0
• Chapter21/PerformanceIS.hs +37/−0
• Craft3e.cabal +19/−7
• Minesweeper/MineRandom.hs +97/−0
• Minesweeper/Minesweeper.hs +250/−0
• Minesweeper/Minesweeper2.hs +407/−0
• Minesweeper/Minesweeper3.hs +498/−0
• Minesweeper/Minesweeper4.hs +542/−0
• Minesweeper/Minesweeper5.hs +563/−0
• Palindromes/Palin.hs +55/−0
• Test.hs +0/−78
• svgOut.xml +1/−1

@@ -12,16 +12,14 @@ module Chapter18 where  import Prelude hiding (lookup)-import System.IO -import Control.Monad (liftM, ap)-import Control.Monad.Identity+import System.IO import Chapter8 (getInt) import Data.Time import System.Locale hiding (defaultTimeLocale) import System.IO.Unsafe (unsafePerformIO) --- Programming with monads--- ^^^^^^^^^^^^^^^^^^^^^^^+-- I/O programming+-- ^^^^^^^^^^^^^^^   -- The basics of input/output@@ -32,8 +30,8 @@ --  getLine :: IO String --  getChar :: IO Char --- Text strings are written using ---  +-- Text strings are written using+-- --  putStr :: String -> IO () --  putStrLn :: String -> IO () @@ -65,7 +63,7 @@  sumInts s   = do n <- getInt-       if n==0 +       if n==0           then return s           else sumInts (s+n) @@ -74,7 +72,7 @@ sumAcc :: Integer -> [Integer] -> Integer  sumAcc s [] = s-sumAcc s (n:ns) +sumAcc s (n:ns)   = if n==0        then s        else sumAcc (s+n) ns@@ -98,7 +96,7 @@  copyInteract :: IO () -copyInteract = +copyInteract =     do       hSetBuffering stdin LineBuffering       copyEOF@@ -106,12 +104,12 @@  copyEOF :: IO () -copyEOF = -    do +copyEOF =+    do       eof <- isEOF-      if eof  -        then return () -        else do line <- getLine +      if eof+        then return ()+        else do line <- getLine                 putStrLn line                 copyEOF @@ -127,216 +125,16 @@ -- Generating random numbers  randomInt :: Integer -> IO Integer-randomInt n = +randomInt n =     do       time <- getCurrentTime       return ( (`rem` n) $ read $ take 6 $ formatTime defaultTimeLocale "%q" time)-      + randInt :: Integer -> Integer-randInt = unsafePerformIO . randomInt -      +randInt = unsafePerformIO . randomInt   -- The calculator -- ^^^^^^^^^^^^^^  -- This is available separately in the Calculator directory.----- The do notation revisited--- ^^^^^^^^^^^^^^^^^^^^^^^^^--addOneInt :: IO ()--addOneInt -  = do line <- getLine-       putStrLn (show (1 + read line :: Int))       --addOneInt' -  = getLine >>= \line ->-    putStrLn (show (1 + read line :: Int))     ---- Monads for Functional Programming--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^---- The definition of the Monad class---  class Monad m where---    (>>=)  :: m a -> (a -> m b) -> m b---    return :: a -> m a---    fail   :: String -> m a---- Kelisli composition for monadic functions.---- (>@>) :: Monad m => (a -> m b) ->---                     (b -> m c) ->---                     (a -> m c)---- f >@> g = \ x -> (f x) >>= g----- Some examples of monads--- ^^^^^^^^^^^^^^^^^^^^^^^---- Some examples from the standard prelude.---- The list monad----  instance Monad [] where---    xs >>= f  = concat (map f xs)---    return x  = [x]---    zero      = []---- The Maybe monad----  instance Monad Maybe where---    (Just x) >>= k  =  k x---    Nothing  >>= k  =  Nothing---    return          =  Just----- The parsing monad----  data SParse a b = SParse (Parse a b)----  instance Monad (SParse a) where---    return x = SParse (succeed x)---    zero     = SParse fail---    (SParse pr) >>= f ---      = SParse (\s -> concat [ sparse (f x) rest | (x,rest) <- pr st ])----  sparse :: SParse a b -> Parse a b---  sparse (SParse pr) = pr---- A state monad (the state need not be a table; this example is designed--- to support the example discussed below.)--type Table a = [a]--data State a b = State (Table a -> (Table a , b))--instance Monad (State a) where--  return x = State (\tab -> (tab,x))--  (State st) >>= f -    = State (\tab -> let -                     (newTab,y)    = st tab-                     (State trans) = f y -                     in-                     trans newTab)--instance Applicative (State a) where-  pure = return-  (<*>) = ap--instance Functor (State a) where-  fmap = liftM----- Example: Monadic computation over trees--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^---- A type of binary trees.--data Tree a = Nil | Node a (Tree a) (Tree a)-              deriving (Eq,Ord,Show)---- Summing a tree of integers---- A direct solution:--sTree :: Tree Integer -> Integer--sTree Nil            = 0-sTree (Node n t1 t2) = n + sTree t1 + sTree t2---- A monadic solution: first giving a value of type Identity Int ...--sumTree :: Tree Integer -> Identity Integer--sumTree Nil = return 0--sumTree (Node n t1 t2)-  = do num <- return n-       s1  <- sumTree t1-       s2  <- sumTree t2-       return (num + s1 + s2)---- ... then adapted to give an Int solution--sTree' :: Tree Integer -> Integer--sTree' = identity . sumTree--identity :: Identity a -> a--identity (Identity x) = x---- Using a state monad in a tree calculation--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^---- The top level function ...--numTree :: Eq a => Tree a -> Tree Integer---- ... and the function which does all the work:--numberTree :: Eq a => Tree a -> State a (Tree Integer)---- Its structure mirrors exactly the structure of the earlier program to--- sum the tree.--numberTree Nil = return Nil--numberTree (Node x t1 t2)-  = do num <- numberNode x-       nt1 <- numberTree t1-       nt2 <- numberTree t2-       return (Node num nt1 nt2)---- The work of the algorithm is done node by node, hence the function--numberNode :: Eq a => a -> State a Integer--numberNode x = State (nNode x)----  --- Looking up a value in the table; will side-effect the table if the value--- is not present.--nNode :: Eq a => a -> (Table a -> (Table a , Integer))-nNode x table-  | elem x table        = (table      , lookup x table)-  | otherwise           = (table++[x] , integerLength table)-    where-      integerLength = toInteger.length-  --- Looking up a value in the table when known to be present--lookup :: Eq a => a -> Table a -> Integer--lookup x tab = -    locate 0 tab-           where-             locate n (y:ys) = -                 if x==y then n else locate (n+1) ys---- Extracting a value froma state monad.--runST :: State a b -> b-runST (State st) = snd (st [])---- The top-level function defined eventually.--numTree = runST . numberTree---- Example tree--egTree :: Tree String- -egTree = Node "Moon"-               (Node "Ahmet" Nil Nil)-               (Node "Dweezil"  -                        (Node "Ahmet" Nil Nil) -                        (Node "Moon" Nil Nil))-

@@ -0,0 +1,303 @@+-----------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+--+--  Chapter 19+--+-----------------------------------------------------------------------+++module Chapter19 where++import Prelude hiding (lookup)+import Control.Monad (liftM, ap)+import Control.Monad.Identity++-- Abstraction: functors, monads and folding+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+++-- Abstraction+-- ^^^^^^^^^^^++-- Spotting the pattern of mapping along a list ...++--  map :: (a -> b) -> [a] -> [b]++-- ... and the pattern of folding along a list.++--  foldr :: (a -> b -> b) -> b -> [a] -> b+--+--  foldr g s []     = s+--  foldr g s (x:xs) = g x (foldr g s xs)+++-- The Functor class+-- ^^^^^^^^^^^^^^^^^++--  class Functor g where+--    fmap :: (a -> b) -> g a -> g b++-- A first example, the Maybe type; Functor Maybe is already an instance+-- in the standard libraries, so this is given as a comment.++--  instance Functor Maybe where+--    fmap f Nothing  = Nothing+--    fmap f (Just x) = Just (f x)++-- The list instance is standard too.++--  instance Functor [] where+--    fmap f []     = []+--    fmap f (x:xs) = f x : fmap f xs++-- Instances for the tree type used later in this chapter (Section+-- 19.5, "Example: monadic computation over trees") are given as real+-- code once that type has been declared, below.+++-- The Applicative class+-- ^^^^^^^^^^^^^^^^^^^^^++--  class Functor g => Applicative g where+--    pure   :: a -> g a+--    (<*>)  :: g (a -> b) -> g a -> g b+--    liftA2 :: (a -> b -> c) -> g a -> g b -> g c++-- Applicative Maybe is already an instance in the standard libraries,+-- so both of the styles of definition discussed in the book -- via+-- liftA2, and via <*> -- are given here as comments.++--  instance Applicative Maybe where+--    pure x = Just x+--+--    liftA2 f (Just x) (Just y) = Just (f x y)+--    liftA2 _ _        _        = Nothing++--  instance Applicative Maybe where+--    ...+--    (Just f) <*> (Just x) = Just (f x)+--    _        <*> _        = Nothing++-- The Applicative instance for the tree type is given as real code+-- once that type has been declared, below.+++-- The do notation revisited+-- ^^^^^^^^^^^^^^^^^^^^^^^^^++addOneInt :: IO ()++addOneInt+  = do line <- getLine+       putStrLn (show (1 + read line :: Int))++addOneInt'+  = getLine >>= \line ->+    putStrLn (show (1 + read line :: Int))++-- Monads: languages for functional programming+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- The definition of the Monad class+--  class Monad m where+--    (>>=)  :: m a -> (a -> m b) -> m b+--    return :: a -> m a+--    fail   :: String -> m a++-- Kelisli composition for monadic functions.++-- (>@>) :: Monad m => (a -> m b) ->+--                     (b -> m c) ->+--                     (a -> m c)++-- f >@> g = \ x -> (f x) >>= g+++-- Some examples of monads+-- ^^^^^^^^^^^^^^^^^^^^^^^++-- Some examples from the standard prelude.++-- The list monad++--  instance Monad [] where+--    xs >>= f  = concat (map f xs)+--    return x  = [x]+--    zero      = []++-- The Maybe monad++--  instance Monad Maybe where+--    (Just x) >>= k  =  k x+--    Nothing  >>= k  =  Nothing+--    return          =  Just+++-- The parsing monad++--  data SParse a b = SParse (Parse a b)++--  instance Monad (SParse a) where+--    return x = SParse (succeed x)+--    zero     = SParse fail+--    (SParse pr) >>= f+--      = SParse (\s -> concat [ sparse (f x) rest | (x,rest) <- pr st ])++--  sparse :: SParse a b -> Parse a b+--  sparse (SParse pr) = pr++-- A state monad (the state need not be a table; this example is designed+-- to support the example discussed below.)++type Table a = [a]++data State a b = State (Table a -> (Table a , b))++instance Monad (State a) where++  return x = State (\tab -> (tab,x))++  (State st) >>= f+    = State (\tab -> let+                     (newTab,y)    = st tab+                     (State trans) = f y+                     in+                     trans newTab)++instance Applicative (State a) where+  pure = return+  (<*>) = ap++instance Functor (State a) where+  fmap = liftM+++-- Example: Monadic computation over trees+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- A type of binary trees.++data Tree a = Nil | Node a (Tree a) (Tree a)+              deriving (Eq,Ord,Show)++-- Tree as an instance of Functor: mapping f over every value stored+-- at a node.++instance Functor Tree where+  fmap f Nil            = Nil+  fmap f (Node x t1 t2) = Node (f x) (fmap f t1) (fmap f t2)++-- Tree as an instance of Applicative, following the same pattern as+-- the liftA2 definition for Maybe above: pure builds a single-node+-- tree, and liftA2 f applies f pointwise to two trees of the same+-- shape, returning Nil as soon as either side runs out of structure.++instance Applicative Tree where+  pure x = Node x Nil Nil++  liftA2 f Nil _ = Nil+  liftA2 f _ Nil = Nil+  liftA2 f (Node x t1 t2) (Node y s1 s2)+    = Node (f x y) (liftA2 f t1 s1) (liftA2 f t2 s2)++-- Summing a tree of integers++-- A direct solution:++sTree :: Tree Integer -> Integer++sTree Nil            = 0+sTree (Node n t1 t2) = n + sTree t1 + sTree t2++-- A monadic solution: first giving a value of type Identity Int ...++sumTree :: Tree Integer -> Identity Integer++sumTree Nil = return 0++sumTree (Node n t1 t2)+  = do num <- return n+       s1  <- sumTree t1+       s2  <- sumTree t2+       return (num + s1 + s2)++-- ... then adapted to give an Int solution++sTree' :: Tree Integer -> Integer++sTree' = identity . sumTree++identity :: Identity a -> a++identity (Identity x) = x++-- Using a state monad in a tree calculation+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- The top level function ...++numTree :: Eq a => Tree a -> Tree Integer++-- ... and the function which does all the work:++numberTree :: Eq a => Tree a -> State a (Tree Integer)++-- Its structure mirrors exactly the structure of the earlier program to+-- sum the tree.++numberTree Nil = return Nil++numberTree (Node x t1 t2)+  = do num <- numberNode x+       nt1 <- numberTree t1+       nt2 <- numberTree t2+       return (Node num nt1 nt2)++-- The work of the algorithm is done node by node, hence the function++numberNode :: Eq a => a -> State a Integer++numberNode x = State (nNode x)++--+-- Looking up a value in the table; will side-effect the table if the value+-- is not present.++nNode :: Eq a => a -> (Table a -> (Table a , Integer))+nNode x table+  | elem x table        = (table      , lookup x table)+  | otherwise           = (table++[x] , integerLength table)+    where+      integerLength = toInteger.length++-- Looking up a value in the table when known to be present++lookup :: Eq a => a -> Table a -> Integer++lookup x tab =+    locate 0 tab+           where+             locate n (y:ys) =+                 if x==y then n else locate (n+1) ys++-- Extracting a value froma state monad.++runST :: State a b -> b+runST (State st) = snd (st [])++-- The top-level function defined eventually.++numTree = runST . numberTree++-- Example tree++egTree :: Tree String++egTree = Node "Moon"+               (Node "Ahmet" Nil Nil)+               (Node "Dweezil"+                        (Node "Ahmet" Nil Nil)+                        (Node "Moon" Nil Nil))

@@ -1,143 +0,0 @@----------------------------------------------------------------------------- ---  Haskell: The Craft of Functional Programming, 3e---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.--- ---  ParseLib.hs--- ---  Library functions for parsing   ---      Note that this is not a monadic approach to parsing.    --- ----------------------------------------------------------------------------                                                                                                  --module ParseLib where--import Control.Monad (liftM, ap)-import Data.Char--infixr 5 >*>---   --- The type of parsers.                     ---  -type Parse a b = [a] -> [(b,[a])]---  --- Some basic parsers                       ---  ---  --- Fail on any input.                       ---  -none :: Parse a b-none inp = []---  --- Succeed, returning the value supplied.               ---  -succeed :: b -> Parse a b -succeed val inp = [(val,inp)]---  --- token t recognises t as the first value in the input.        ---  -token :: Eq a => a -> Parse a a-token t (x:xs) -  | t==x    = [(t,xs)]-  | otherwise   = []-token t []    = []---  --- spot whether an element with a particular property is the    --- first element of input.                      ---  -spot :: (a -> Bool) -> Parse a a-spot p (x:xs) -  | p x     = [(x,xs)]-  | otherwise   = []-spot p []    = []---  --- Examples.                            ---  -bracket = token '('-dig     =  spot isDigit---- Succeeds with value given when the input is empty.--endOfInput :: b -> Parse a b-endOfInput x [] = [(x,[])]-endOfInput x _  = []---  --- Combining parsers                        ---  ---  --- alt p1 p2 recognises anything recogniseed by p1 or by p2.    ---  -alt :: Parse a b -> Parse a b -> Parse a b-alt p1 p2 inp = p1 inp ++ p2 inp-exam1 = (bracket `alt` dig) "234" ---  --- Apply one parser then the second to the result(s) of the first.  ---  --(>*>) :: Parse a b -> Parse a c -> Parse a (b,c)---  -(>*>) p1 p2 inp -  = [((y,z),rem2) | (y,rem1) <- p1 inp , (z,rem2)  <- p2 rem1 ]---  --- Transform the results of the parses according to the function.   ---  -build :: Parse a b -> (b -> c) -> Parse a c-build p f inp = [ (f x,rem) | (x,rem) <- p inp ]---  --- Recognise a list of objects.                 ---  ---  -list :: Parse a b -> Parse a [b]-list p = (succeed []) -         `alt`-         ((p >*> list p) `build` convert)-         where-         convert = uncurry (:)---  --- Some variants...---- A non-empty list of objects.                     ---  -neList   :: Parse a b -> Parse a [b]-neList p = (p  `build` (:[]))-           `alt`-           ((p >*> list p) `build` (uncurry (:)))---- Zero or one object.--optional :: Parse a b -> Parse a [b]-optional p = (succeed []) -             `alt`  -             (p  `build` (:[]))---- A given number of objects.--nTimes :: Int -> Parse a b -> Parse a [b]-nTimes 0 p     = succeed []-nTimes n p     = (p >*> nTimes (n-1) p) `build` (uncurry (:))---  --- Monadic parsing--data SParse a b = SParse (Parse a b)--instance Monad (SParse a) where-  return x = SParse (succeed x)-  (SParse pr) >>= f-    = SParse (\st -> concat [ sparse (f a) rest | (a,rest) <- pr st ])--instance MonadFail (SParse a) where-  fail s   = SParse none--instance Applicative (SParse a) where-  pure = return-  (<*>) = ap--instance Functor (SParse a) where-  fmap = liftM--sparse :: SParse a b -> Parse a b--sparse (SParse pr) = pr--

@@ -1,63 +0,0 @@------------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.------  Pic.hs--- ---      A deep embedding of pictures-----------------------------------------------------------------------------module Pic where--import Pictures---- Data type representing pictures--data Pic = Horse |-           Above Pic Pic |-           Beside Pic Pic |-           FlipH Pic |-           FlipV Pic ---- Interpreting a Pic as a Picture--interpretPic :: Pic -> Picture--interpretPic Horse = horse-interpretPic (Above pic1 pic2)-  = above (interpretPic pic1)  (interpretPic pic2)-interpretPic (Beside pic1 pic2)-  = beside (interpretPic pic1)  (interpretPic pic2)-interpretPic (FlipH pic)-  = flipH (interpretPic pic)-interpretPic (FlipV pic)-  = flipV (interpretPic pic)---- Tidying up a picture ...---- remove pairs of flips--- push flips through placement above / beside--tidyPic :: Pic -> Pic--tidyPic (FlipV (FlipV pic)) -  = tidyPic pic-tidyPic (FlipV (FlipH pic)) -  = FlipH (tidyPic (FlipV pic)) --tidyPic (FlipV (Above pic1 pic2))-  = Above (tidyPic (FlipV pic1)) (tidyPic (FlipV pic2)) -tidyPic (FlipV (Beside pic1 pic2))-  = Beside (tidyPic (FlipV pic2)) (tidyPic (FlipV pic1)) --tidyPic (FlipH (FlipH pic)) -  = tidyPic pic-  -tidyPic (FlipH (Above pic1 pic2))-  = Above (tidyPic (FlipH pic2)) (tidyPic (FlipH pic1)) -tidyPic (FlipH (Beside pic1 pic2))-  = Beside (tidyPic (FlipH pic1)) (tidyPic (FlipH pic2)) -  

@@ -1,256 +0,0 @@---------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2010.------  Pictures.hs--- ---     An implementation of a type of rectangular pictures  ---     using lists of lists of characters. ------------------------------------------------------------------------------ The basics--- ^^^^^^^^^^--module Pictures where-import Test.QuickCheck---type Picture = [[Char]]---- The example used in Craft2e: a polygon which looks like a horse. Here--- taken to be a 16 by 12 rectangle.--horse :: Picture--horse = [".......##...",-         ".....##..#..",-         "...##.....#.",-         "..#.......#.",-         "..#...#...#.",-         "..#...###.#.",-         ".#....#..##.",-         "..#...#.....",-         "...#...#....",-         "....#..#....",-         ".....#.#....",-         "......##...."]---- Completely white and black pictures.--white :: Picture--white = ["......",-         "......",-         "......",-         "......",-         "......",-         "......"]--black = ["######",-         "######",-         "######",-         "######",-         "######",-         "######"]---- Getting a picture onto the screen.--printPicture :: Picture -> IO ()--printPicture = putStr . concat . map (++"\n")----- Transformations of pictures.--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^---- Reflection in a vertical mirror.--flipV :: Picture -> Picture--flipV = map reverse---- Reflection in a horizontal mirror.--flipH :: Picture -> Picture--flipH = reverse---- Rotation through 180 degrees, by composing vertical and horizontal--- reflection. Note that it can also be done by flipV.flipH, and that we--- can prove equality of the two functions.--rotate :: Picture -> Picture--rotate = flipH . flipV---- One picture above another. To maintain the rectangular property,--- the pictures need to have the same width.--above :: Picture -> Picture -> Picture--above = (++)---- One picture next to another. To maintain the rectangular property,--- the pictures need to have the same height.--beside :: Picture -> Picture -> Picture--beside = zipWith (++)---- Superimose one picture above another. Assume the pictures to be the same--- size. The individual characters are combined using the combine function.--superimpose :: Picture -> Picture -> Picture--superimpose = zipWith (zipWith combine)---- For the result to be '.' both components have to the '.'; otherwise--- get the '#' character.--combine :: Char -> Char -> Char--combine topCh bottomCh-  = if (topCh == '.' && bottomCh == '.') -    then '.'-    else '#'---- Inverting the colours in a picture; done pointwise by invert...--invertColour :: Picture -> Picture--invertColour = map (map invert)---- ... which works by making the result '.' unless the input is '.'.--invert :: Char -> Char--invert ch = if ch == '.' then '#' else '.'----- Property--prop_rotate, prop_flipV, prop_flipH :: Picture -> Bool--prop_rotate pic = flipV (flipH pic) == flipH (flipV pic)--prop_flipV pic = flipV (flipV pic) == pic--prop_flipH pic = flipH (flipV pic) == pic--test_rotate, test_flipV, test_flipH :: Bool- -test_rotate = flipV (flipH horse) == flipH (flipV horse)--test_flipV = flipV (flipV horse) == horse--test_flipH = flipH (flipV horse) == horse---- More properties--prop_AboveFlipV pic1 pic2 = -    flipV (pic1 `above` pic2) == (flipV pic1) `above` (flipV pic2) --prop_AboveFlipH pic1 pic2 = flipH (pic1 `above` pic2) == (flipH pic2) `above` (flipH pic1)--propAboveBeside1 nw ne sw se =-  (nw `beside` ne) `above` (sw `beside` se) -  == -  (nw `above` sw) `beside` (ne `above` se) --propAboveBeside2 n s =-  (n `beside` n) `above` (s `beside` s) == (n `above` s) `beside` (n `above` s) --propAboveBeside3 w e =-  (w `beside` e) `above` (w `beside` e) == (w `above` w) `beside` (e `above` e) --propAboveBeside3Correct w e =-  (rectangular w && rectangular e && height w == height e) -  ==>-     (w `beside` e) `above` (w `beside` e) -         == -     (w `above` w) `beside` (e `above` e) ---- auxiliary properties and functions--notEmpty pic = pic /= []--rectangular pic =-  notEmpty pic &&-  and [ length first == length l | l <-rest ]-  where-    (first:rest) = pic--height, width :: Picture -> Int--height = length-width = length . head--size :: Picture -> (Int,Int)--size pic = (width pic, height pic)--propAboveBesideFull nw ne sw se =-  (rectangular nw && rectangular ne && rectangular sw && rectangular se &&-   size nw == size ne && size ne == size se && size se == size sw) ==>-  (nw `beside` ne) `above` (sw `beside` se) == (nw `above` sw) `beside` (ne `above` se) ---- Using explicit generators ...---prop_1 = forAll (choose (1,10)) $ \x -> x/=x+(x::Int)--prop_2 = forAll (choose (1,10)) $ \x -> x/=(x::Int)---- Generators suited to Pictures---- chose either '.' or '#'--genChar :: Gen Char--genChar = oneof [return '.', return '#']---- generate a list of length n each element from generator g.--genList :: Int -> Gen a -> Gen [a]--genList n g = sequence [ g | i<-[1..n] ]---- generate a picture of given size using '.' and '#'--genSizedPicture :: Int -> Int -> Gen [String]--genSizedPicture height width =-      sequence [ genList width genChar | i<-[1::Int .. height] ]---- generate a picture of random size using '.' and '#'--genPicture :: Gen [String]--genPicture =-    do-      height <- choose (1,10)-      width  <- choose (1,10)-      genSizedPicture height width---- generate four pictures of the *same* random size using '.' and '#'--genFourPictures :: Gen ([String],[String],[String],[String])--genFourPictures =-    do-      height <- choose (1,10)-      width  <- choose (1,10)-      nw <- genSizedPicture height width-      ne <- genSizedPicture height width-      sw <- genSizedPicture height width-      se <- genSizedPicture height width-      return (nw,ne,sw,se)---- test that above and besides commute when used with four pictures--- of the same size--prop_AboveBeside =-    forAll genFourPictures $ \(nw,ne,sw,se) -> propAboveBeside1 nw ne sw se

@@ -1,133 +0,0 @@------------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.--- ---  QC.hs------      Generating values randomly.-----------------------------------------------------------------------------module QC where--import Test.QuickCheck--import Control.Monad (liftM,liftM2)-import System.IO.Unsafe (unsafePerformIO)-import Data.List (nub)-import QCfuns -- to Show functions---- Simple examples for data generation--data Card = Card Int String-            deriving (Eq,Show)--data Info = Number Int | Email String-            deriving (Eq, Show)--data List a = Empty | Cons a (List a)-            deriving (Eq, Show)--instance Arbitrary Card where-    arbitrary =-        do-          int <- arbitrary-          string <- arbitrary-          return (Card int string)--instance Arbitrary Info where-    arbitrary =-        do-          boo <- arbitrary-          if boo-            then do-              int <- arbitrary-              return (Number int) -            else do-              string <- arbitrary-              return (Email string) ---- Generating lists of samples---- instance Arbitrary a => Arbitrary (List a) where---     arbitrary =---         do---           boo <- elements [True, False]---           if boo---                   then ---                     return $ Empty ---                   else do---                     val  <- arbitrary---                     list <- arbitrary---                     return $ Cons val list --instance Arbitrary a => Arbitrary (List a) where-    arbitrary =-        do-          switch <- elements [1,2,3]-          case switch of -            1 -> return Empty -            _ -> -                do-                  val  <- arbitrary-                  list <- arbitrary-                  return (Cons val list) ---- The expr type from the calculator--data Expr = Lit Integer |-            Add Expr Expr |-            Sub Expr Expr-                deriving (Show,Eq)--instance Arbitrary Expr where-    arbitrary = sized arbExpr--arbExpr :: Int -> Gen Expr--arbExpr 0 = liftM Lit arbitrary--arbExpr n = frequency-    [(1, liftM Lit arbitrary),-     (2, liftM2 Add subExp subExp),-     (2, liftM2 Sub subExp subExp)]-        where-          subExp = arbExpr (div n 2)-{--arbExpr 0 = -    do int <- arbitrary-       return (Lit int)--arbExpr n-    | n>0 =-        do-          pick <- choose (0,2::Int)-          case pick of-            0 -> do -              int <- arbitrary-              return (Lit int)-            1 -> do -              left  <- subExp-              right <- subExp-              return (Add left right)-            2 -> do -              left  <- subExp-              right <- subExp-              return (Sub left right)-        where-          subExp = arbExpr (div n 2)--}--prettyE :: Expr -> String--prettyE (Lit n) = show n-prettyE (Add e1 e2) = "("++prettyE e1 ++"+"++prettyE e2 ++")"-prettyE (Sub e1 e2) = "("++prettyE e1 ++"-"++prettyE e2 ++")"---- Property of map--prop_map f g xs =-  map (f::Int->Int) (map (g::Int -> Int) xs) == map (g.f) xs-

@@ -1,37 +0,0 @@--------------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.------  QCfuns-------------------------------------------------------------------------------module QCfuns where--import Test.QuickCheck-import System.IO.Unsafe -- for unsafePerformIO---- Sampling and showing functions--sampleFun :: (Arbitrary a,Show a, Show b)  => (a -> b) -> IO String--sampleFun f =-    do-      inputs <- sample' arbitrary-      let list = [ (a,f a) | a <- inputs ]-      return $ showMap list--showMap :: (Show a, Show b) => [(a,b)] -> String--showMap [] = "\n"-showMap [(a,b)] = showPair (a,b) ++ "\n"-showMap (p:ps)  = showPair p ++ " ," ++ showMap ps--showPair :: (Show a, Show b) => (a,b) -> String--showPair (a,b) = "("++show a ++ "|->" ++ show b ++ ")"--instance (Arbitrary a, Show a, Show b) => Show (a -> b) where-    show = unsafePerformIO . sampleFun

@@ -1,133 +0,0 @@------------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.------      RegExp.hs--- ---  Regular Expressions-----------------------------------------------------------------------------module RegExp where--type RegExp = String -> Bool--char :: Char -> RegExp--epsilon = (=="")--char ch = (==[ch])--(|||) :: RegExp -> RegExp ->  RegExp--e1 ||| e2 = -    \x -> e1 x || e2 x--(<*>) :: RegExp -> RegExp ->  RegExp--e1 <*> e2 =-    \x -> or [ e1 y && e2 z | (y,z) <- splits x ]--(<**>) :: RegExp -> RegExp ->  RegExp--e1 <**> e2 =-    \x -> or [ e1 y && e2 z | (y,z) <- fsplits x ]--splits xs = [splitAt n xs | n<-[0..len]]-    where-      len = length xs--star :: RegExp -> RegExp--star p = epsilon ||| (p <**> star p)---           epsilon ||| (p <*> star p)--- is OK as long as p can't have epsilon match--fsplits xs = tail (splits xs)---- a = char 'a'---- b = char 'b'--infixr 7 :*:-infixr 5 :|:--data RE = Eps |-          Ch Char |-          RE :|: RE |-          RE :*: RE |-          St RE |-          Plus RE-          deriving(Eq,Show)--evens = St two-two = (a :|: b) :*: (a :|: b)-          -a = Ch 'a'-b = Ch 'b'---- interp: RE -> RegExp: exercise.---- Value recursion---  Eunmerating strings matching a regexp--enumerate :: RE -> [String]--enumerate Eps = [""]-enumerate (Ch ch) = [[ch]]-enumerate (re1 :|: re2)-    = enumerate re1 `interleave` enumerate re2-enumerate  (re1 :*: re2)-    = enumerate re1 `cartesian` enumerate re2-enumerate (St re)-    = result -      where-        result =-            [""] ++ (enumerate re `cartesian` result)---- Auxiliary functions--- interleave and product for potentially infinite lists--interleave :: [a] -> [a] -> [a]--interleave [] ys = ys-interleave (x:xs) ys = x : interleave ys xs-        -cartesian :: [[a]] -> [[a]] -> [[a]]--cartesian [] ys = []-cartesian (x:xs) ys -    = [ x++y | y<-ys ] `interleave` cartesian xs ys-    --- Recursive regular expressions--anbn :: RE--anbn = Eps :|: (a :*: (anbn :*: b))---- Extending the implementation--plus :: RE -> RE-plus re = re :*: St re---- Simplification--simplify :: RE -> RE--simplify (St (St re)) = simplify (St re)-simplify (Plus (St re)) = simplify (St re)-simplify (St (Plus re)) = simplify (St re)-simplify (re1 :|: re2) =-    if sre1==sre2 then sre1 else sre1 :|: sre2 -          where-            sre1 = simplify re1; sre2 = simplify re2-simplify re = re---- smart constructors--starC :: RE -> RE-starC (St re) = re-starC (Plus re) = re-starC re = St re

@@ -1,237 +0,0 @@----  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2010.----  Chapter 20---- Time and space behaviour--- ^^^^^^^^^^^^^^^^^^^^^^^^--module Chapter20 where--import Prelude hiding (map)---- Various functions whose complexity is discussed.--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^---- Naive Fibonacci function--fib :: Integer -> Integer--fib 0 = 0-fib 1 = 1-fib m = fib (m-2) + fib (m-1)---- Naive factorial function--fac :: Integer -> Integer-fac 0 = 1-fac n = n * fac (n-1)---- Insertion sort--iSort :: Ord a => [a] -> [a]--iSort []     = []-iSort (x:xs) = ins x (iSort xs)--ins :: Ord a => a -> [a] -> [a]--ins x [] = [x]-ins x (y:ys) -  | (x<=y)      = x:y:ys-  | otherwise   = y:ins x ys---- Quicksort--qSort :: Ord a => [a] -> [a]--qSort []     = []-qSort (x:xs) = qSort [z|z<-xs,z<=x] ++ [x] ++ qSort [z|z<-xs,z>x]---- Two reverse functions--rev1 []     = []-rev1 (x:xs) = rev1 xs ++ [x]--rev2            = shunt []-shunt xs []     = xs-shunt xs (y:ys) = shunt (y:xs) ys---- Two multiplication functions--mult n 0 = 0-mult n m = mult n (m-1) + n--russ n 0 = 0-russ n m -  | (m `mod` 2 == 0)    = russ (n+n) (m `div` 2)-  | otherwise           = russ (n+n) (m `div` 2) + n---- The merge sort function --mSort :: Ord a => [a] -> [a]--mSort xs -  | (len < 2)   = xs-  | otherwise   = mer (mSort (take m xs)) (mSort (drop m xs))-    where-    len = length xs-    m   = len `div` 2--mer :: Ord a => [a] -> [a]  -> [a]--mer (x:xs) (y:ys) -  | (x<=y)      = x : mer xs (y:ys)-  | otherwise   = y : mer (x:xs) ys-mer (x:xs) []   = (x:xs)-mer []     ys   = ys---- Implementations of sets--- ^^^^^^^^^^^^^^^^^^^^^^^---- Sets implemented as _unordered_ lists.---- type Set a = [a]---- empty        = []--- memSet       = member--- inter xs ys  = filter (member xs) ys--- union        = (++)--- subSet xs ys = and (map (member ys) xs)--- eqSet xs ys  = subSet xs ys && subSet ys xs--- makeSet      = id--- mapSet       = map---  ----- Space behaviour--- ^^^^^^^^^^^^^^^---- Lazy evaluation--- ^^^^^^^^^^^^^^^---- List examples--exam1 n = [1 .. n] ++ [1 .. n]--exam2 n = list ++ list -          where -          list=[1 .. n]--exam3 n = [1 .. n] ++ [last [1 .. n]]--exam4 n = list ++ [last list]-          where-          list=[1 .. n]----- Saving space?--- ^^^^^^^^^^^^^---- A new version of factorial--newFac :: Integer -> Integer-newFac n = aFac n 1--aFac :: Integer -> Integer -> Integer-aFac 0 p = p-aFac n p = aFac (n-1) (p*n)---- This can be modified thus:---  aFac n p---    | p==p        = aFac (n-1) (p*n)---- Miscellaneous functions--sumSquares :: Integer -> Integer-sumSquares n = sumList (map sq [1 .. n])--sumList = foldr (+) 0-sq n    = n*n------ Folding revisited--- ^^^^^^^^^^^^^^^^^---- Map defined using foldr--map f = foldr ((:).f) []---- Factorial using foldr--facFold n = foldr (*) 1 [1 .. n]---- Examples--foldEx1 n = foldr (&&) True (map (==2) [2 .. n])------ Avoiding re-computation: memoization--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^---- The Fibonacci numbers---- A naive algorithm is given earlier in this script.---- An algorithm which returns a pair of consecutive Fibonacci numbers.--fibP :: Integer -> (Integer,Integer)--fibP 0 = (0,1)-fibP n = (y,x+y)-         where-         (x,y) = fibP (n-1)---- The list of Fibonacci values, defined directly.--fibs ::[Integer]--fibs = 0 : 1 : zipWith (+) fibs (tail fibs)----- Dynamic programming: maximal common subsequence--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^---- The naive algorithm ...--mLen :: Eq a => [a] -> [a] -> Integer--mLen xs []        = 0-mLen [] ys        = 0-mLen (x:xs) (y:ys) -  | x==y        = 1 + mLen xs ys-  | otherwise   = max (mLen xs (y:ys)) (mLen (x:xs) ys)---- ... translated to talk about sub-components of lists, described by their--- endpoints ...--maxLen :: Eq a => [a] -> [a] -> Int -> Int -> Int--maxLen xs ys 0 j = 0 -maxLen xs ys i 0 = 0-maxLen xs ys i j-  | xs!!(i-1) == ys!!(j-1)  = (maxLen xs ys (i-1) (j-1)) + 1-  | otherwise               = max (maxLen xs ys i (j-1))-                                  (maxLen xs ys (i-1) j)---- ... and then transliterated into a memoised version.--maxTab ::  Eq a => [a] -> [a] -> [[Int]]--maxTab xs ys-  = result-    where -    result = [0,0 .. ] : zipWith f [0 .. ] result-    f i prev  -        = ans-          where-          ans   = 0 : zipWith g [0 .. ] ans-          g j v -            | xs!!i == ys!!j      = prev!!j + 1-            | otherwise           = max v (prev!!(j+1))--

@@ -1,37 +0,0 @@------------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.------  PerformanceI.hs-----------------------------------------------------------------------------module Main where--main = putStrLn (show (sumI 1 1000000))--- main = putStrLn (show (sumIA 1 1000000))--- main = putStrLn (show (sumIS 1 1000000))--sumI :: Integer -> Integer -> Integer--sumI n m- | n>m       = 0- | otherwise = n + sumI (n+1) m--sumIA :: Integer -> Integer -> Integer--sumIA n m = accIA n m 0--accIA n m s- | n>m       = s- | otherwise = accIA (n+1) m (n+s)--sumIS :: Integer -> Integer -> Integer--sumIS n m = accIS n m 0--accIS n m s- | n>m       = s- | otherwise = accIS (n+1) m $! (n+s)

@@ -1,37 +0,0 @@------------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.------  PerformanceIA.hs-----------------------------------------------------------------------------module Main where---- main = putStrLn (show (sumI 1 1000000))-main = putStrLn (show (sumIA 1 1000000))---- main = putStrLn (show (sumIS 1 1000000))--sumI :: Integer -> Integer -> Integer--sumI n m- | n>m       = 0- | otherwise = n + sumI (n+1) m--sumIA :: Integer -> Integer -> Integer--sumIA n m = accIA n m 0--accIA n m s- | n>m       = s- | otherwise = accIA (n+1) m (n+s)--sumIS :: Integer -> Integer -> Integer--sumIS n m = accIS n m 0--accIS n m s- | n>m       = s- | otherwise = accIS (n+1) m $! (n+s)

@@ -1,37 +0,0 @@------------------------------------------------------------------------------  Haskell: The Craft of Functional Programming---  Simon Thompson---  (c) Addison-Wesley, 1996-2011.------  PerformanceIS.hs-----------------------------------------------------------------------------module Main where---- main = putStrLn (show (sumI 1 1000000))--- main = putStrLn (show (sumIA 1 1000000))-main = putStrLn (show (sumIS 1 1000000))--sumI :: Integer -> Integer -> Integer--sumI n m- | n>m       = 0- | otherwise = n + sumI (n+1) m--sumIA :: Integer -> Integer -> Integer--sumIA n m = accIA n m 0--accIA n m s- | n>m       = s- | otherwise = accIA (n+1) m (n+s)--sumIS :: Integer -> Integer -> Integer--sumIS n m = accIS n m 0--accIS n m s- | n>m       = s- | otherwise = accIS (n+1) m $! (n+s)

@@ -0,0 +1,63 @@+-----------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+--+--  Pic.hs+-- +--      A deep embedding of pictures+--+-----------------------------------------------------------------------++module Pic where++import Pictures++-- Data type representing pictures++data Pic = Horse |+           Above Pic Pic |+           Beside Pic Pic |+           FlipH Pic |+           FlipV Pic ++-- Interpreting a Pic as a Picture++interpretPic :: Pic -> Picture++interpretPic Horse = horse+interpretPic (Above pic1 pic2)+  = above (interpretPic pic1)  (interpretPic pic2)+interpretPic (Beside pic1 pic2)+  = beside (interpretPic pic1)  (interpretPic pic2)+interpretPic (FlipH pic)+  = flipH (interpretPic pic)+interpretPic (FlipV pic)+  = flipV (interpretPic pic)++-- Tidying up a picture ...++-- remove pairs of flips+-- push flips through placement above / beside++tidyPic :: Pic -> Pic++tidyPic (FlipV (FlipV pic)) +  = tidyPic pic+tidyPic (FlipV (FlipH pic)) +  = FlipH (tidyPic (FlipV pic)) ++tidyPic (FlipV (Above pic1 pic2))+  = Above (tidyPic (FlipV pic1)) (tidyPic (FlipV pic2)) +tidyPic (FlipV (Beside pic1 pic2))+  = Beside (tidyPic (FlipV pic2)) (tidyPic (FlipV pic1)) ++tidyPic (FlipH (FlipH pic)) +  = tidyPic pic+  +tidyPic (FlipH (Above pic1 pic2))+  = Above (tidyPic (FlipH pic2)) (tidyPic (FlipH pic1)) +tidyPic (FlipH (Beside pic1 pic2))+  = Beside (tidyPic (FlipH pic1)) (tidyPic (FlipH pic2)) +  

@@ -0,0 +1,256 @@+-----------------------------------------------------------------------+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2010.+--+--  Pictures.hs+-- +--     An implementation of a type of rectangular pictures  +--     using lists of lists of characters. +-----------------------------------------------------------------------++++-- The basics+-- ^^^^^^^^^^++module Pictures where+import Test.QuickCheck+++type Picture = [[Char]]++-- The example used in Craft2e: a polygon which looks like a horse. Here+-- taken to be a 16 by 12 rectangle.++horse :: Picture++horse = [".......##...",+         ".....##..#..",+         "...##.....#.",+         "..#.......#.",+         "..#...#...#.",+         "..#...###.#.",+         ".#....#..##.",+         "..#...#.....",+         "...#...#....",+         "....#..#....",+         ".....#.#....",+         "......##...."]++-- Completely white and black pictures.++white :: Picture++white = ["......",+         "......",+         "......",+         "......",+         "......",+         "......"]++black = ["######",+         "######",+         "######",+         "######",+         "######",+         "######"]++-- Getting a picture onto the screen.++printPicture :: Picture -> IO ()++printPicture = putStr . concat . map (++"\n")+++-- Transformations of pictures.+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- Reflection in a vertical mirror.++flipV :: Picture -> Picture++flipV = map reverse++-- Reflection in a horizontal mirror.++flipH :: Picture -> Picture++flipH = reverse++-- Rotation through 180 degrees, by composing vertical and horizontal+-- reflection. Note that it can also be done by flipV.flipH, and that we+-- can prove equality of the two functions.++rotate :: Picture -> Picture++rotate = flipH . flipV++-- One picture above another. To maintain the rectangular property,+-- the pictures need to have the same width.++above :: Picture -> Picture -> Picture++above = (++)++-- One picture next to another. To maintain the rectangular property,+-- the pictures need to have the same height.++beside :: Picture -> Picture -> Picture++beside = zipWith (++)++-- Superimose one picture above another. Assume the pictures to be the same+-- size. The individual characters are combined using the combine function.++superimpose :: Picture -> Picture -> Picture++superimpose = zipWith (zipWith combine)++-- For the result to be '.' both components have to the '.'; otherwise+-- get the '#' character.++combine :: Char -> Char -> Char++combine topCh bottomCh+  = if (topCh == '.' && bottomCh == '.') +    then '.'+    else '#'++-- Inverting the colours in a picture; done pointwise by invert...++invertColour :: Picture -> Picture++invertColour = map (map invert)++-- ... which works by making the result '.' unless the input is '.'.++invert :: Char -> Char++invert ch = if ch == '.' then '#' else '.'+++-- Property++prop_rotate, prop_flipV, prop_flipH :: Picture -> Bool++prop_rotate pic = flipV (flipH pic) == flipH (flipV pic)++prop_flipV pic = flipV (flipV pic) == pic++prop_flipH pic = flipH (flipV pic) == pic++test_rotate, test_flipV, test_flipH :: Bool+ +test_rotate = flipV (flipH horse) == flipH (flipV horse)++test_flipV = flipV (flipV horse) == horse++test_flipH = flipH (flipV horse) == horse++-- More properties++prop_AboveFlipV pic1 pic2 = +    flipV (pic1 `above` pic2) == (flipV pic1) `above` (flipV pic2) ++prop_AboveFlipH pic1 pic2 = flipH (pic1 `above` pic2) == (flipH pic2) `above` (flipH pic1)++propAboveBeside1 nw ne sw se =+  (nw `beside` ne) `above` (sw `beside` se) +  == +  (nw `above` sw) `beside` (ne `above` se) ++propAboveBeside2 n s =+  (n `beside` n) `above` (s `beside` s) == (n `above` s) `beside` (n `above` s) ++propAboveBeside3 w e =+  (w `beside` e) `above` (w `beside` e) == (w `above` w) `beside` (e `above` e) ++propAboveBeside3Correct w e =+  (rectangular w && rectangular e && height w == height e) +  ==>+     (w `beside` e) `above` (w `beside` e) +         == +     (w `above` w) `beside` (e `above` e) ++-- auxiliary properties and functions++notEmpty pic = pic /= []++rectangular pic =+  notEmpty pic &&+  and [ length first == length l | l <-rest ]+  where+    (first:rest) = pic++height, width :: Picture -> Int++height = length+width = length . head++size :: Picture -> (Int,Int)++size pic = (width pic, height pic)++propAboveBesideFull nw ne sw se =+  (rectangular nw && rectangular ne && rectangular sw && rectangular se &&+   size nw == size ne && size ne == size se && size se == size sw) ==>+  (nw `beside` ne) `above` (sw `beside` se) == (nw `above` sw) `beside` (ne `above` se) ++-- Using explicit generators ...+++prop_1 = forAll (choose (1,10)) $ \x -> x/=x+(x::Int)++prop_2 = forAll (choose (1,10)) $ \x -> x/=(x::Int)++-- Generators suited to Pictures++-- chose either '.' or '#'++genChar :: Gen Char++genChar = oneof [return '.', return '#']++-- generate a list of length n each element from generator g.++genList :: Int -> Gen a -> Gen [a]++genList n g = sequence [ g | i<-[1..n] ]++-- generate a picture of given size using '.' and '#'++genSizedPicture :: Int -> Int -> Gen [String]++genSizedPicture height width =+      sequence [ genList width genChar | i<-[1::Int .. height] ]++-- generate a picture of random size using '.' and '#'++genPicture :: Gen [String]++genPicture =+    do+      height <- choose (1,10)+      width  <- choose (1,10)+      genSizedPicture height width++-- generate four pictures of the *same* random size using '.' and '#'++genFourPictures :: Gen ([String],[String],[String],[String])++genFourPictures =+    do+      height <- choose (1,10)+      width  <- choose (1,10)+      nw <- genSizedPicture height width+      ne <- genSizedPicture height width+      sw <- genSizedPicture height width+      se <- genSizedPicture height width+      return (nw,ne,sw,se)++-- test that above and besides commute when used with four pictures+-- of the same size++prop_AboveBeside =+    forAll genFourPictures $ \(nw,ne,sw,se) -> propAboveBeside1 nw ne sw se

@@ -0,0 +1,133 @@+-----------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+-- +--  QC.hs+--+--      Generating values randomly.+--+-----------------------------------------------------------------------++module QC where++import Test.QuickCheck++import Control.Monad (liftM,liftM2)+import System.IO.Unsafe (unsafePerformIO)+import Data.List (nub)+import QCfuns -- to Show functions++-- Simple examples for data generation++data Card = Card Int String+            deriving (Eq,Show)++data Info = Number Int | Email String+            deriving (Eq, Show)++data List a = Empty | Cons a (List a)+            deriving (Eq, Show)++instance Arbitrary Card where+    arbitrary =+        do+          int <- arbitrary+          string <- arbitrary+          return (Card int string)++instance Arbitrary Info where+    arbitrary =+        do+          boo <- arbitrary+          if boo+            then do+              int <- arbitrary+              return (Number int) +            else do+              string <- arbitrary+              return (Email string) ++-- Generating lists of samples++-- instance Arbitrary a => Arbitrary (List a) where+--     arbitrary =+--         do+--           boo <- elements [True, False]+--           if boo+--                   then +--                     return $ Empty +--                   else do+--                     val  <- arbitrary+--                     list <- arbitrary+--                     return $ Cons val list ++instance Arbitrary a => Arbitrary (List a) where+    arbitrary =+        do+          switch <- elements [1,2,3]+          case switch of +            1 -> return Empty +            _ -> +                do+                  val  <- arbitrary+                  list <- arbitrary+                  return (Cons val list) ++-- The expr type from the calculator++data Expr = Lit Integer |+            Add Expr Expr |+            Sub Expr Expr+                deriving (Show,Eq)++instance Arbitrary Expr where+    arbitrary = sized arbExpr++arbExpr :: Int -> Gen Expr++arbExpr 0 = liftM Lit arbitrary++arbExpr n = frequency+    [(1, liftM Lit arbitrary),+     (2, liftM2 Add subExp subExp),+     (2, liftM2 Sub subExp subExp)]+        where+          subExp = arbExpr (div n 2)+{-+arbExpr 0 = +    do int <- arbitrary+       return (Lit int)++arbExpr n+    | n>0 =+        do+          pick <- choose (0,2::Int)+          case pick of+            0 -> do +              int <- arbitrary+              return (Lit int)+            1 -> do +              left  <- subExp+              right <- subExp+              return (Add left right)+            2 -> do +              left  <- subExp+              right <- subExp+              return (Sub left right)+        where+          subExp = arbExpr (div n 2)+-}++prettyE :: Expr -> String++prettyE (Lit n) = show n+prettyE (Add e1 e2) = "("++prettyE e1 ++"+"++prettyE e2 ++")"+prettyE (Sub e1 e2) = "("++prettyE e1 ++"-"++prettyE e2 ++")"++-- Property of map++prop_map f g xs =+  map (f::Int->Int) (map (g::Int -> Int) xs) == map (g.f) xs+

@@ -0,0 +1,37 @@+-------------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+--+--  QCfuns+--+-------------------------------------------------------------------------++module QCfuns where++import Test.QuickCheck+import System.IO.Unsafe -- for unsafePerformIO++-- Sampling and showing functions++sampleFun :: (Arbitrary a,Show a, Show b)  => (a -> b) -> IO String++sampleFun f =+    do+      inputs <- sample' arbitrary+      let list = [ (a,f a) | a <- inputs ]+      return $ showMap list++showMap :: (Show a, Show b) => [(a,b)] -> String++showMap [] = "\n"+showMap [(a,b)] = showPair (a,b) ++ "\n"+showMap (p:ps)  = showPair p ++ " ," ++ showMap ps++showPair :: (Show a, Show b) => (a,b) -> String++showPair (a,b) = "("++show a ++ "|->" ++ show b ++ ")"++instance (Arbitrary a, Show a, Show b) => Show (a -> b) where+    show = unsafePerformIO . sampleFun

@@ -0,0 +1,133 @@+-----------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+--+--      RegExp.hs+-- +--  Regular Expressions+--+-----------------------------------------------------------------------++module RegExp where++type RegExp = String -> Bool++char :: Char -> RegExp++epsilon = (=="")++char ch = (==[ch])++(|||) :: RegExp -> RegExp ->  RegExp++e1 ||| e2 = +    \x -> e1 x || e2 x++(<*>) :: RegExp -> RegExp ->  RegExp++e1 <*> e2 =+    \x -> or [ e1 y && e2 z | (y,z) <- splits x ]++(<**>) :: RegExp -> RegExp ->  RegExp++e1 <**> e2 =+    \x -> or [ e1 y && e2 z | (y,z) <- fsplits x ]++splits xs = [splitAt n xs | n<-[0..len]]+    where+      len = length xs++star :: RegExp -> RegExp++star p = epsilon ||| (p <**> star p)+--           epsilon ||| (p <*> star p)+-- is OK as long as p can't have epsilon match++fsplits xs = tail (splits xs)++-- a = char 'a'++-- b = char 'b'++infixr 7 :*:+infixr 5 :|:++data RE = Eps |+          Ch Char |+          RE :|: RE |+          RE :*: RE |+          St RE |+          Plus RE+          deriving(Eq,Show)++evens = St two+two = (a :|: b) :*: (a :|: b)+          +a = Ch 'a'+b = Ch 'b'++-- interp: RE -> RegExp: exercise.++-- Value recursion+--  Eunmerating strings matching a regexp++enumerate :: RE -> [String]++enumerate Eps = [""]+enumerate (Ch ch) = [[ch]]+enumerate (re1 :|: re2)+    = enumerate re1 `interleave` enumerate re2+enumerate  (re1 :*: re2)+    = enumerate re1 `cartesian` enumerate re2+enumerate (St re)+    = result +      where+        result =+            [""] ++ (enumerate re `cartesian` result)++-- Auxiliary functions+-- interleave and product for potentially infinite lists++interleave :: [a] -> [a] -> [a]++interleave [] ys = ys+interleave (x:xs) ys = x : interleave ys xs+        +cartesian :: [[a]] -> [[a]] -> [[a]]++cartesian [] ys = []+cartesian (x:xs) ys +    = [ x++y | y<-ys ] `interleave` cartesian xs ys+    +-- Recursive regular expressions++anbn :: RE++anbn = Eps :|: (a :*: (anbn :*: b))++-- Extending the implementation++plus :: RE -> RE+plus re = re :*: St re++-- Simplification++simplify :: RE -> RE++simplify (St (St re)) = simplify (St re)+simplify (Plus (St re)) = simplify (St re)+simplify (St (Plus re)) = simplify (St re)+simplify (re1 :|: re2) =+    if sre1==sre2 then sre1 else sre1 :|: sre2 +          where+            sre1 = simplify re1; sre2 = simplify re2+simplify re = re++-- smart constructors++starC :: RE -> RE+starC (St re) = re+starC (Plus re) = re+starC re = St re

@@ -0,0 +1,237 @@++--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2010.++--  Chapter 21++-- Time and space behaviour+-- ^^^^^^^^^^^^^^^^^^^^^^^^++module Chapter21 where++import Prelude hiding (map)++-- Various functions whose complexity is discussed.+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- Naive Fibonacci function++fib :: Integer -> Integer++fib 0 = 0+fib 1 = 1+fib m = fib (m-2) + fib (m-1)++-- Naive factorial function++fac :: Integer -> Integer+fac 0 = 1+fac n = n * fac (n-1)++-- Insertion sort++iSort :: Ord a => [a] -> [a]++iSort []     = []+iSort (x:xs) = ins x (iSort xs)++ins :: Ord a => a -> [a] -> [a]++ins x [] = [x]+ins x (y:ys) +  | (x<=y)      = x:y:ys+  | otherwise   = y:ins x ys++-- Quicksort++qSort :: Ord a => [a] -> [a]++qSort []     = []+qSort (x:xs) = qSort [z|z<-xs,z<=x] ++ [x] ++ qSort [z|z<-xs,z>x]++-- Two reverse functions++rev1 []     = []+rev1 (x:xs) = rev1 xs ++ [x]++rev2            = shunt []+shunt xs []     = xs+shunt xs (y:ys) = shunt (y:xs) ys++-- Two multiplication functions++mult n 0 = 0+mult n m = mult n (m-1) + n++russ n 0 = 0+russ n m +  | (m `mod` 2 == 0)    = russ (n+n) (m `div` 2)+  | otherwise           = russ (n+n) (m `div` 2) + n++-- The merge sort function ++mSort :: Ord a => [a] -> [a]++mSort xs +  | (len < 2)   = xs+  | otherwise   = mer (mSort (take m xs)) (mSort (drop m xs))+    where+    len = length xs+    m   = len `div` 2++mer :: Ord a => [a] -> [a]  -> [a]++mer (x:xs) (y:ys) +  | (x<=y)      = x : mer xs (y:ys)+  | otherwise   = y : mer (x:xs) ys+mer (x:xs) []   = (x:xs)+mer []     ys   = ys++-- Implementations of sets+-- ^^^^^^^^^^^^^^^^^^^^^^^++-- Sets implemented as _unordered_ lists.++-- type Set a = [a]++-- empty        = []+-- memSet       = member+-- inter xs ys  = filter (member xs) ys+-- union        = (++)+-- subSet xs ys = and (map (member ys) xs)+-- eqSet xs ys  = subSet xs ys && subSet ys xs+-- makeSet      = id+-- mapSet       = map+--  +++-- Space behaviour+-- ^^^^^^^^^^^^^^^++-- Lazy evaluation+-- ^^^^^^^^^^^^^^^++-- List examples++exam1 n = [1 .. n] ++ [1 .. n]++exam2 n = list ++ list +          where +          list=[1 .. n]++exam3 n = [1 .. n] ++ [last [1 .. n]]++exam4 n = list ++ [last list]+          where+          list=[1 .. n]+++-- Saving space?+-- ^^^^^^^^^^^^^++-- A new version of factorial++newFac :: Integer -> Integer+newFac n = aFac n 1++aFac :: Integer -> Integer -> Integer+aFac 0 p = p+aFac n p = aFac (n-1) (p*n)++-- This can be modified thus:+--  aFac n p+--    | p==p        = aFac (n-1) (p*n)++-- Miscellaneous functions++sumSquares :: Integer -> Integer+sumSquares n = sumList (map sq [1 .. n])++sumList = foldr (+) 0+sq n    = n*n++++-- Folding revisited+-- ^^^^^^^^^^^^^^^^^++-- Map defined using foldr++map f = foldr ((:).f) []++-- Factorial using foldr++facFold n = foldr (*) 1 [1 .. n]++-- Examples++foldEx1 n = foldr (&&) True (map (==2) [2 .. n])++++-- Avoiding re-computation: memoization+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- The Fibonacci numbers++-- A naive algorithm is given earlier in this script.++-- An algorithm which returns a pair of consecutive Fibonacci numbers.++fibP :: Integer -> (Integer,Integer)++fibP 0 = (0,1)+fibP n = (y,x+y)+         where+         (x,y) = fibP (n-1)++-- The list of Fibonacci values, defined directly.++fibs ::[Integer]++fibs = 0 : 1 : zipWith (+) fibs (tail fibs)+++-- Dynamic programming: maximal common subsequence+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- The naive algorithm ...++mLen :: Eq a => [a] -> [a] -> Integer++mLen xs []        = 0+mLen [] ys        = 0+mLen (x:xs) (y:ys) +  | x==y        = 1 + mLen xs ys+  | otherwise   = max (mLen xs (y:ys)) (mLen (x:xs) ys)++-- ... translated to talk about sub-components of lists, described by their+-- endpoints ...++maxLen :: Eq a => [a] -> [a] -> Int -> Int -> Int++maxLen xs ys 0 j = 0 +maxLen xs ys i 0 = 0+maxLen xs ys i j+  | xs!!(i-1) == ys!!(j-1)  = (maxLen xs ys (i-1) (j-1)) + 1+  | otherwise               = max (maxLen xs ys i (j-1))+                                  (maxLen xs ys (i-1) j)++-- ... and then transliterated into a memoised version.++maxTab ::  Eq a => [a] -> [a] -> [[Int]]++maxTab xs ys+  = result+    where +    result = [0,0 .. ] : zipWith f [0 .. ] result+    f i prev  +        = ans+          where+          ans   = 0 : zipWith g [0 .. ] ans+          g j v +            | xs!!i == ys!!j      = prev!!j + 1+            | otherwise           = max v (prev!!(j+1))++

@@ -0,0 +1,37 @@+-----------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+--+--  PerformanceI.hs+--+-----------------------------------------------------------------------++module Main where++main = putStrLn (show (sumI 1 1000000))+-- main = putStrLn (show (sumIA 1 1000000))+-- main = putStrLn (show (sumIS 1 1000000))++sumI :: Integer -> Integer -> Integer++sumI n m+ | n>m       = 0+ | otherwise = n + sumI (n+1) m++sumIA :: Integer -> Integer -> Integer++sumIA n m = accIA n m 0++accIA n m s+ | n>m       = s+ | otherwise = accIA (n+1) m (n+s)++sumIS :: Integer -> Integer -> Integer++sumIS n m = accIS n m 0++accIS n m s+ | n>m       = s+ | otherwise = accIS (n+1) m $! (n+s)

@@ -0,0 +1,37 @@+-----------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+--+--  PerformanceIA.hs+--+-----------------------------------------------------------------------++module Main where++-- main = putStrLn (show (sumI 1 1000000))+main = putStrLn (show (sumIA 1 1000000))+--- main = putStrLn (show (sumIS 1 1000000))++sumI :: Integer -> Integer -> Integer++sumI n m+ | n>m       = 0+ | otherwise = n + sumI (n+1) m++sumIA :: Integer -> Integer -> Integer++sumIA n m = accIA n m 0++accIA n m s+ | n>m       = s+ | otherwise = accIA (n+1) m (n+s)++sumIS :: Integer -> Integer -> Integer++sumIS n m = accIS n m 0++accIS n m s+ | n>m       = s+ | otherwise = accIS (n+1) m $! (n+s)

@@ -0,0 +1,37 @@+-----------------------------------------------------------------------+--+--  Haskell: The Craft of Functional Programming+--  Simon Thompson+--  (c) Addison-Wesley, 1996-2011.+--+--  PerformanceIS.hs+--+-----------------------------------------------------------------------++module Main where++-- main = putStrLn (show (sumI 1 1000000))+-- main = putStrLn (show (sumIA 1 1000000))+main = putStrLn (show (sumIS 1 1000000))++sumI :: Integer -> Integer -> Integer++sumI n m+ | n>m       = 0+ | otherwise = n + sumI (n+1) m++sumIA :: Integer -> Integer -> Integer++sumIA n m = accIA n m 0++accIA n m s+ | n>m       = s+ | otherwise = accIA (n+1) m (n+s)++sumIS :: Integer -> Integer -> Integer++sumIS n m = accIS n m 0++accIS n m s+ | n>m       = s+ | otherwise = accIS (n+1) m $! (n+s)

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: Craft3e-version: 0.2.0.4+version: 0.2.0.5 license: MIT license-file: LICENSE copyright: (c) Simon Thompson@@ -40,6 +40,7 @@     QuickCheck >= 2.1 && < 3,     old-locale == 1.0.*,     time >= 1.1 && < 2,+    random >= 1.1 && < 1.3,     mtl >= 1.1 && < 2.3,     HUnit >= 1.2.0 && < 1.7,     open-browser >= 0.1.0.0 && < 0.5@@ -55,8 +56,9 @@     Chapter14_2     Chapter17     Chapter18+    Chapter19     Chapter2-    Chapter20+    Chapter21     Chapter3     Chapter4     Chapter5@@ -112,14 +114,22 @@     QueueState     RandomGen     ServerState-    TopLevelServe  +    TopLevelServe+    Minesweeper+    Minesweeper2+    Minesweeper3+    Minesweeper4+    Minesweeper5+    MineRandom+    Palin -  hs-source-dirs: . ./Calculator ./Chapter15 ./Chapter16 ./Chapter19 ./Simulation  ./Chapter20+  hs-source-dirs: . ./Calculator ./Chapter15 ./Chapter16 ./Chapter20 ./Simulation  ./Chapter21 ./Minesweeper ./Palindromes  executable performanceI   main-is:     PerformanceI.hs-  hs-source-dirs: ./Chapter20+  hs-source-dirs: ./Chapter21   default-language: Haskell2010+  ghc-options: -rtsopts   build-depends:     base >= 4 && < 5,     Craft3e@@ -127,16 +137,18 @@  executable performanceIA   main-is:     PerformanceIA.hs-  hs-source-dirs: ./Chapter20+  hs-source-dirs: ./Chapter21   default-language: Haskell2010+  ghc-options: -rtsopts   build-depends:     base >= 4 && < 5,     Craft3e  executable performanceIS   main-is:     PerformanceIS.hs-  hs-source-dirs: ./Chapter20+  hs-source-dirs: ./Chapter21   default-language: Haskell2010+  ghc-options: -rtsopts   build-depends:     base >= 4 && < 5,     Craft3e

@@ -0,0 +1,97 @@+----------------------------------------------------------
+--							--
+--	MineRandom.hs					--
+--							--
+--	Simon Thompson					--
+--							--
+--	2002-2011					--
+--							--
+----------------------------------------------------------
+
+-- Choosing a random starting configuration for 
+-- a minesweeper game.
+
+-- Making dynamic choices: get the seed on each invocation.
+-- Have to refactor choices etc. to take the seed as a parameter.
+
+module MineRandom ( randomGrid, randomGridDyn ) where
+import System.Random
+import System.IO.Unsafe ( unsafePerformIO )
+import Data.Time.Clock.POSIX ( getPOSIXTime )
+import Data.List ( insert , nub )
+
+-- Generate a random combination of m elements from n 
+-- i.e. choice of 0, 1, ..., n-1.
+-- The algorithm used makes repeated random choices until m different
+-- values are found.
+-- Perfectly efficient for n=100, m=40; not for 1000,400.
+-- Assumes that m<=n.
+-- Postcondition: the result is in ascending order; no duplicates.
+-- 16.6.02 seed is made a parameter
+
+choices :: Int -> Int -> Int -> [Int]
+
+choices seed n m
+  = fst (choicesAux ([],rands))
+    where
+    
+    choicesAux :: ([Int],[Int]) -> ([Int],[Int])
+    choicesAux (cs,(r:rs))
+      | length cs >= m 	= (cs,[])
+      | otherwise	= choicesAux (nub (insert r cs) , rs)
+      
+    rands :: [Int]
+    rands = randomRs (0::Int,n-1) (mkStdGen seed)
+    
+-- A random startup
+
+-- A seed for the random numbers is given by system time in seconds.
+-- A value is chosen once per session: the value persists through a
+-- session.
+
+sessionSeed :: Int
+
+sessionSeed = round (unsafePerformIO getPOSIXTime)
+
+-- A list of n choices from an m*p matrix
+-- 	m = row length
+--	p = column height
+-- Assumes that the postcondition for choices holds.
+-- 16.6.02 seed is made a parameter to the old randomGrid, now
+-- renamed randomGridMake.
+
+randomGridMake :: Int -> Int -> Int -> Int -> [[Bool]]
+
+randomGridMake seed n m p 
+  = pad
+    where
+    
+    makeMatrix :: Int -> [Int] -> [[Bool]]
+
+    makeMatrix i cs
+      | cs==[]		= []
+      | otherwise
+        = convert first : makeMatrix (i+1) rest
+	  where
+	  (first,rest) = span ((==i).(flip div m)) cs
+	  convert ns 
+	     = map check [0 .. m-1]
+	       where
+	       check n = elem n [ x `mod` m | x<-ns ]
+
+    rows = makeMatrix 0 (choices seed (m*p) n)
+     
+    pad = rows ++ replicate (p - length rows) (replicate m False)
+
+-- Random grid with a per-session seed.
+
+randomGrid :: Int -> Int -> Int -> [[Bool]]
+
+randomGrid = randomGridMake sessionSeed 
+
+-- Random grid with a per-invocation seed.
+
+randomGridDyn :: Int -> Int -> Int -> Int -> [[Bool]]
+
+randomGridDyn 
+  = randomGridMake 

@@ -0,0 +1,250 @@+----------------------------------------------------------
+--							--
+--	Minesweeper.hs					--
+--							--
+--	Simon Thompson					--
+--							--
+--      2002-2011                                       --
+--                                                      --
+----------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+
+-- NB: Requires pragma above for instance declaration of
+-- non-atomic type: 
+--	instance AddThree [Int] where ...
+
+-- The board is represented by a list of lists. It is a
+-- global assumption that this is rectangular, that is all
+-- component lists have the same length.
+-- It is also assumed that grids are nonempty.
+
+module Minesweeper where
+import MineRandom ( randomGrid )
+import Data.List ( (\\) )
+
+
+type Config = [[Bool]]
+
+type Count  = [[Int]]
+
+class AddThree a where
+  add3 :: a -> a -> a -> a
+  zero :: a
+  addOffset :: [a] -> [a]
+  addOffset = zipOffset3 add3 zero
+  
+instance AddThree Int where
+  add3 n m p = n+m+p
+  zero       = 0
+
+instance AddThree [Int] where
+  add3 = zipWith3 add3
+  zero = repeat zero
+
+-- Combine elementwise (i.e. zipWith3) the three lists:
+--
+--	 z,a0,a1,a2,...
+--	a0,a1,a2,...,an
+--      a1,a2,...,an,z
+--
+-- using the ternary function f
+-- Example: f is addition of three numbers, z is zero.
+
+zipOffset3 :: (a -> a -> a -> a) -> a -> [a] -> [a]
+
+zipOffset3 f z xs = zipWith3 f (z:xs) xs (tail xs ++ [z])
+
+-- From the grid of occupation (Boolean) calculate the
+-- number of occupied adjacent squares.
+-- Note that the stone in the square itself is also
+-- counted.
+
+countConfig :: [[Bool]] -> [[Int]]
+
+countConfig = addOffset . map addOffset . makeNumeric
+
+-- A variant of countConfig which doesn't count the stone in
+-- the square itself.
+
+countConfigLess :: [[Bool]] -> [[Int]]
+
+countConfigLess bs 
+  = zipWith (zipWith (-)) (countConfig bs) (makeNumeric bs)
+
+-- Boolean matrix to numeric matrix; True to 1, 
+-- False to 0.
+
+makeNumeric :: [[Bool]] -> [[Int]]
+
+makeNumeric = map (map (\b -> if b then 1 else 0))
+
+-- A 3*3 Boolean test matrix.
+
+test1 = [[True, False, True],[True,True,True],[False,True,True]]
+
+-- Printing the grid
+
+showGrid :: [[Int]] -> String
+
+showGrid nss = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith f [0 .. length nss - 1] nss)
+	     where
+	     f n ns = pad 3 (show n) ++ concat (map show ns) ++ "\n"
+
+pad :: Int -> String -> String
+
+pad n st
+  | len <= n		= st ++ replicate (n - len) ' ' 
+  | otherwise		= take n st
+    where
+    len = length st
+
+showTest1 :: IO ()
+
+showTest1 = putStr $ showGrid $ countConfig test1
+
+showGrid3 :: IO ()
+
+showGrid3 = putStr $ showGrid $ map (map (\b -> if b then 1 else 0)) test3
+
+
+showTest3 :: IO ()
+
+showTest3 = putStr $ showGrid $ countConfig test3
+
+tester3 :: IO ()
+
+tester3 = showGrid3 >> showTest3
+
+
+test3 = randomGrid 20 10 10
+
+
+-- Strength of the product functor on the left
+
+appLeft :: (a -> b) -> (a,c) -> (b,c)
+
+appLeft f (x,y) = (f x , y)
+
+-- Update list xs at index n to have value f (xs!!n)
+-- Handles out of range indices
+	     
+update :: Int -> (a -> a) -> [a] -> [a]
+
+update n f xs = front ++ rear
+		where
+		(front,rest) = splitAt n xs
+		rear = case rest of
+			[]	-> []
+			(h:t)	-> f h:t
+			
+-- Update an array to have value x at position (n,m)			
+ 
+updateArray :: Int -> Int -> a -> [[a]] -> [[a]]
+
+updateArray n m x xss = update n (update m (const x)) xss
+
+-- Show play
+-- Assumes that the two arrays are of the same shape
+-- The second array gives the adjacency count of the cell,
+-- whilst the first indicates whether or not it is uncovered.
+
+
+showPlay :: [[Bool]] -> [[Int]] -> String
+
+showPlay ess nss = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith3 f [0 .. length nss - 1] ess nss)
+	     where
+	     f n es ns = pad 3 (show n) ++ concat (zipWith showCell es ns) ++ "\n"
+
+-- How to show the value in a particular cell.
+
+showCell :: Bool -> Int -> String
+
+showCell b n = if not b then "X"
+                        else if n==0 then " "
+			             else show n
+
+
+showTest2 :: IO ()
+
+showTest2 = putStr $ showPlay showing (countConfig test1)
+
+showing = [[True, False, False],[True, False, True],[True,True,True]]
+
+
+
+
+playGame :: IO ()
+
+playGame = 
+   playGameGrid showing
+
+   where
+
+   grid      = randomGrid 20 10 10
+   count     = countConfig grid			
+   countLess = countConfigLess grid	-- Added 26.4.02 (superfluous)
+   showing   = map (map (const False)) grid
+
+   playGameGrid :: [[Bool]] -> IO ()
+
+   playGameGrid showing =
+     do { putStr (showPlay showing count) ;
+          rowCh <- getChar ;
+	  let { row = fromEnum rowCh - fromEnum '0' } ;
+	  colCh <- getChar ;
+	  let { col = fromEnum colCh - fromEnum 'a' } ;
+	  putStr "\n" ;
+	  if grid!!row!!col then do { putStr "LOST!" ; return () }
+	  else
+	    playGameGrid (uncoverNbhrs count [(row,col)] (row,col) showing)
+	}
+     
+-- Transitively uncover all the neighbours of all the points in a list.
+-- Repeatedly applies uncoverNbhrs
+
+uncoverNbhrsList :: [[Int]] -> [(Int,Int)] -> [(Int,Int)] -> 
+                    [[Bool]] -> [[Bool]]
+
+uncoverNbhrsList count avoid
+  = foldr (.) id . map (uncoverNbhrs count avoid)
+
+-- Transitively uncover all the neighbours of a point.
+-- First uncover the immediate neighbours, then call recursively on
+-- all the neighbours with zero adjacency count.
+   
+uncoverNbhrs :: [[Int]] -> [(Int,Int)] -> (Int,Int) -> 
+                [[Bool]] -> [[Bool]]
+
+uncoverNbhrs count avoid (p,q)
+  = uncoverNbhrsList count (avoid++nbhrs count (p,q)) 
+                           (nullNbhrs count (p,q) \\ avoid) 
+    .
+    ( foldr (.) id $ 
+      map ((flip.uncurry) updateArray True) (nbhrs count (p,q)) )
+
+-- What are the neighbours of a point?
+
+nbhrs :: [[Int]] -> (Int,Int) -> [(Int,Int)]
+
+nbhrs count (p,q)
+  = filter inGrid [ (p-1,q-1), (p-1,q), (p-1,q+1),
+                    (p,q-1),   (p,q),   (p,q+1),
+		    (p+1,q-1), (p+1,q), (p+1,q+1) ]
+    where
+    inGrid (s,t) = 0<=s && s <= rows &&
+                   0<=t && t <= cols
+    rows = length count - 1
+    cols = length (head count) -1
+
+-- What are the null nbhrs?
+
+nullNbhrs :: [[Int]] -> (Int,Int) -> [(Int,Int)]
+
+nullNbhrs count (p,q)
+  = filter zeroVal (nbhrs count (p,q))
+    where
+    zeroVal (s,t) = count!!s!!t==0
+    

@@ -0,0 +1,407 @@+----------------------------------------------------------
+--							--
+--	Minesweeper2.hs					--
+--							--
+--	Simon Thompson					--
+--							--
+--      2002-2011                                       --
+--                                                      --
+----------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+
+
+-- NB: Requires pragma above for instance declaration of
+-- non-atomic type: 
+--	instance AddThree [Int] where ...
+
+-- Modifies Minesweeper.hs, by adding choice of reveal and mark
+
+-- The board is represented by a list of lists. It is a
+-- global assumption that this is rectangular, that is all
+-- component lists have the same length.
+-- It is also assumed that grids are nonempty.
+
+module Minesweeper2 where
+import MineRandom ( randomGrid )
+import Data.List ( (\\), zipWith4, nub )
+
+
+type Config = [[Bool]]
+
+type Count  = [[Int]]
+
+class AddThree a where
+  add3 :: a -> a -> a -> a
+  zero :: a
+  addOffset :: [a] -> [a]
+  addOffset = zipOffset3 add3 zero
+  
+instance AddThree Int where
+  add3 n m p = n+m+p
+  zero       = 0
+
+instance AddThree [Int] where
+  add3 = zipWith3 add3
+  zero = repeat zero
+
+-- Combine elementwise (i.e. zipWith3) the three lists:
+--
+--	 z,a0,a1,a2,...
+--	a0,a1,a2,...,an
+--      a1,a2,...,an,z
+--
+-- using the ternary function f
+-- Example: f is addition of three numbers, z is zero.
+
+zipOffset3 :: (a -> a -> a -> a) -> a -> [a] -> [a]
+
+zipOffset3 f z xs = zipWith3 f (z:xs) xs (tail xs ++ [z])
+
+-- From the grid of occupation (Boolean) calculate the
+-- number of occupied adjacent squares.
+-- Note that the stone in the square itself is also
+-- counted.
+
+countConfig :: [[Bool]] -> [[Int]]
+
+countConfig = addOffset . map addOffset . makeNumeric
+
+-- A variant of countConfig which doesn't count the stone in
+-- the square itself.
+
+countConfigLess :: [[Bool]] -> [[Int]]
+
+countConfigLess bs 
+  = zipWith (zipWith (-)) (countConfig bs) (makeNumeric bs)
+
+-- Boolean matrix to numeric matrix; True to 1, 
+-- False to 0.
+
+makeNumeric :: [[Bool]] -> [[Int]]
+
+makeNumeric = map (map (\b -> if b then 1 else 0))
+
+-- A 3*3 Boolean test matrix.
+
+test1 = [[True, False, True],[True,True,True],[False,True,True]]
+
+-- Printing the grid
+
+showGrid :: [[Int]] -> String
+
+showGrid nss = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith f [0 .. length nss - 1] nss)
+	     where
+	     f n ns = pad 3 (show n) ++ concat (map show ns) ++ "\n"
+
+pad :: Int -> String -> String
+
+pad n st
+  | len <= n		= st ++ replicate (n - len) ' ' 
+  | otherwise		= take n st
+    where
+    len = length st
+
+-- Strength of the product functor on the left
+
+appLeft :: (a -> b) -> (a,c) -> (b,c)
+
+appLeft f (x,y) = (f x , y)
+
+-- Update list xs at index n to have value f (xs!!n)
+-- Handles out of range indices
+	     
+update :: Int -> (a -> a) -> [a] -> [a]
+
+update n f xs = front ++ rear
+		where
+		(front,rest) = splitAt n xs
+		rear = case rest of
+			[]	-> []
+			(h:t)	-> f h:t
+			
+-- Update an array to have value x at position (n,m)			
+ 
+updateArray :: Int -> Int -> a -> [[a]] -> [[a]]
+
+updateArray n m x xss = update n (update m (const x)) xss
+
+-- Show play
+-- Assumes that the two arrays are of the same shape
+-- The second array gives the adjacency count of the cell,
+-- whilst the first indicates whether or not it is uncovered.
+
+
+showPlay :: [[Bool]] -> [[Bool]] -> [[Int]] -> String
+
+showPlay ess mss nss 
+           = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith4 f [0 .. length nss - 1] ess mss nss)
+	     where
+	     f n es ms ns 
+	       = pad 3 (show n) ++ concat (zipWith3 showCell es ms ns) ++ "\n"
+
+-- How to show the value in a particular cell.
+
+showCell :: Bool -> Bool -> Int -> String
+
+showCell showing marked n 
+	= if marked then "X"
+	     else if not showing then "."
+                 else if n==0 then " "
+		     else show n
+
+
+-- Play the game; pass in the number of mines
+-- and the (square) board size as initial arguments.
+
+playGame :: Int -> Int -> IO ()
+
+playGame mines size = 
+   playGameGrid showing marked
+
+   where
+
+   grid      = randomGrid mines size size
+   count     = countConfig grid			
+   showing   = map (map (const False)) grid
+   marked    = map (map (const False)) grid
+   
+   playGameGrid :: [[Bool]] -> [[Bool]] -> IO ()
+
+   playGameGrid showing marked =
+     do { putStr (showPlay showing marked count) ;
+          choice <- getChar ;
+	  if choice=='q' 				-- quit
+	  then 
+	   do { putStr "\nquit" ; return () }
+	  else if not (elem choice "smur")		-- ignore illegal
+	  then						-- choice
+	   do { putStr "\n" ; playGameGrid showing marked }
+	  else 
+	   do {
+           rowCh <- getChar ;				-- get row
+	   let { row = fitRange size (fromEnum rowCh - fromEnum '0') } ; 
+	   colCh <- getChar ;				-- and column
+	   let { col = fitRange size (fromEnum colCh - fromEnum 'a') } ;
+	   putStr "\n" ;
+	   case choice of
+	    'm' -> playGameGrid showing (updateArray row col True marked)
+	    'u' -> playGameGrid showing (updateArray row col False marked)
+	    'r' -> if grid!!!(row,col) 
+	             then (do { putStr "LOST!" ; return () })
+	             else
+	                (playGameGrid (uncoverClosure count (row,col) showing)
+	                              marked)
+	    's' -> do { putStr $ showInfo count showing marked row col ; 
+	                putStr "---------\n" ;
+	                putStr $ showEquations $ fixSplit $
+			         getInfo count showing marked row col ;
+	                playGameGrid showing marked }
+	       }
+	}
+
+-- Finding the closure of a point / set of points.
+-- The worker functions: doClosure, doClosureList, carry around a 
+-- list of points already visited.
+
+closure :: [[Int]] -> (Int,Int) -> [(Int,Int)]
+
+closure count point = doClosure count point []
+
+-- doClosure, doClosureList use a variant of the algorithm 
+-- on pp333-4 of craft2e.
+
+doClosure :: [[Int]] -> (Int,Int) -> [(Int,Int)] -> [(Int,Int)]
+
+doClosure count point avoid
+  | count!!!point /= 0	= [point]
+  | otherwise	
+    = point : doClosureList count nbs (point:avoid)
+      where
+      nbs = nbhrs count point
+
+doClosureList :: [[Int]] -> [(Int,Int)] -> [(Int,Int)] -> [(Int,Int)]
+
+doClosureList count [] avoid = []
+
+doClosureList count (point: points) avoid
+  = next ++ doClosureList count points (avoid ++ next)
+    where
+    next = if elem point avoid
+           then [point]
+	   else doClosure count point avoid
+
+-- Uncover all the points in the closure
+
+uncoverClosure :: [[Int]] -> (Int,Int) -> [[Bool]] -> [[Bool]]
+
+uncoverClosure count point 
+  = foldr (.) id $ 
+    map ((flip.uncurry) updateArray True) (closure count point)
+
+-- What are the neighbours of a point?
+
+nbhrs :: [[Int]] -> (Int,Int) -> [(Int,Int)]
+
+nbhrs count (p,q)
+  = filter inGrid [ (p-1,q-1), (p-1,q), (p-1,q+1),
+                    (p,q-1),   (p,q),   (p,q+1),
+		    (p+1,q-1), (p+1,q), (p+1,q+1) ]
+    where
+    inGrid (s,t) = 0<=s && s <= rows &&
+                   0<=t && t <= cols
+    rows = length count - 1
+    cols = length (head count) -1
+
+-- Push an integer value into the range 
+--	0 .. r-1
+
+fitRange :: Int -> Int -> Int
+
+fitRange r val
+  | 0<=val && val<r	= val
+  | val<0		= 0
+  | val>=r 		= r-1
+
+-- Array lookup operation
+
+(!!!) :: [[a]] -> (Int,Int) -> a
+
+xss!!!(p,q) = xss!!p!!q
+
+-- Showing the information about a given cell,
+-- in the context of certain known information:
+--	count showing marked
+-- Produces an equation corresponding to each neighbour
+-- which has its value showing.
+-- Count zero for showing zeroes and 1 for marked cells
+-- i.e. assumes that markings are correct.
+
+-- Refactored as getInfoCell below ....
+
+getInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> Equations
+
+getInfo count showing marked row col
+  = map (uncurry (getInfoCell count showing marked))
+        [ point | point <- nbhrs count (row,col) , showing!!!point ]
+
+showInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> String
+
+showInfo count showing marked row col 
+  = showEquations (getInfo count showing marked row col)
+			  
+type Equations = [Equation]
+type Equation  = (Int, [(Int,Int)])
+
+-- Initial program for the information extracts it and immediately
+-- shows it. Subsequently refactored to produce a data structure
+-- containing the information, and a corresponding show function over
+-- the data structure.
+
+-- Call this separate producer and consumer ... allows whatever is
+-- produced to be used in more than one way.
+-- Can envisage the converse too: merging producer and consumer,
+-- particularly if there's only one use of the producer in the program.
+
+getInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> Equation 
+
+getInfoCell count showing marked s t 
+  = ( (count!!!(s,t) - marks) , 
+      [ point | point <- nbrs, not (showing!!!point), 
+    			       not (marked!!!point) ]
+    )
+    where 
+    nbrs              = nbhrs count (s,t)
+    marks             = sum [ 1 | point<-nbrs , marked!!!point ]
+
+-- Showing the information in a cell
+    
+showInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> String 
+
+showInfoCell count showing marked s t 
+  = showEquation (getInfoCell count showing marked s t)
+
+showEquations = concat . (map showEquation)
+
+showEquation :: Equation -> String
+
+showEquation (lhs, rhs) 
+  = show lhs ++ " = " ++ showPoints rhs ++ "\n"
+
+showRow :: Int -> String
+showRow           = show
+
+showCol :: Int -> String
+showCol t         = [ toEnum (t + fromEnum 'a') ]
+
+showPoint :: (Int,Int) -> String
+showPoint (p,q)   = showRow p ++ showCol q
+
+showPoints :: [(Int,Int)] -> String
+showPoints []     = "none"
+showPoints [p]    = showPoint p
+showPoints (p:ps) = showPoint p ++ " + " ++ showPoints ps
+
+-- Reducing a list of equations to a normal form
+
+-- Is one list a sublist of the other?
+-- It is assumed that the elements appear in the same order, 
+-- without repetitions.
+
+subList :: Eq a => [a] -> [a] -> Bool
+
+subList [] _     = True
+subList (_:_) [] = False
+subList (x:xs) (y:ys)
+  | x==y	= subList xs ys
+  | otherwise	= subList (x:xs) ys
+
+-- The difference of two lists;
+-- only applied when the first is a subList of the second.
+
+listDiff :: Eq a => [a] -> [a] -> [a]
+
+listDiff [] ys	= ys
+listDiff (_:_) [] = error "listDiff applied to non-subList"
+listDiff (x:xs) (y:ys) 
+  | x==y	= listDiff xs ys
+  | otherwise	= y : listDiff (x:xs) ys
+
+-- Only splits when the first rhs is a sublist of the second
+-- and a proper sublist at that.
+
+splitEq :: Equation -> Equation -> Equation
+
+splitEq e1@(l1,r1) e2@(l2,r2)
+  | e1==e2		= e2
+  | subList r1 r2	= (l2-l1 , listDiff r1 r2)
+  | otherwise		= e2
+
+
+-- Split a set (list) of equations
+
+splitEqs :: [Equation] -> [Equation]
+
+splitEqs eqs
+  = foldr (.) id (map map (map splitEq eqs)) eqs
+
+-- Generic fixpt operator
+
+fixpt :: Eq a => (a -> a) -> a -> a
+
+fixpt f x
+  = g x
+    where
+    g y
+  	| y==next	= y
+  	| otherwise	= g next
+    	  where
+	  next = f y
+
+fixSplit :: [Equation] -> [Equation]
+
+fixSplit = fixpt (nub.splitEqs)
+
+

@@ -0,0 +1,498 @@+----------------------------------------------------------
+--							--
+--	Minesweeper3.hs					--
+--							--
+--	Simon Thompson					--
+--							--
+--      2002-2011                                       --
+--                                                      --
+----------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+
+
+-- NB: Requires pragma above for instance declaration of
+-- non-atomic type: 
+--	instance AddThree [Int] where ...
+
+-- Modifies Minesweeper2.hs, by ... (to be completed)
+
+-- The board is represented by a list of lists. It is a
+-- global assumption that this is rectangular, that is all
+-- component lists have the same length.
+-- It is also assumed that counts are nonempty.
+
+module Minesweeper3 where
+import MineRandom ( randomGrid )
+import Data.List ( (\\), zipWith4, nub )
+
+
+type Config = [[Bool]]
+
+type Count  = [[Int]]
+
+class AddThree a where
+  add3 :: a -> a -> a -> a
+  zero :: a
+  addOffset :: [a] -> [a]
+  addOffset = zipOffset3 add3 zero
+  
+instance AddThree Int where
+  add3 n m p = n+m+p
+  zero       = 0
+
+instance AddThree [Int] where
+  add3 = zipWith3 add3
+  zero = repeat zero
+
+-- Combine elementwise (i.e. zipWith3) the three lists:
+--
+--	 z,a0,a1,a2,...
+--	a0,a1,a2,...,an
+--      a1,a2,...,an,z
+--
+-- using the ternary function f
+-- Example: f is addition of three numbers, z is zero.
+
+zipOffset3 :: (a -> a -> a -> a) -> a -> [a] -> [a]
+
+zipOffset3 f z xs = zipWith3 f (z:xs) xs (tail xs ++ [z])
+
+-- From the grid of occupation (Boolean) calculate the
+-- number of occupied adjacent squares.
+-- Note that the stone in the square itself is also
+-- counted.
+
+countConfig :: [[Bool]] -> [[Int]]
+
+countConfig = addOffset . map addOffset . makeNumeric
+
+-- A variant of countConfig which doesn't count the stone in
+-- the square itself.
+
+countConfigLess :: [[Bool]] -> [[Int]]
+
+countConfigLess bs 
+  = zipWith (zipWith (-)) (countConfig bs) (makeNumeric bs)
+
+-- Boolean matrix to numeric matrix; True to 1, 
+-- False to 0.
+
+makeNumeric :: [[Bool]] -> [[Int]]
+
+makeNumeric = map (map (\b -> if b then 1 else 0))
+
+-- A 3*3 Boolean test matrix.
+
+test1 = [[True, False, True],[True,True,True],[False,True,True]]
+
+-- Printing the grid
+
+showGrid :: [[Int]] -> String
+
+showGrid nss = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith f [0 .. length nss - 1] nss)
+	     where
+	     f n ns = pad 3 (show n) ++ concat (map show ns) ++ "\n"
+
+pad :: Int -> String -> String
+
+pad n st
+  | len <= n		= st ++ replicate (n - len) ' ' 
+  | otherwise		= take n st
+    where
+    len = length st
+
+-- Strength of the product functor on the left
+
+appLeft :: (a -> b) -> (a,c) -> (b,c)
+
+appLeft f (x,y) = (f x , y)
+
+-- Update list xs at index n to have value f (xs!!n)
+-- Handles out of range indices
+	     
+update :: Int -> (a -> a) -> [a] -> [a]
+
+update n f xs = front ++ rear
+		where
+		(front,rest) = splitAt n xs
+		rear = case rest of
+			[]	-> []
+			(h:t)	-> f h:t
+			
+-- Update an array to have value x at position (n,m)			
+ 
+updateArray :: Int -> Int -> a -> [[a]] -> [[a]]
+
+updateArray n m x xss = update n (update m (const x)) xss
+
+-- Show play
+-- Assumes that the two arrays are of the same shape
+-- The second array gives the adjacency count of the cell,
+-- whilst the first indicates whether or not it is uncovered.
+
+
+showPlay :: [[Bool]] -> [[Bool]] -> [[Int]] -> String
+
+showPlay ess mss nss 
+           = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith4 f [0 .. length nss - 1] ess mss nss)
+	     where
+	     f n es ms ns 
+	       = pad 3 (show n) ++ concat (zipWith3 showCell es ms ns) ++ "\n"
+
+-- How to show the value in a particular cell.
+
+showCell :: Bool -> Bool -> Int -> String
+
+showCell showing marked n 
+	= if marked then "X"
+	     else if not showing then "."
+                 else if n==0 then " "
+		     else show n
+
+
+-- Play the game; pass in the number of mines
+-- and the (square) board size as initial arguments.
+
+playGame :: Int -> Int -> IO ()
+
+playGame mines size = 
+   playGameGrid grid count showing marked
+
+   where
+
+   grid      = randomGrid mines size size
+   count     = countConfig grid			
+   showing   = map (map (const False)) grid
+   marked    = map (map (const False)) grid
+   
+playGameGrid :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> IO ()
+
+playGameGrid grid count showing marked =
+     do { putStr (showPlay showing marked count) ;
+          choice <- getChar ;
+	  if choice=='q' 				-- quit
+	  then 
+	   do { putStr "\nquit" ; return () }
+	  else if not (elem choice "smurat")		-- ignore illegal
+	  then						-- choice
+	   do { putStr "\n" ; playGameGrid grid count showing marked }
+	  else 
+	   do {
+           rowCh <- getChar ;				-- get row
+	   let { row = fitRange size (fromEnum rowCh - fromEnum '0') } ; 
+	   colCh <- getChar ;				-- and column
+	   let { col = fitRange size (fromEnum colCh - fromEnum 'a') } ;
+	   putStr "\n" ;
+	   case choice of
+	    'm' -> playGameGrid grid count showing (updateArray row col True marked)
+	    'u' -> playGameGrid grid count showing (updateArray row col False marked)
+	    'r' -> if grid!!!(row,col) 
+	             then (do { putStr "LOST!" ; return () })
+	             else
+	                (playGameGrid grid count 
+			              (uncoverClosure count (row,col) showing)
+	                              marked)
+	    's' -> do { putStr $ showInfo count showing marked row col ; 
+	                putStr "---------\n" ;
+	                putStr $ showEquations $ fixSplit $
+			         getInfo count showing marked row col ;
+	                playGameGrid grid count showing marked }
+	    'a' -> let {eqs = fixSplit (getInfo count showing marked row col);
+	                (newShow,newMark) = playAutoOne grid count
+						showing marked row col}
+		   in do {
+	                putStr $ showEquations eqs ;
+			playGameGrid grid count newShow newMark }
+	    't' -> playAuto grid count showing marked [(row,col)]
+	       }
+	}
+	where size = length grid
+	
+-- Play one step automatically
+
+playAutoOne :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> 
+               Int -> Int -> ([[Bool]],[[Bool]])
+
+playAutoOne grid count showing marked row col
+ = let eqs = fixSplit (getInfo count showing marked row col)
+   in (updateShowByEqs eqs count showing,
+       updateMarkByEqs eqs marked)
+
+-- Play the game automatically from the information at point (n,m)
+-- Halts when no further progress made, and calls playGame.
+
+playAuto :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> [(Int,Int)] -> IO ()
+
+playAuto grid count showing marked []
+  = playGameGrid grid count showing marked
+playAuto grid count showing marked ((row,col):rest)
+ = let eqs = fixSplit (getInfo count showing marked row col)
+       (newShow,newMark) = playAutoOne grid count showing marked row col
+       newPts = makeNeg eqs ++ makePos eqs
+   in if (showing,marked)==(newShow,newMark) 
+   then playAuto grid count showing marked rest
+   else 
+   do { putStr $ showEquations eqs ;
+        putStr (showPlay showing marked count) ;
+	playAuto grid count newShow newMark (nub(newPts++rest)) }
+
+
+-- Finding the closure of a point / set of points.
+-- The worker functions: doClosure, doClosureList, carry around a 
+-- list of points already visited.
+
+closure :: [[Int]] -> (Int,Int) -> [(Int,Int)]
+
+closure count point = doClosure count point []
+
+-- doClosure, doClosureList use a variant of the algorithm 
+-- on pp333-4 of craft2e.
+
+doClosure :: [[Int]] -> (Int,Int) -> [(Int,Int)] -> [(Int,Int)]
+
+doClosure count point avoid
+  | count!!!point /= 0	= [point]
+  | otherwise	
+    = point : doClosureList count nbs (point:avoid)
+      where
+      nbs = nbhrs count point
+
+doClosureList :: [[Int]] -> [(Int,Int)] -> [(Int,Int)] -> [(Int,Int)]
+
+doClosureList count [] avoid = []
+
+doClosureList count (point: points) avoid
+  = next ++ doClosureList count points (avoid ++ next)
+    where
+    next = if elem point avoid
+           then [point]
+	   else doClosure count point avoid
+
+-- Uncover all the points in the closure
+
+uncoverClosure :: [[Int]] -> (Int,Int) -> [[Bool]] -> [[Bool]]
+
+uncoverClosure count point 
+  = foldr (.) id $ 
+    map ((flip.uncurry) updateArray True) (closure count point)
+
+-- What are the neighbours of a point?
+
+nbhrs :: [[Int]] -> (Int,Int) -> [(Int,Int)]
+
+nbhrs count (p,q)
+  = filter inGrid [ (p-1,q-1), (p-1,q), (p-1,q+1),
+                    (p,q-1),   (p,q),   (p,q+1),
+		    (p+1,q-1), (p+1,q), (p+1,q+1) ]
+    where
+    inGrid (s,t) = 0<=s && s <= rows &&
+                   0<=t && t <= cols
+    rows = length count - 1
+    cols = length (head count) -1
+
+-- Push an integer value into the range 
+--	0 .. r-1
+
+fitRange :: Int -> Int -> Int
+
+fitRange r val
+  | 0<=val && val<r	= val
+  | val<0		= 0
+  | val>=r 		= r-1
+
+-- Array lookup operation
+
+(!!!) :: [[a]] -> (Int,Int) -> a
+
+xss!!!(p,q) = xss!!p!!q
+
+-- Showing the information about a given cell,
+-- in the context of certain known information:
+--	count showing marked
+-- Produces an equation corresponding to each neighbour
+-- which has its value showing.
+-- Count zero for showing zeroes and 1 for marked cells
+-- i.e. assumes that markings are correct.
+
+-- Refactored as getInfoCell below ....
+
+getInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> Equations
+
+getInfo count showing marked row col
+  = map (uncurry (getInfoCell count showing marked))
+        [ point | point <- nbhrs count (row,col) , showing!!!point ]
+
+showInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> String
+
+showInfo count showing marked row col 
+  = showEquations (getInfo count showing marked row col)
+			  
+type Equations = [Equation]
+type Equation  = (Int, [(Int,Int)])
+
+-- Initial program for the information extracts it and immediately
+-- shows it. Subsequently refactored to produce a data structure
+-- containing the information, and a corresponding show function over
+-- the data structure.
+
+-- Call this separate producer and consumer ... allows whatever is
+-- produced to be used in more than one way.
+-- Can envisage the converse too: merging producer and consumer,
+-- particularly if there's only one use of the producer in the program.
+
+getInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> Equation 
+
+getInfoCell count showing marked s t 
+  = ( (count!!!(s,t) - marks) , 
+      [ point | point <- nbrs, not (showing!!!point), 
+    			       not (marked!!!point) ]
+    )
+    where 
+    nbrs              = nbhrs count (s,t)
+    marks             = sum [ 1 | point<-nbrs , marked!!!point ]
+
+-- Showing the information in a cell
+    
+showInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Int -> Int -> String 
+
+showInfoCell count showing marked s t 
+  = showEquation (getInfoCell count showing marked s t)
+
+showEquations = concat . (map showEquation)
+
+showEquation :: Equation -> String
+
+showEquation (lhs, rhs) 
+  = show lhs ++ " = " ++ showPoints rhs ++ "\n"
+
+showRow :: Int -> String
+showRow           = show
+
+showCol :: Int -> String
+showCol t         = [ toEnum (t + fromEnum 'a') ]
+
+showPoint :: (Int,Int) -> String
+showPoint (p,q)   = showRow p ++ showCol q
+
+showPoints :: [(Int,Int)] -> String
+showPoints []     = "none"
+showPoints [p]    = showPoint p
+showPoints (p:ps) = showPoint p ++ " + " ++ showPoints ps
+
+-- Reducing a list of equations to a normal form
+
+-- Is one list a sublist of the other?
+-- It is assumed that the elements appear in the same order, 
+-- without repetitions.
+
+subList :: Eq a => [a] -> [a] -> Bool
+
+subList [] _     = True
+subList (_:_) [] = False
+subList (x:xs) (y:ys)
+  | x==y	= subList xs ys
+  | otherwise	= subList (x:xs) ys
+
+-- The difference of two lists;
+-- only applied when the first is a subList of the second.
+
+listDiff :: Eq a => [a] -> [a] -> [a]
+
+listDiff [] ys	= ys
+listDiff (_:_) [] = error "listDiff applied to non-subList"
+listDiff (x:xs) (y:ys) 
+  | x==y	= listDiff xs ys
+  | otherwise	= y : listDiff (x:xs) ys
+
+-- Only splits when the first rhs is a sublist of the second
+-- and a proper sublist at that.
+
+splitEq :: Equation -> Equation -> Equation
+
+splitEq e1@(l1,r1) e2@(l2,r2)
+  | e1==e2		= e2
+  | subList r1 r2	= (l2-l1 , listDiff r1 r2)
+  | otherwise		= e2
+
+
+-- Split a set (list) of equations
+
+splitEqs :: [Equation] -> [Equation]
+
+splitEqs eqs
+  = foldr (.) id (map map (map splitEq eqs)) eqs
+
+-- Generic fixpt operator
+
+fixpt :: Eq a => (a -> a) -> a -> a
+
+fixpt f x
+  = g x
+    where
+    g y
+  	| y==next	= y
+  	| otherwise	= g next
+    	  where
+	  next = f y
+
+fixSplit :: [Equation] -> [Equation]
+
+fixSplit = fixpt (nub.splitEqs)
+
+-- Added in Minesweeper3 ...
+
+-- Is an equation determinate?
+-- Could be determinate in setting all values to
+-- zero (deterNeg) or to one (deterPos)
+
+determined :: Equation -> Bool
+
+determined eq
+  = deterPos eq || deterNeg eq
+  
+deterPos,deterNeg :: Equation -> Bool
+
+deterPos (n,pts)
+  = n>0 && n==length pts
+
+deterNeg (n,pts) 
+  = n==0 && length pts > 0
+
+-- Find all the points to be made negative or positive
+-- from a set of Equations.
+
+makePos,makeNeg :: [Equation] -> [(Int,Int)]
+
+makeNeg = nub . concat . map snd . filter deterNeg
+makePos = nub . concat . map snd . filter deterPos
+
+-- Update a marking array according to the information 
+-- in a set of equations.
+
+updateMarkByEqs :: [Equation] -> [[Bool]] -> [[Bool]]
+
+updateMarkByEqs eqs marked
+  = updatePos marked
+    where
+    updatePos = foldr (.) id $ map updateP (makePos eqs)
+    updateP (n,m) = updateArray n m True 
+
+-- Update a showing array according to the info
+-- in a set of equations. In thie first version it
+-- failed to uncover the closure of the uncovered points.
+-- To do this, it has to be passed the grid count as well
+-- as the show matrix.
+
+updateShowByEqs :: [Equation] -> [[Int]] -> [[Bool]] -> [[Bool]]
+
+updateShowByEqs eqs count showing
+  = updateNeg showing
+    where
+    updateNeg = foldr (.) id $ map updateN (makeNeg eqs)
+    updateN (n,m) = uncoverClosure count (n,m)
+
+
+    

@@ -0,0 +1,542 @@+----------------------------------------------------------
+--							--
+--	Minesweeper4.hs					--
+--							--
+--	Simon Thompson					--
+--							--
+--      2002-2011                                       --
+--                                                      --
+----------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+
+
+-- NB: Requires pragma above for instance declaration of
+-- non-atomic type: 
+--	instance AddThree [Int] where ...
+
+-- Modifies Minesweeper3.hs, by refactoring two Ints to
+-- Int pairs. Notes below. Help option added.
+
+-- The board is represented by a list of lists. It is a
+-- global assumption that this is rectangular, that is all
+-- component lists have the same length.
+-- It is also assumed that counts are nonempty.
+
+-- REFACTOR
+-- Introduce a type of Points which are pairs of Int.
+--
+-- Modify functions which take curried points e.g.
+--	X -> Y -> Int -> Int -> ...
+-- to be uncurried
+--	X -> Y -> (Int,Int) -> ...
+--
+-- In most cases elements of type Point don't have to be
+-- a pair pattern any more, so (s,t) becomes point, say.
+--
+-- In the main loop adding a let definition of
+--   point = (row,col)
+-- changes the calls to the main functions.
+--
+-- Note also the interesting case in which there were 
+-- explict uses of uncurry, e.g.
+--  (flip.uncurry) updateArray
+-- which had to be recognised and dealt with.
+--
+-- Also need to deal with other type definitions containing (Int,Int)
+-- as a subtype.
+
+
+module Minesweeper4 where
+import MineRandom ( randomGrid )
+import Data.List ( (\\), zipWith4, nub )
+
+
+type Config = [[Bool]]
+
+type Count  = [[Int]]
+
+type Point = (Int,Int)		-- added in Minesweeper4
+
+class AddThree a where
+  add3 :: a -> a -> a -> a
+  zero :: a
+  addOffset :: [a] -> [a]
+  addOffset = zipOffset3 add3 zero
+  
+instance AddThree Int where
+  add3 n m p = n+m+p
+  zero       = 0
+
+instance AddThree [Int] where
+  add3 = zipWith3 add3
+  zero = repeat zero
+
+-- Combine elementwise (i.e. zipWith3) the three lists:
+--
+--	 z,a0,a1,a2,...
+--	a0,a1,a2,...,an
+--      a1,a2,...,an,z
+--
+-- using the ternary function f
+-- Example: f is addition of three numbers, z is zero.
+
+zipOffset3 :: (a -> a -> a -> a) -> a -> [a] -> [a]
+
+zipOffset3 f z xs = zipWith3 f (z:xs) xs (tail xs ++ [z])
+
+-- From the grid of occupation (Boolean) calculate the
+-- number of occupied adjacent squares.
+-- Note that the stone in the square itself is also
+-- counted.
+
+countConfig :: [[Bool]] -> [[Int]]
+
+countConfig = addOffset . map addOffset . makeNumeric
+
+-- A variant of countConfig which doesn't count the stone in
+-- the square itself.
+
+countConfigLess :: [[Bool]] -> [[Int]]
+
+countConfigLess bs 
+  = zipWith (zipWith (-)) (countConfig bs) (makeNumeric bs)
+
+-- Boolean matrix to numeric matrix; True to 1, 
+-- False to 0.
+
+makeNumeric :: [[Bool]] -> [[Int]]
+
+makeNumeric = map (map (\b -> if b then 1 else 0))
+
+-- A 3*3 Boolean test matrix.
+
+test1 = [[True, False, True],[True,True,True],[False,True,True]]
+
+-- Printing the grid
+
+showGrid :: [[Int]] -> String
+
+showGrid nss = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith f [0 .. length nss - 1] nss)
+	     where
+	     f n ns = pad 3 (show n) ++ concat (map show ns) ++ "\n"
+
+pad :: Int -> String -> String
+
+pad n st
+  | len <= n		= st ++ replicate (n - len) ' ' 
+  | otherwise		= take n st
+    where
+    len = length st
+
+-- Strength of the product functor on the left
+
+appLeft :: (a -> b) -> (a,c) -> (b,c)
+
+appLeft f (x,y) = (f x , y)
+
+-- Update list xs at index n to have value f (xs!!n)
+-- Handles out of range indices
+	     
+update :: Int -> (a -> a) -> [a] -> [a]
+
+update n f xs = front ++ rear
+		where
+		(front,rest) = splitAt n xs
+		rear = case rest of
+			[]	-> []
+			(h:t)	-> f h:t
+			
+-- Update an array to have value x at position (n,m)			
+ 
+updateArray :: Point -> a -> [[a]] -> [[a]]
+
+updateArray (n,m) x xss = update n (update m (const x)) xss
+
+-- Show play
+-- Assumes that the two arrays are of the same shape
+-- The second array gives the adjacency count of the cell,
+-- whilst the first indicates whether or not it is uncovered.
+
+
+showPlay :: [[Bool]] -> [[Bool]] -> [[Int]] -> String
+
+showPlay ess mss nss 
+           = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith4 f [0 .. length nss - 1] ess mss nss)
+	     where
+	     f n es ms ns 
+	       = pad 3 (show n) ++ concat (zipWith3 showCell es ms ns) ++ "\n"
+
+-- How to show the value in a particular cell.
+
+showCell :: Bool -> Bool -> Int -> String
+
+showCell showing marked n 
+	= if marked then "X"
+	     else if not showing then "."
+                 else if n==0 then " "
+		     else show n
+
+
+-- Play the game; pass in the number of mines
+-- and the (square) board size as initial arguments.
+
+playGame :: Int -> Int -> IO ()
+
+playGame mines size = 
+   playGameGrid grid count showing marked
+
+   where
+
+   grid      = randomGrid mines size size
+   count     = countConfig grid			
+   showing   = map (map (const False)) grid
+   marked    = map (map (const False)) grid
+   
+playGameGrid :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> IO ()
+
+playGameGrid grid count showing marked =
+     do { putStr (showPlay showing marked count) ;
+          choice <- getChar ;
+	  if choice=='q' 				-- quit
+	  then 
+	   do { putStr "\nquit" ; return () }
+	  else if choice=='h'
+	  then
+	   do { putStr helpInfo ; playGameGrid grid count showing marked }
+	  else if not (elem choice "smurat")		-- ignore illegal
+	  then						-- choice
+	   do { putStr "\n" ; playGameGrid grid count showing marked }
+	  else 
+	   do {
+           rowCh <- getChar ;				-- get row
+	   let { row = fitRange size (fromEnum rowCh - fromEnum '0') } ; 
+	   colCh <- getChar ;				-- and column
+	   let { col = fitRange size (fromEnum colCh - fromEnum 'a') } ;
+	   let { point = (row,col) } ;
+	   putStr "\n" ;
+	   case choice of
+	    'm' -> playGameGrid grid count showing (updateArray point True marked)
+	    'u' -> playGameGrid grid count showing (updateArray point False marked)
+	    'r' -> if grid!!!point 
+	             then (do { putStr "LOST!" ; return () })
+	             else
+	                (playGameGrid grid count 
+			              (uncoverClosure count point showing)
+	                              marked)
+	    's' -> do { putStr $ showInfo count showing marked point ; 
+	                putStr "---------\n" ;
+	                putStr $ showEquations $ fixSplit $
+			         getInfo count showing marked point ;
+	                playGameGrid grid count showing marked }
+	    'a' -> let {eqs = fixSplit (getInfo count showing marked point);
+	                (newShow,newMark) = playAutoOne grid count
+						showing marked point}
+		   in do {
+	                putStr $ showEquations eqs ;
+			playGameGrid grid count newShow newMark }
+	    't' -> playAuto grid count showing marked [point]
+	       }
+	}
+	where size = length grid
+
+helpInfo :: String
+
+helpInfo
+  = "\n\n q\tQuit\n\
+    \ h\tHelp information\n\
+    \ m7b\tMark position 7b\n\
+    \ u7b\tUnmark position 7b\n\
+    \ r7b\tReveal position 7b\n\
+    \ s7b\tShow equations at 7b\n\
+    \ a7b\tAutomatic turn at 7b\n\
+    \ t7b\tTransitive automatic from 7b\n\n"
+	
+-- Play one step automatically
+
+playAutoOne :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> 
+               Point -> ([[Bool]],[[Bool]])
+
+playAutoOne grid count showing marked point
+ = let eqs = fixSplit (getInfo count showing marked point)
+   in (updateShowByEqs eqs count showing,
+       updateMarkByEqs eqs marked)
+
+-- Play the game automatically from the information at point (n,m)
+-- Halts when no further progress made, and calls playGame.
+
+playAuto :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> [Point] -> IO ()
+
+playAuto grid count showing marked []
+  = playGameGrid grid count showing marked
+playAuto grid count showing marked (point:rest)
+ = let eqs = fixSplit (getInfo count showing marked point)
+       (newShow,newMark) = playAutoOne grid count showing marked point
+       newPts = makeNeg eqs ++ makePos eqs
+   in if (showing,marked)==(newShow,newMark) 
+   then playAuto grid count showing marked rest
+   else 
+   do { putStr $ showEquations eqs ;
+        putStr (showPlay showing marked count) ;
+	playAuto grid count newShow newMark (nub(newPts++rest)) }
+
+
+-- Finding the closure of a point / set of points.
+-- The worker functions: doClosure, doClosureList, carry around a 
+-- list of points already visited.
+
+closure :: [[Int]] -> Point -> [Point]
+
+closure count point = doClosure count point []
+
+-- doClosure, doClosureList use a variant of the algorithm 
+-- on pp333-4 of craft2e.
+
+doClosure :: [[Int]] -> Point -> [Point] -> [Point]
+
+doClosure count point avoid
+  | count!!!point /= 0	= [point]
+  | otherwise	
+    = point : doClosureList count nbs (point:avoid)
+      where
+      nbs = nbhrs count point
+
+doClosureList :: [[Int]] -> [Point] -> [Point] -> [Point]
+
+doClosureList count [] avoid = []
+
+doClosureList count (point: points) avoid
+  = next ++ doClosureList count points (avoid ++ next)
+    where
+    next = if elem point avoid
+           then [point]
+	   else doClosure count point avoid
+
+-- Uncover all the points in the closure
+
+uncoverClosure :: [[Int]] -> Point -> [[Bool]] -> [[Bool]]
+
+uncoverClosure count point 
+  = foldr (.) id $ 
+    map (flip updateArray True) (closure count point)
+
+-- What are the neighbours of a point?
+
+nbhrs :: [[Int]] -> Point -> [Point]
+
+nbhrs count (p,q)
+  = filter inGrid [ (p-1,q-1), (p-1,q), (p-1,q+1),
+                    (p,q-1),   (p,q),   (p,q+1),
+		    (p+1,q-1), (p+1,q), (p+1,q+1) ]
+    where
+    inGrid (s,t) = 0<=s && s <= rows &&
+                   0<=t && t <= cols
+    rows = length count - 1
+    cols = length (head count) -1
+
+-- Push an integer value into the range 
+--	0 .. r-1
+
+fitRange :: Int -> Int -> Int
+
+fitRange r val
+  | 0<=val && val<r	= val
+  | val<0		= 0
+  | val>=r 		= r-1
+
+-- Array lookup operation
+
+(!!!) :: [[a]] -> Point -> a
+
+xss!!!(p,q) = xss!!p!!q
+
+-- Showing the information about a given cell,
+-- in the context of certain known information:
+--	count showing marked
+-- Produces an equation corresponding to each neighbour
+-- which has its value showing.
+-- Count zero for showing zeroes and 1 for marked cells
+-- i.e. assumes that markings are correct.
+
+-- Refactored as getInfoCell below ....
+
+getInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> Equations
+
+getInfo count showing marked point
+  = map (getInfoCell count showing marked)
+        [ nb | nb <- nbhrs count point , showing!!!nb ]
+
+showInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> String
+
+showInfo count showing marked point 
+  = showEquations (getInfo count showing marked point)
+			  
+type Equations = [Equation]
+type Equation  = (Int, [Point])
+
+-- Initial program for the information extracts it and immediately
+-- shows it. Subsequently refactored to produce a data structure
+-- containing the information, and a corresponding show function over
+-- the data structure.
+
+-- Call this separate producer and consumer ... allows whatever is
+-- produced to be used in more than one way.
+-- Can envisage the converse too: merging producer and consumer,
+-- particularly if there's only one use of the producer in the program.
+
+getInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> Equation 
+
+getInfoCell count showing marked point
+  = ( (count!!!point - marks) , 
+      [ nb | nb <- nbrs, not (showing!!!nb), not (marked!!!nb) ]
+    )
+    where 
+    nbrs              = nbhrs count point
+    marks             = sum [ 1 | nb<-nbrs , marked!!!nb ]
+
+-- Showing the information in a cell
+    
+showInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> String 
+
+showInfoCell count showing marked point
+  = showEquation (getInfoCell count showing marked point)
+
+showEquations :: Equations -> String
+
+showEquations = concat . (map showEquation)
+
+showEquation :: Equation -> String
+
+showEquation (lhs, rhs) 
+  = show lhs ++ " = " ++ showPoints rhs ++ "\n"
+
+showRow :: Int -> String
+showRow           = show
+
+showCol :: Int -> String
+showCol t         = [ toEnum (t + fromEnum 'a') ]
+
+showPoint :: Point -> String
+showPoint (p,q)   = showRow p ++ showCol q
+
+showPoints :: [Point] -> String
+showPoints []     = "none"
+showPoints [p]    = showPoint p
+showPoints (p:ps) = showPoint p ++ " + " ++ showPoints ps
+
+-- Reducing a list of equations to a normal form
+
+-- Is one list a sublist of the other?
+-- It is assumed that the elements appear in the same order, 
+-- without repetitions.
+
+subList :: Eq a => [a] -> [a] -> Bool
+
+subList [] _     = True
+subList (_:_) [] = False
+subList (x:xs) (y:ys)
+  | x==y	= subList xs ys
+  | otherwise	= subList (x:xs) ys
+
+-- The difference of two lists;
+-- only applied when the first is a subList of the second.
+
+listDiff :: Eq a => [a] -> [a] -> [a]
+
+listDiff [] ys	= ys
+listDiff (_:_) [] = error "listDiff applied to non-subList"
+listDiff (x:xs) (y:ys) 
+  | x==y	= listDiff xs ys
+  | otherwise	= y : listDiff (x:xs) ys
+
+-- Only splits when the first rhs is a sublist of the second
+-- and a proper sublist at that.
+
+splitEq :: Equation -> Equation -> Equation
+
+splitEq e1@(l1,r1) e2@(l2,r2)
+  | e1==e2		= e2
+  | subList r1 r2	= (l2-l1 , listDiff r1 r2)
+  | otherwise		= e2
+
+
+-- Split a set (list) of equations
+
+splitEqs :: [Equation] -> [Equation]
+
+splitEqs eqs
+  = foldr (.) id (map map (map splitEq eqs)) eqs
+
+-- Generic fixpt operator
+
+fixpt :: Eq a => (a -> a) -> a -> a
+
+fixpt f x
+  = g x
+    where
+    g y
+  	| y==next	= y
+  	| otherwise	= g next
+    	  where
+	  next = f y
+
+fixSplit :: [Equation] -> [Equation]
+
+fixSplit = fixpt (nub.splitEqs)
+
+-- Added in Minesweeper3 ...
+
+-- Is an equation determinate?
+-- Could be determinate in setting all values to
+-- zero (deterNeg) or to one (deterPos)
+
+determined :: Equation -> Bool
+
+determined eq
+  = deterPos eq || deterNeg eq
+  
+deterPos,deterNeg :: Equation -> Bool
+
+deterPos (n,pts)
+  = n>0 && n==length pts
+
+deterNeg (n,pts) 
+  = n==0 && length pts > 0
+
+-- Find all the points to be made negative or positive
+-- from a set of Equations.
+
+makePos,makeNeg :: [Equation] -> [Point]
+
+makeNeg = nub . concat . map snd . filter deterNeg
+makePos = nub . concat . map snd . filter deterPos
+
+-- Update a marking array according to the information 
+-- in a set of equations.
+
+updateMarkByEqs :: [Equation] -> [[Bool]] -> [[Bool]]
+
+updateMarkByEqs eqs marked
+  = updatePos marked
+    where
+    updatePos = foldr (.) id $ map updateP (makePos eqs)
+    updateP pt = updateArray pt True 
+
+-- Update a showing array according to the info
+-- in a set of equations. In thie first version it
+-- failed to uncover the closure of the uncovered points.
+-- To do this, it has to be passed the grid count as well
+-- as the show matrix.
+
+updateShowByEqs :: [Equation] -> [[Int]] -> [[Bool]] -> [[Bool]]
+
+updateShowByEqs eqs count showing
+  = updateNeg showing
+    where
+    updateNeg = foldr (.) id $ map updateN (makeNeg eqs)
+    updateN   = uncoverClosure count
+
+
+    

@@ -0,0 +1,563 @@+----------------------------------------------------------
+--							--
+--	Minesweeper5.hs					--
+--							--
+--	Simon Thompson					--
+--							--
+--      2002-2011                                       --
+--                                                      --
+----------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+
+
+-- NB: Requires pragma above for instance declaration of
+-- non-atomic type: 
+--	instance AddThree [Int] where ...
+
+-- Modifies Minesweeper3.hs, by refactoring two Ints to
+-- Int pairs. Notes below. Help option added.
+
+-- The board is represented by a list of lists. It is a
+-- global assumption that this is rectangular, that is all
+-- component lists have the same length.
+-- It is also assumed that counts are nonempty.
+
+-- REFACTOR 3->4
+-- Introduce a type of Points which are pairs of Int.
+--
+-- Modify functions which take curried points e.g.
+--	X -> Y -> Int -> Int -> ...
+-- to be uncurried
+--	X -> Y -> (Int,Int) -> ...
+--
+-- In most cases elements of type Point don't have to be
+-- a pair pattern any more, so (s,t) becomes point, say.
+--
+-- In the main loop adding a let definition of
+--   point = (row,col)
+-- changes the calls to the main functions.
+--
+-- Note also the interesting case in which there were 
+-- explict uses of uncurry, e.g.
+--  (flip.uncurry) updateArray
+-- which had to be recognised and dealt with.
+--
+-- Also need to deal with other type definitions containing (Int,Int)
+-- as a subtype.
+
+
+-- REFACTOR 4->5
+--
+-- A uniform procedure for getting input (getInput)
+-- and for handling it......
+
+
+module Minesweeper5 where
+import MineRandom ( randomGrid )
+import Data.List ( (\\), zipWith4, nub )
+
+
+type Config = [[Bool]]
+
+type Count  = [[Int]]
+
+type Point = (Int,Int)		-- added in Minesweeper4
+
+class AddThree a where
+  add3 :: a -> a -> a -> a
+  zero :: a
+  addOffset :: [a] -> [a]
+  addOffset = zipOffset3 add3 zero
+  
+instance AddThree Int where
+  add3 n m p = n+m+p
+  zero       = 0
+
+instance AddThree a => AddThree [a] where
+  add3 = zipWith3 add3
+  zero = repeat zero
+
+-- Combine elementwise (i.e. zipWith3) the three lists:
+--
+--	 z,a0,a1,a2,...
+--	a0,a1,a2,...,an
+--      a1,a2,...,an,z
+--
+-- using the ternary function f
+-- Example: f is addition of three numbers, z is zero.
+
+zipOffset3 :: (a -> a -> a -> a) -> a -> [a] -> [a]
+
+zipOffset3 f z xs = zipWith3 f (z:xs) xs (tail xs ++ [z])
+
+-- From the grid of occupation (Boolean) calculate the
+-- number of occupied adjacent squares.
+-- Note that the stone in the square itself is also
+-- counted.
+
+countConfig :: [[Bool]] -> [[Int]]
+
+countConfig = addOffset . map addOffset . makeNumeric
+
+-- A variant of countConfig which doesn't count the stone in
+-- the square itself.
+
+countConfigLess :: [[Bool]] -> [[Int]]
+
+countConfigLess bs 
+  = zipWith (zipWith (-)) (countConfig bs) (makeNumeric bs)
+
+-- Boolean matrix to numeric matrix; True to 1, 
+-- False to 0.
+
+makeNumeric :: [[Bool]] -> [[Int]]
+
+makeNumeric = map (map (\b -> if b then 1 else 0))
+
+-- A 3*3 Boolean test matrix.
+
+test1 = [[True, False, True],[True,True,True],[False,True,True]]
+
+-- Printing the grid
+
+showGrid :: [[Int]] -> String
+
+showGrid nss = "   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith f [0 .. length nss - 1] nss)
+	     where
+	     f n ns = pad 3 (show n) ++ concat (map show ns) ++ "\n"
+
+pad :: Int -> String -> String
+
+pad n st
+  | len <= n		= st ++ replicate (n - len) ' ' 
+  | otherwise		= take n st
+    where
+    len = length st
+
+-- Strength of the product functor on the left
+
+appLeft :: (a -> b) -> (a,c) -> (b,c)
+
+appLeft f (x,y) = (f x , y)
+
+-- Update list xs at index n to have value f (xs!!n)
+-- Handles out of range indices
+	     
+update :: Int -> (a -> a) -> [a] -> [a]
+
+update n f xs = front ++ rear
+		where
+		(front,rest) = splitAt n xs
+		rear = case rest of
+			[]	-> []
+			(h:t)	-> f h:t
+			
+-- Update an array to have value x at position (n,m)			
+ 
+updateArray :: Point -> a -> [[a]] -> [[a]]
+
+updateArray (n,m) x xss = update n (update m (const x)) xss
+
+-- Show play
+-- Assumes that the two arrays are of the same shape
+-- The second array gives the adjacency count of the cell,
+-- whilst the first indicates whether or not it is uncovered.
+
+
+showPlay :: [[Bool]] -> [[Bool]] -> [[Int]] -> String
+
+showPlay ess mss nss 
+           = "\n   " ++ take (length (head nss)) ['a' .. 'z'] ++ "\n" ++
+             concat (zipWith4 f [0 .. length nss - 1] ess mss nss) ++"\n"
+	     where
+	     f n es ms ns 
+	       = pad 3 (show n) ++ concat (zipWith3 showCell es ms ns) ++ "\n"
+
+-- How to show the value in a particular cell.
+
+showCell :: Bool -> Bool -> Int -> String
+
+showCell showing marked n 
+	= if marked then "X"
+	     else if not showing then "."
+                 else if n==0 then " "
+		     else show n
+
+
+-- Play the game; pass in the number of mines
+-- and the (square) board size as initial arguments.
+
+playGame :: Int -> Int -> IO ()
+
+playGame mines size = 
+   playGameGrid grid count showing marked
+
+   where
+
+   grid      = randomGrid mines size size
+   count     = countConfig grid			
+   showing   = map (map (const False)) grid
+   marked    = map (map (const False)) grid
+   
+playGameGrid :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> IO ()
+
+playGameGrid grid count showing marked =
+     do { putStr (showPlay showing marked count) ;
+          (choice,point) <- getInput size ;
+	  case choice of
+	    'q' -> return ()
+	    'h' -> do { putStr helpInfo ; playGameGrid grid count showing marked }
+	    'm' -> playGameGrid grid count showing (updateArray point True marked)
+	    'u' -> playGameGrid grid count showing (updateArray point False marked)
+	    'r' -> if grid!!!point 
+	             then (do { putStr "\nLOST!" ; return () })
+	             else
+	                (playGameGrid grid count 
+			              (uncoverClosure count point showing)
+	                              marked)
+	    's' -> let {eqs = getInfo count showing marked point;
+	                normEqs = fixSplit eqs }
+		   in do { putStr $ showEquations eqs ; 
+	                   putStr "---------\n" ;
+	                   putStr $ showEquations normEqs ;
+	                   playGameGrid grid count showing marked }
+	    'a' -> let {eqs = fixSplit (getInfo count showing marked point);
+	                (newShow,newMark) = playAutoOne grid count
+						showing marked point}
+		   in do {
+	                putStr $ showEquations eqs ;
+			playGameGrid grid count newShow newMark }
+	    't' -> playAuto grid count showing marked [point]
+	    _   -> playGameGrid grid count showing marked 
+	}
+	where size = length grid
+
+-- A uniform procedure for getting input, which gives
+-- a choice and a cell. 
+-- In the case that cell information is not required, i.e.
+-- 'help' or 'quit' a dummy point is returned.
+-- Parameterised by the size of the grid, so that the Point
+-- returned is quaranteed to be in the grid ... primitive
+-- error correction.
+
+getInput :: Int -> IO (Char,Point)
+
+getInput size =
+  do {    choice <- getChar ;
+	  if elem choice "smurat"	-- need to get (row,col)
+	  then 
+	   do {
+           rowCh <- getChar ;				-- get row
+	   colCh <- getChar ;				-- and column
+	   let { row = fitRange size (fromEnum rowCh - fromEnum '0') } ; 
+	   let { col = fitRange size (fromEnum colCh - fromEnum 'a') } ;
+	   let { point = (row,col) } ;
+	   return (choice,point)
+	      }
+	  else 				-- dummy values for (row,col) 
+	  do {
+	   let { dummy = (0,0) } ;
+	   return (choice,dummy)
+	      }
+     }
+
+helpInfo :: String
+
+helpInfo
+  = "\n\n q\tQuit\n\
+    \ h\tHelp information\n\
+    \ m7b\tMark position 7b\n\
+    \ u7b\tUnmark position 7b\n\
+    \ r7b\tReveal position 7b\n\
+    \ s7b\tShow equations at 7b\n\
+    \ a7b\tAutomatic turn at 7b\n\
+    \ t7b\tTransitive automatic from 7b\n\n"
+	
+-- Play one step automatically
+
+playAutoOne :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> 
+               Point -> ([[Bool]],[[Bool]])
+
+playAutoOne grid count showing marked point
+ = let eqs = fixSplit (getInfo count showing marked point)
+   in (updateShowByEqs eqs count showing,
+       updateMarkByEqs eqs marked)
+
+-- Play the game automatically from the information at point (n,m)
+-- Halts when no further progress made, and calls playGame.
+
+playAuto :: [[Bool]] -> [[Int]] -> [[Bool]] -> [[Bool]] -> [Point] -> IO ()
+
+playAuto grid count showing marked []
+  = playGameGrid grid count showing marked
+playAuto grid count showing marked (point:rest)
+ = let eqs = fixSplit (getInfo count showing marked point)
+       (newShow,newMark) = playAutoOne grid count showing marked point
+       newPts = makeNeg eqs ++ makePos eqs
+   in if (showing,marked)==(newShow,newMark) 
+   then playAuto grid count showing marked rest
+   else 
+   do { putStr $ showEquations eqs ;
+        putStr (showPlay showing marked count) ;
+	playAuto grid count newShow newMark (nub(newPts++rest)) }
+
+
+-- Finding the closure of a point / set of points.
+-- The worker functions: doClosure, doClosureList, carry around a 
+-- list of points already visited.
+
+closure :: [[Int]] -> Point -> [Point]
+
+closure count point = doClosure count point []
+
+-- doClosure, doClosureList use a variant of the algorithm 
+-- on pp333-4 of craft2e.
+
+doClosure :: [[Int]] -> Point -> [Point] -> [Point]
+
+doClosure count point avoid
+  | count!!!point /= 0	= [point]
+  | otherwise	
+    = point : doClosureList count nbs (point:avoid)
+      where
+      nbs = nbhrs count point
+
+doClosureList :: [[Int]] -> [Point] -> [Point] -> [Point]
+
+doClosureList count [] avoid = []
+
+doClosureList count (point: points) avoid
+  = next ++ doClosureList count points (avoid ++ next)
+    where
+    next = if elem point avoid
+           then [point]
+	   else doClosure count point avoid
+
+-- Uncover all the points in the closure
+
+uncoverClosure :: [[Int]] -> Point -> [[Bool]] -> [[Bool]]
+
+uncoverClosure count point 
+  = foldr (.) id $ 
+    map (flip updateArray True) (closure count point)
+
+-- What are the neighbours of a point?
+
+nbhrs :: [[Int]] -> Point -> [Point]
+
+nbhrs count (p,q)
+  = filter inGrid [ (p-1,q-1), (p-1,q), (p-1,q+1),
+                    (p,q-1),   (p,q),   (p,q+1),
+		    (p+1,q-1), (p+1,q), (p+1,q+1) ]
+    where
+    inGrid (s,t) = 0<=s && s <= rows &&
+                   0<=t && t <= cols
+    rows = length count - 1
+    cols = length (head count) -1
+
+-- Push an integer value into the range 
+--	0 .. r-1
+
+fitRange :: Int -> Int -> Int
+
+fitRange r val
+  | 0<=val && val<r	= val
+  | val<0		= 0
+  | val>=r 		= r-1
+
+-- Array lookup operation
+
+(!!!) :: [[a]] -> Point -> a
+
+xss!!!(p,q) = xss!!p!!q
+
+-- Showing the information about a given cell,
+-- in the context of certain known information:
+--	count showing marked
+-- Produces an equation corresponding to each neighbour
+-- which has its value showing.
+-- Count zero for showing zeroes and 1 for marked cells
+-- i.e. assumes that markings are correct.
+
+-- Refactored as getInfoCell below ....
+
+getInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> Equations
+
+getInfo count showing marked point
+  = map (getInfoCell count showing marked)
+        [ nb | nb <- nbhrs count point , showing!!!nb ]
+
+showInfo :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> String
+
+showInfo count showing marked point 
+  = showEquations (getInfo count showing marked point)
+			  
+type Equations = [Equation]
+type Equation  = (Int, [Point])
+
+-- Initial program for the information extracts it and immediately
+-- shows it. Subsequently refactored to produce a data structure
+-- containing the information, and a corresponding show function over
+-- the data structure.
+
+-- Call this separate producer and consumer ... allows whatever is
+-- produced to be used in more than one way.
+-- Can envisage the converse too: merging producer and consumer,
+-- particularly if there's only one use of the producer in the program.
+
+getInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> Equation 
+
+getInfoCell count showing marked point
+  = ( (count!!!point - marks) , 
+      [ nb | nb <- nbrs, not (showing!!!nb), not (marked!!!nb) ]
+    )
+    where 
+    nbrs              = nbhrs count point
+    marks             = sum [ 1 | nb<-nbrs , marked!!!nb ]
+
+-- Showing the information in a cell
+    
+showInfoCell :: [[Int]] -> [[Bool]] -> [[Bool]] -> Point -> String 
+
+showInfoCell count showing marked point
+  = showEquation (getInfoCell count showing marked point)
+
+showEquations :: Equations -> String
+
+showEquations = ("\n"++) . concat . (map showEquation)
+
+showEquation :: Equation -> String
+
+showEquation (lhs, rhs) 
+  = show lhs ++ " = " ++ showPoints rhs ++ "\n"
+
+showRow :: Int -> String
+showRow           = show
+
+showCol :: Int -> String
+showCol t         = [ toEnum (t + fromEnum 'a') ]
+
+showPoint :: Point -> String
+showPoint (p,q)   = showRow p ++ showCol q
+
+showPoints :: [Point] -> String
+showPoints []     = "none"
+showPoints [p]    = showPoint p
+showPoints (p:ps) = showPoint p ++ " + " ++ showPoints ps
+
+-- Reducing a list of equations to a normal form
+
+-- Is one list a sublist of the other?
+-- It is assumed that the elements appear in the same order, 
+-- without repetitions.
+
+subList :: Eq a => [a] -> [a] -> Bool
+
+subList [] _     = True
+subList (_:_) [] = False
+subList (x:xs) (y:ys)
+  | x==y	= subList xs ys
+  | otherwise	= subList (x:xs) ys
+
+-- The difference of two lists;
+-- only applied when the first is a subList of the second.
+
+listDiff :: Eq a => [a] -> [a] -> [a]
+
+listDiff [] ys	= ys
+listDiff (_:_) [] = error "listDiff applied to non-subList"
+listDiff (x:xs) (y:ys) 
+  | x==y	= listDiff xs ys
+  | otherwise	= y : listDiff (x:xs) ys
+
+-- Only splits when the first rhs is a sublist of the second
+-- and a proper sublist at that.
+
+splitEq :: Equation -> Equation -> Equation
+
+splitEq e1@(l1,r1) e2@(l2,r2)
+  | e1==e2		= e2
+  | subList r1 r2	= (l2-l1 , listDiff r1 r2)
+  | otherwise		= e2
+
+
+-- Split a set (list) of equations
+
+splitEqs :: [Equation] -> [Equation]
+
+splitEqs eqs
+  = foldr (.) id (map map (map splitEq eqs)) eqs
+
+-- Generic fixpt operator
+
+fixpt :: Eq a => (a -> a) -> a -> a
+
+fixpt f x
+  = g x
+    where
+    g y
+  	| y==next	= y
+  	| otherwise	= g next
+    	  where
+	  next = f y
+
+fixSplit :: [Equation] -> [Equation]
+
+fixSplit = fixpt (nub.splitEqs)
+
+-- Added in Minesweeper3 ...
+
+-- Is an equation determinate?
+-- Could be determinate in setting all values to
+-- zero (deterNeg) or to one (deterPos)
+
+determined :: Equation -> Bool
+
+determined eq
+  = deterPos eq || deterNeg eq
+  
+deterPos,deterNeg :: Equation -> Bool
+
+deterPos (n,pts)
+  = n>0 && n==length pts
+
+deterNeg (n,pts) 
+  = n==0 && length pts > 0
+
+-- Find all the points to be made negative or positive
+-- from a set of Equations.
+
+makePos,makeNeg :: [Equation] -> [Point]
+
+makeNeg = nub . concat . map snd . filter deterNeg
+makePos = nub . concat . map snd . filter deterPos
+
+-- Update a marking array according to the information 
+-- in a set of equations.
+
+updateMarkByEqs :: [Equation] -> [[Bool]] -> [[Bool]]
+
+updateMarkByEqs eqs marked
+  = updatePos marked
+    where
+    updatePos = foldr (.) id $ map updateP (makePos eqs)
+    updateP pt = updateArray pt True 
+
+-- Update a showing array according to the info
+-- in a set of equations. In the first version it
+-- failed to uncover the closure of the uncovered points.
+-- To do this, it has to be passed the grid count as well
+-- as the show matrix.
+
+updateShowByEqs :: [Equation] -> [[Int]] -> [[Bool]] -> [[Bool]]
+
+updateShowByEqs eqs count showing
+  = updateNeg showing
+    where
+    updateNeg = foldr (.) id $ map updateN (makeNeg eqs)
+    updateN   = uncoverClosure count
+
+
+    

@@ -0,0 +1,55 @@++------------------------------------------------------------------+--								--+--	Solution to the palindrome problem			--+--								--+--	(c) Simon Thompson, University of Kent, 1997-2011       --+--                                                              --+------------------------------------------------------------------++module Palin where++import Data.Char++palin :: String -> Bool++palin st = simplePalin (disregard st)++simplePalin :: String -> Bool++simplePalin st = (rev st == st)++rev :: String -> String++rev []	   = []+rev (a:st) = rev st ++ [a]++disregard :: String -> String++disregard = change . remove++remove :: String -> String+change :: String -> String++remove []	= []+remove (a:st) +  | notPunct a  = a : remove st   +  | otherwise   =     remove st	++notPunct ch = isAlpha ch || isDigit ch++change []	= []+change (a:st) = convert a : change st++convert :: Char -> Char++convert ch +  | isCap ch      = toEnum (fromEnum ch + offset)+  | otherwise     = ch+    where+    offset = fromEnum 'a' - fromEnum 'A'++isCap :: Char -> Bool++isCap ch = 'A' <= ch && ch <= 'Z'+

@@ -1,78 +0,0 @@-module Test where  --import PicturesSVG-    -ex :: Integer-ex = 3+4--double :: Integer -> Integer-double x = 2*x--trip :: Integer -> Integer-trip y = 3*y--pic1 :: Picture-pic1 = horse `beside` flipV (invert horse)--pic2 :: Picture-pic2 = pic1 `above` invert pic1--howManyEqual :: Integer -> Integer -> Integer -> Integer--howManyEqual x y z -  | x==y && y==z            = 3-  | x==y || y==z || z==x    = 2-  | otherwise               = 0---(^^^) :: Integer -> Integer -> Integer-x ^^^ y -    | x>= y      = x-    | otherwise  = y--fac :: Integer -> Integer--fac 0               = 1-fac n -    | n>0           = n * fac (n-1)-    | otherwise     = 0----maxThreeOccurs :: Integer -> Integer -> Integer -> (Integer,Integer)--maxThreeOccurs x y z =-  (theMax,occurs)-  where-    theMax = max (max x y) z-    occurs = eq x + eq y + eq z-    eq w = if w==theMax then 1 else 0--pow :: Integer -> Integer--pow n -  | n==0      = 1-  | n>0       = 2 * pow (n-1) -  | otherwise = 0      --sumFun :: (Integer -> Integer) -> Integer -> Integer-  -sumFun f n -  | n==0      = f 0-  | n>0       = sumFun f (n-1) + f n-  | otherwise = 0  ---fibP :: Integer -> (Integer,Integer)--fibP 0 = (0,1)-fibP n = (v,u+v)-         where-         (u,v) = fibP (n-1)---fib :: Integer -> Integer--fib 0 = 0-fib 1 = 1-fib n = fib (n-2) + fib (n-1)

@@ -7,7 +7,7 @@    <image x="0" y="0" width="150" height="200" xlink:href="blk_horse_head.jpg"/> -  <image x="150" y="0" width="150" height="200" xlink:href="blk_horse_head.jpg" transform="translate(450,0) scale(-1,1)"  filter="url(#negative)"/>+  <image x="150" y="0" width="150" height="200" xlink:href="blk_horse_head.jpg" transform="translate(450,0) scale(-1,1)" />  </svg>