diff --git a/Chapter18.hs b/Chapter18.hs --- a/Chapter18.hs +++ b/Chapter18.hs @@ -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)) - diff --git a/Chapter19.hs b/Chapter19.hs new file mode 100644 --- /dev/null +++ b/Chapter19.hs @@ -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)) diff --git a/Chapter19/ParseLib.hs b/Chapter19/ParseLib.hs deleted file mode 100644 --- a/Chapter19/ParseLib.hs +++ /dev/null @@ -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 - - diff --git a/Chapter19/Pic.hs b/Chapter19/Pic.hs deleted file mode 100644 --- a/Chapter19/Pic.hs +++ /dev/null @@ -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)) - diff --git a/Chapter19/Pictures.hs b/Chapter19/Pictures.hs deleted file mode 100644 --- a/Chapter19/Pictures.hs +++ /dev/null @@ -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 diff --git a/Chapter19/QC.hs b/Chapter19/QC.hs deleted file mode 100644 --- a/Chapter19/QC.hs +++ /dev/null @@ -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 - diff --git a/Chapter19/QCfuns.hs b/Chapter19/QCfuns.hs deleted file mode 100644 --- a/Chapter19/QCfuns.hs +++ /dev/null @@ -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 diff --git a/Chapter19/RegExp.hs b/Chapter19/RegExp.hs deleted file mode 100644 --- a/Chapter19/RegExp.hs +++ /dev/null @@ -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 diff --git a/Chapter20/Chapter20.hs b/Chapter20/Chapter20.hs deleted file mode 100644 --- a/Chapter20/Chapter20.hs +++ /dev/null @@ -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)) - - diff --git a/Chapter20/PerformanceI.hs b/Chapter20/PerformanceI.hs deleted file mode 100644 --- a/Chapter20/PerformanceI.hs +++ /dev/null @@ -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) diff --git a/Chapter20/PerformanceIA.hs b/Chapter20/PerformanceIA.hs deleted file mode 100644 --- a/Chapter20/PerformanceIA.hs +++ /dev/null @@ -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) diff --git a/Chapter20/PerformanceIS.hs b/Chapter20/PerformanceIS.hs deleted file mode 100644 --- a/Chapter20/PerformanceIS.hs +++ /dev/null @@ -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) diff --git a/Chapter20/Pic.hs b/Chapter20/Pic.hs new file mode 100644 --- /dev/null +++ b/Chapter20/Pic.hs @@ -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)) + diff --git a/Chapter20/Pictures.hs b/Chapter20/Pictures.hs new file mode 100644 --- /dev/null +++ b/Chapter20/Pictures.hs @@ -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 diff --git a/Chapter20/QC.hs b/Chapter20/QC.hs new file mode 100644 --- /dev/null +++ b/Chapter20/QC.hs @@ -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 + diff --git a/Chapter20/QCfuns.hs b/Chapter20/QCfuns.hs new file mode 100644 --- /dev/null +++ b/Chapter20/QCfuns.hs @@ -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 diff --git a/Chapter20/RegExp.hs b/Chapter20/RegExp.hs new file mode 100644 --- /dev/null +++ b/Chapter20/RegExp.hs @@ -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 diff --git a/Chapter21/Chapter21.hs b/Chapter21/Chapter21.hs new file mode 100644 --- /dev/null +++ b/Chapter21/Chapter21.hs @@ -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)) + + diff --git a/Chapter21/PerformanceI.hs b/Chapter21/PerformanceI.hs new file mode 100644 --- /dev/null +++ b/Chapter21/PerformanceI.hs @@ -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) diff --git a/Chapter21/PerformanceIA.hs b/Chapter21/PerformanceIA.hs new file mode 100644 --- /dev/null +++ b/Chapter21/PerformanceIA.hs @@ -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) diff --git a/Chapter21/PerformanceIS.hs b/Chapter21/PerformanceIS.hs new file mode 100644 --- /dev/null +++ b/Chapter21/PerformanceIS.hs @@ -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) diff --git a/Craft3e.cabal b/Craft3e.cabal --- a/Craft3e.cabal +++ b/Craft3e.cabal @@ -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 diff --git a/Minesweeper/MineRandom.hs b/Minesweeper/MineRandom.hs new file mode 100644 --- /dev/null +++ b/Minesweeper/MineRandom.hs @@ -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 diff --git a/Minesweeper/Minesweeper.hs b/Minesweeper/Minesweeper.hs new file mode 100644 --- /dev/null +++ b/Minesweeper/Minesweeper.hs @@ -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 + diff --git a/Minesweeper/Minesweeper2.hs b/Minesweeper/Minesweeper2.hs new file mode 100644 --- /dev/null +++ b/Minesweeper/Minesweeper2.hs @@ -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 = 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) + + diff --git a/Minesweeper/Minesweeper3.hs b/Minesweeper/Minesweeper3.hs new file mode 100644 --- /dev/null +++ b/Minesweeper/Minesweeper3.hs @@ -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 = 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) + + + diff --git a/Minesweeper/Minesweeper4.hs b/Minesweeper/Minesweeper4.hs new file mode 100644 --- /dev/null +++ b/Minesweeper/Minesweeper4.hs @@ -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 = 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 + + + diff --git a/Minesweeper/Minesweeper5.hs b/Minesweeper/Minesweeper5.hs new file mode 100644 --- /dev/null +++ b/Minesweeper/Minesweeper5.hs @@ -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 = 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 + + + diff --git a/Palindromes/Palin.hs b/Palindromes/Palin.hs new file mode 100644 --- /dev/null +++ b/Palindromes/Palin.hs @@ -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' + diff --git a/Test.hs b/Test.hs deleted file mode 100644 --- a/Test.hs +++ /dev/null @@ -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) diff --git a/svgOut.xml b/svgOut.xml --- a/svgOut.xml +++ b/svgOut.xml @@ -7,7 +7,7 @@ - +