Craft3e 0.1.0.3 → 0.1.0.4

raw patch · 45 files changed

+2349/−45 lines, 45 filesdep ~mtlbinary-added

Dependency ranges changed: mtl

Files

• ._Calculator binary
• ._Chapter15 binary
• ._Chapter16 binary
• ._Craft3e.cabal binary
• ._IO binary
• ._LICENSE binary
• ._README.txt binary
• ._Simulation binary
• ._blk_horse_head.jpg binary
• Calculator/.DS_Store binary
• Calculator/._.DS_Store binary
• Chapter14_1.hs +11/−8
• Chapter14_2.hs +1/−1
• Chapter15/.DS_Store binary
• Chapter15/._.DS_Store binary
• Chapter15/Solutions15.hs +212/−0
• Chapter16/.DS_Store binary
• Chapter16/._.DS_Store binary
• Chapter16/Solutions16.hs +474/−0
• Chapter16/Tree.hs +12/−1
• Chapter19/ParseLib.hs +132/−0
• Chapter19/Pic.hs +63/−0
• Chapter19/Pictures.hs +256/−0
• Chapter19/PositionedImages.hs +258/−0
• Chapter19/QCfuns.hs +37/−0
• Chapter19/RegExp.hs +1/−13
• Chapter19/Solutions19.hs +227/−0
• Chapter2.hs +1/−1
• Chapter8.hs +1/−1
• Craft3e.cabal +3/−3
• IO/.DS_Store binary
• IO/._.DS_Store binary
• IO/DoTest.hs +49/−0
• IO/MonadIO.hs +171/−0
• IO/TreeId.hs +55/−0
• IO/TreeState.hs +99/−0
• LISTING +177/−0
• ParseLib.hs +2/−0
• RPS.hs +1/−1
• Relation.hs +4/−4
• Set.hs +4/−11
• Simulation/.DS_Store binary
• Simulation/._.DS_Store binary
• Simulation/QueueState.hs +6/−1
• UsePictures.hs +92/−0

binary file changed (absent → 229 bytes)

binary file changed (absent → 229 bytes)

binary file changed (absent → 229 bytes)

binary file changed (absent → 356 bytes)

binary file changed (absent → 229 bytes)

binary file changed (absent → 167 bytes)

binary file changed (absent → 171 bytes)

binary file changed (absent → 229 bytes)

binary file changed (absent → 263 bytes)

binary file changed (absent → 6148 bytes)

binary file changed (absent → 82 bytes)

@@ -28,7 +28,10 @@ -- Two enumerated types  data Temp   = Cold | Hot+              deriving (Show)+ data Season = Spring | Summer | Autumn | Winter+              deriving (Show,Eq,Enum)  -- A function over Season, defined using pattern matching. @@ -94,29 +97,29 @@ -- The type definition.  data NTree = NilT |-             NodeT Integer NTree NTree+             Node Integer NTree NTree                    deriving (Show,Eq,Read,Ord) -- Example trees -treeEx1 = NodeT 10 NilT NilT-treeEx2 = NodeT 17 (NodeT 14 NilT NilT) (NodeT 20 NilT NilT)+treeEx1 = Node 10 NilT NilT+treeEx2 = Node 17 (Node 14 NilT NilT) (Node 20 NilT NilT)  -- Definitions of many functions are primitive recursive. For instance,  sumTree,depth :: NTree -> Integer  sumTree NilT            = 0-sumTree (NodeT n t1 t2) = n + sumTree t1 + sumTree t2+sumTree (Node n t1 t2) = n + sumTree t1 + sumTree t2  depth NilT             = 0-depth (NodeT n t1 t2)  = 1 + max (depth t1) (depth t2)+depth (Node n t1 t2)  = 1 + max (depth t1) (depth t2)  -- How many times does an integer occur in a tree?  occurs :: NTree -> Integer -> Integer  occurs NilT p = 0-occurs (NodeT n t1 t2) p+occurs (Node n t1 t2) p   | n==p        = 1 + occurs t1 p + occurs t2 p   | otherwise   =     occurs t1 p + occurs t2 p @@ -203,7 +206,7 @@ arbNTree n     | n>0         = frequency[(1, return NilT),-                    (3, liftM3 NodeT arbitrary bush bush)]+                    (3, liftM3 Node arbitrary bush bush)]           where             bush = arbNTree (div n 2) @@ -234,4 +237,4 @@ size :: NTree -> Integer  size NilT             = 0-size (NodeT n t1 t2)  = 1 + (size t1) + (depth t2)+size (Node n t1 t2)  = 1 + (size t1) + (depth t2)

@@ -12,7 +12,7 @@ module Chapter14_2 where  import Prelude hiding (Either(..),either,Maybe(..),maybe)-import Chapter14_1 hiding (Name)+import Chapter14_1 hiding (Name,NTree(..)) import Test.QuickCheck import Control.Monad 

binary file changed (absent → 6148 bytes)

binary file changed (absent → 82 bytes)

@@ -0,0 +1,212 @@+------------------------------------------------------------------------------+--+-- 	Haskell: The Craft of Functional Programming+-- 	Simon Thompson+-- 	(c) Addison-Wesley, 2011.+-- +-- 	Solutions15+--+------------------------------------------------------------------------------++module Solutions15 where++import Types++--+-- Solution 15.1+--++-- It is always possible to limit what is imported from a particular+-- module through import controls, but that doesn't prevent a client of +-- the imported module importing anything from the client, if no export+-- controls are in place.++-- On the other hand, export controls are needed for re-export of imported+-- definitions, which are not re-exported by default.++-- Export controls have an annoying limitation: it's not possible to hide+-- particular bindings explicitly on export, rather have to have a whole export+-- list which excludes the binding(s) in question, but which has to include+-- everything else.++--+-- Solution 15.2+--++-- It's the right default: can always re-export, but if everything re-exported a+-- automatically it's harder to look at a module and see where the definitions it +-- uses come from. As it stands, a definition will be in one of the modules included,+-- or explicitly re-exported from one of those.++-- Also auto re-export would possibly pollute the name space with bindings we don't+-- want to be aware of.++--+-- Solution 15.3+--++-- More brevity. Why not? Could have to check consistency: what if we say "no Dog"+-- but something imported from Dog is explicitly exported?++--+-- Solution 15.4+--++-- LRLRRRRRLRR++--+-- Solution 15.5+--++-- babbat++-- would expect that the shortest is with b coded by a single letter; using the+-- tree in 15.4 get the coding LRLLLRLRR: 9 chars rather than 10.++--+-- Solutions 15.6-7+--++-- Just walk through the definitions++--+-- Solution 15.8+--++mergeSort :: Ord a => [a] -> [a]++mergeSort [] = []++mergeSort [x] = [x]++mergeSort xs +  = mergeOrd (mergeSort left) (mergeSort right) +    where+    (left,right) = splitAt (length xs `div` 2) xs++mergeOrd :: Ord a => [a] -> [a] -> [a]++mergeOrd [] ys = ys+mergeOrd xs [] = xs+mergeOrd (x:xs) (y:ys)+  | x<y        = x : mergeOrd xs (y:ys)+  | x==y       = x:y: mergeOrd xs ys+  | otherwise  = y : mergeOrd (x:xs) ys++--+-- Solution 15.9+--++-- change the line+--          | x==y       = x:y: mergeOrd xs ys+-- to+--          | x==y       = x: mergeOrd xs ys++--+-- Solution 15.10+--++-- assuming that x `f` y iff x<=y.++mergeSort' :: (a -> a -> Bool) -> [a] -> [a]++mergeSort' _ [] = []++mergeSort' _ [x] = [x]++mergeSort' f xs +  = mergeOrd' f (mergeSort' f left) (mergeSort' f right) +    where+    (left,right) = splitAt (length xs `div` 2) xs++mergeOrd' ::  (a -> a -> Bool) -> [a] -> [a] -> [a]++mergeOrd' _ [] ys = ys+mergeOrd' _ xs [] = xs+mergeOrd' f (x:xs) (y:ys)+  | x `f` y        = x : mergeOrd' f xs (y:ys)+  | otherwise      = y : mergeOrd' f (x:xs) ys++--+-- Solution 15.11+--++-- already in MakeTree.hs++--+-- Solution 15.12+--++-- Stadard calculation.++--+-- Solution 15.13+--++-- showTable is a standard layout problem.++showTree :: Tree -> String++showTreeInd :: Int -> Tree -> String++showTree = showTreeInd 0++showTreeInd n (Leaf ch int) = replicate n ' ' ++ show ch ++ ": " ++ show int ++"\n"+showTreeInd n (Node m t1 t2) = showTreeInd (n+4) t1 +++                               replicate n ' ' ++ show n +++                               showTreeInd (n+4) t2++--+-- Solution 15.14+--++-- Basic property to expect is that (decode.code) is the identity function, or+--       decode (code string) = string+-- But need the string to come from the elements in the code tree. Alternatively+-- can just left the coding function drop anything unrecodgnised, and then compare+-- the results of decode.code with the string with the unrecognised characters +-- removed. This means don't have to write a special generator, but means that most+-- of the tests are effectively on the empty list.++--+-- Solution 15.15+--++sorted :: [Int] -> Bool++sorted [] = True+sorted [x] = True+sorted (x:y:zs) = x<=y && sorted (y:zs)++--+-- Solution 15.16+--++-- Pretty open-ended. Note discussion for 15.14 above. Often different ways of+-- solving the same problem.++--+-- Solution 15.17+--++-- an example is given in 15.14.++--+-- Solution 15.18+--++-- It's possible to write a property / test of whether a sequence of L's and R's is+-- a valid code. For the abt tress above, would have LL as a valid code sequence but+-- not LR, as this should be LRL or LRR. Any sequence is a valid initial segment, so +-- can be extended to a valid code. Once that's done, then should expect that+-- code.decode is also the identity (on that subset).++++++++++

binary file changed (absent → 6148 bytes)

binary file changed (absent → 82 bytes)

@@ -0,0 +1,474 @@+------------------------------------------------------------------------------+--+-- 	Haskell: The Craft of Functional Programming+-- 	Simon Thompson+-- 	(c) Addison-Wesley, 2011.+-- +-- 	Solutions16+--+------------------------------------------------------------------------------++module Solutions16 where++import Tree+import UseTree++-- The type Var.++type Var = Char++--+-- Solution 16.1+--++-- The implementation here has names suffixed with "S"++type StoreS = [(Var, Integer)]++initialS :: StoreS++initialS = []++-- Note that in case the variable isn't bound, returns 0.++valueS :: StoreS -> Var -> Integer++valueS [] v = 0 ++valueS ((w,n):sto) v+  | w<v            = valueS sto v+  | w==v           = n+  | otherwise      = 0++-- This implementation overwrites the previous binding (assumed+-- to be unique).++updateS :: StoreS -> Var -> Integer -> StoreS++updateS [] v n = [(v,n)]++updateS ((w,m):sto) v n+  | w<v         = (w,m) : updateS sto v n+  | w==v        = (v,n) : sto+  | otherwise   = (v,n) : (w,m) : sto++--+-- Solution 16.2+--++-- For the implemetation in 16.1 it's actual equality. For the non-+-- ordered implementation in the chapter, need only to look at the first +-- values given to variables: variable,value pairs later in the list are+-- ignored.++-- For function types need some indication of what the domain is. The neatest+-- way to do this is to pair the function with a list of variables which +-- gives the set of variables defined. Need just to check equalities on these+-- lists.++--+-- Solution 16.3+--++-- Using a maybe type we can avoid returning the conventional 0 when a+-- variable isn't defined. Instead say this, modifying the solution to+-- 16.1.++valueS' :: StoreS -> Var -> Maybe Integer++valueS' [] _ = Nothing ++valueS' ((w,n):sto) v+  | w<v            = valueS' sto v+  | w==v           = Just n+  | otherwise      = Nothing++--+-- Solution 16.4+--++hasVal ::  StoreS -> Var -> Bool++hasVal [] _ = False ++hasVal ((w,n):sto) v+  | w<v            = hasVal sto v+  | w==v           = True+  | otherwise      = False++--+-- Solution 16.5+--++-- Easy for the functional implementation.++-- For the list implementation would have to define a "catch all" variable, or+-- ass an extr field to a record which is the default value for variables as+-- yet unassigned.++--+-- Solution 16.6+--++-- Need to choose an appropriat esubset of the type signatures of the functions+-- in the case study. ++-- An important point is not to include in the API functions which can be defined+-- in terms of other API functions. If that's the case, define them in this was so+-- that if/when the API is redefined these functions don't need to be redefined.++--+-- Solution 16.7+--++-- Standard calculations.++--+-- Solution 16.8+--++-- This exercise helps to make concrete the differences between the three implementations.++--+-- Solution 16.9+--++-- If a queue is not empty, then the the first element to be removed will+-- be the same before and after adding another element to the queue.++-- If a queue is empty and x is added, then x is the first element in the +-- queue.++--+-- Solution 16.10+--++-- Can add elements to either end of the queue and if it is non-empty+-- can remove an element from either end too. Could implement with a single+-- list, or with a pair of lists: the latter should be much more efficient.++-- In both cases it's a matter of extending one of the existing implementations+-- with implmentations of the two new operations.++--+-- Solution 16.11+--++-- Same API as the ordinary queue; need to implement so that don't add a new+-- entry for a value already in the queue.++-- Alternatively could add another operation to the queue to check when an+-- entry is already present, so that can know when it's (not) worth adding+-- an entry. ++--+-- Solution 16.12+--++type Priority = Int++-- Store elements in descending order of priority. Within a particular priority +-- store in FIFO form.++-- Note that this is a "concrete" implementation. If it's to be an ADT then+-- need to declare as a newtype with a wrapping constructor.++type PriQ a = [(Int,[a])]++emptyPQ = []++isEmptyPQ [] = True+isEmptyPQ _  = False++addPQ :: a -> Priority -> PriQ a -> PriQ a++addPQ x p [] = [(p,[x])]+addPQ x p qs@((q,ys):rest)+  | p>q         = (p,[x]):qs+  | p==q        = (q,ys++[x]):rest+  | p<q         = (q,ys) : addPQ x p rest++remPQ :: PriQ a -> (Maybe a, PriQ a)++remPQ q+  | isEmptyPQ q   = (Nothing, q)+  | otherwise     = (Nothing, [])++--+-- Solution 16.13+--++-- Once accumulated the scores of each letter can put into a priority queue; this+-- could help in tree building.++--+-- Solution 16.14+--++-- Can define isNil from isNode, and vice versa++-- Can define isNil from minTree: it will return Nothing iff tree is Nil.++-- Given any (finite) tree value t where elements are in Ord a can define nil thus:++{-+makeNil :: Ord a => Tree a -> Tree a+makeNil t+  | res == Nothing      = t+  | otherwise           = makeNil (delete min t)+    where+    res = minTree t+    Just min = res+-}++--+-- Solution 16.15+--++-- Depends a bit on what the database is to do, but need lookups and updates, as+-- well as initial value. Can define e.g. number of loans from the interface functions.++--+-- Solution 16.16+--++-- Two sorts of interface here++-- Using an existing index: take word to page range. Take page to all entries, perhaps?++-- Building an index: take a text to an index.++--+-- Solution 16.17+--++-- QueueState:+-- can define queueEmpty from queueLength++-- ServerState:+-- can define simulationStep using serverStep, shortestQueue and addToQueue+-- is it enough to have simulationStep, serverStart and serverSize? certainly+-- it is to actually run the simulation step by step.++--+-- Solution 16.18+--++-- In the light of the previous answer, it would be enough to include+-- simulationStep, serverStart and serverSize in an interface, and to have+-- the "next queue" as an element of the state, but not directly accessible+-- from the interface:++-- type NextState      = Int+-- newtype ServerState = SS ([QueueState],NextState)++-- Alternatively if more is to be exposed, then need a function to reveal+-- the current value of the "next state++--+-- Solutions 16.19,20+--++-- Standard calculations.++--+-- Solution 16.21+--++-- QueueState: running the queue to completion on a list of n inputs+-- should produce a list of n outputs, processed in order in which they +-- arrived. In order to do this need to define a number of auxiliary +-- functions, the major one being a funciton to run the queue to +-- completion on an input list.++-- Need to take account here of the arrival times: can't expect to +-- process something (at least) until it has arrived. Halt processing when+-- there are no more input messages to process and the queue itself is+-- empty.++--+-- Solution 16.22+--++-- Need to know how many queues there are, and can't tell this from an +-- arbitrary function of type (Int -> QueueState); need to pair this function+-- with an Int telling you the number of queues. Once that's there, replace +-- accessing a queue by list indexing and instead just use function application.+-- e.g. in the definition of addToQueue don't have to split the list up,+-- operate on one element and then form another list; instead simply change the +-- value of the function on argument n.++--+-- Solution 16.23+--++-- See solution 16.17 above.++--+-- Solutions 16.24-25+--++-- See solution 16.18 above.++--+-- Solution 16.26+--++-- A different version of the round robin implemetation +-- will keep a, ordered list of (Int,Queue) pairs and ensure that+-- the current/next queue is always at the head.++--+-- Solution 16.27,28+--++-- There are two approaches here: could test the accessor, selector+-- and discriminator functions, but we should be able to assume these+-- are ok. Here we test for the top level properties of how elementhood+-- interacts with insertion and deletion:++prop_add_tree :: Int -> Int -> Tree Int -> Bool++prop_add_tree n m t+  = elemT n t == elemT n (insTree m t) || n==m++prop_delete_tree :: Int -> Int -> Tree Int -> Bool++prop_delete_tree n m t+  = elemT n t == elemT n (delete m t) || n==m++-- Could also check that the minTree function indeed picks the minimum+-- value in the tree by comparing it with the nth value in the tree:++prop_min_tree :: Integer -> Tree Int -> Bool++prop_min_tree i t+  = let Just min = minTree t in+        min <= indexT i t || isNil t -- || "i not valid"++-- would be easier for this to be defined if indexT returned a Maybe a+-- indicating whether or not the index is in range: exercise.++--+-- Solution 16.29+--++{-+successor :: Ord a => a -> Tree a -> Maybe a++successor v Nil = Nothing+successor v (Node x t1 t2)+  | x<=v          = successor v t2+  | otherwise     = case maxT t1 of+                      Nothing -> x+                      Just y  -> if y>v +                                    then successor v t1+                                    else x++maxT :: Ord a => Tree a -> Maybe a++maxT Nil            = Nothing+maxT (Node x _ Nil) = Just x+maxT (Node x _ t2)  = maxT t2+-}++--+-- Solution 16.30+--++-- Stree is defined on p398.++-- The paradigm for the solution is given on p398+-- where it is shown that the new field gives the value it+-- should, while the other functions need to maintain that+-- value.++--+-- Solution 16.31+--++-- Built on the model of Stree: need to make sure that the +-- functions manipulate the "cached" values appropriately.++-- This is not caching the size, incidentally.++data MMtree a = NilMM | NodeMM a a a (MMtree a) (MMtree a)++insTreeMM :: Ord a => a -> MMtree a -> MMtree a++insTreeMM val NilMM = NodeMM val val val NilMM NilMM++insTreeMM val (NodeMM x minV maxV t1 t2)+  | val<=x          = NodeMM x newMin maxV newT1 t2+  | val>x           = NodeMM x minV newMax t1 newT2+    where+    newMin      = min val minV+    newMax      = max val maxV+    newT1       = insTreeMM val t1+    newT2       = insTreeMM val t2 ++-- Note that because of lazy evaluation (Chapter 17) in each+-- case will only compute one of newMin / newMax and newT1 / newT2+-- according to the relation between val and x, the value at the+-- root of the tree.++--+-- Solution 16.32+--++-- The implentation type could remain the same, but it would be better to +-- store an occurrence count with each element (with the assumption +-- that no element occurs more than once). ++-- If the implementation type remains the same, then need to scan for all+-- occurrences of a particular element when looking for its occurrence +-- count.++-- Should extend the interface with an element occurrence function, rather+-- than simply checking elementhood. This effectively gives "bags" rather+-- than "sets".++--+-- Solution 16.33+--++-- Search trees keep the implementation ordered. This is a straightforward +-- re-implementation of the application.++--+-- Solution 16.34+--++-- This solution takes a different approach. Update the b value by passing in+-- an update function, of type (b -> b), to the insertion. This is applied to, e.g.+-- add an instance of a word to a list of instances, so might be (++[newOccurrence])+-- in that case.++data GenTree a b = GenNil b+                 | GenNode a b (GenTree a b) (GenTree a b)++insertGenTree :: Ord a => a -> (b -> b) -> GenTree a b -> GenTree a b++insertGenTree x f (GenNil b)+  = GenNode x (f b) (GenNil b) (GenNil b)++insertGenTree x f (GenNode a b t1 t2)+  | x==a          = GenNode a (f b) t1 t2+  | x<a           = GenNode a b (insertGenTree x f t1) t2+  | x>a           = GenNode a b t1 (insertGenTree x f t2)++--+-- Solution 16.35+--++-- One gives a total ordering, but of less value than a (partial) subset ordering.++--+-- Solutions 16.36 - 16.44 SEE SolutionsSet.hs+--++--+-- Solutions 16.45 - 16.50 SEE SolutionsRelation.hs+--++

@@ -18,9 +18,11 @@    treeVal,       -- Tree a -> a    insTree,       -- Ord a => a -> Tree a -> Tree a     delete,        -- Ord a => a -> Tree a -> Tree a-   minTree        -- Ord a => Tree a -> Maybe a+   minTree,        -- Ord a => Tree a -> Maybe a+   elemT           -- Ord a => a -> Tree a -> Bool   ) where + data Tree a = Nil | Node a (Tree a) (Tree a)					 --   @@ -77,6 +79,15 @@       where       t1 = leftSub t       v  = treeVal t++elemT :: Ord a => a -> Tree a -> Bool++elemT x Nil       = False+elemT x (Node y t1 t2)+  | x<y          = elemT x t1+  | x==y         = True+  | otherwise    = elemT x t2+   -- The join function is an auxiliary, used in delete, where note that it

@@ -0,0 +1,132 @@+-------------------------------------------------------------------------+-- +-- 	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 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+1) p = (p >*> nTimes n 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 ])++sparse :: SParse a b -> Parse a b++sparse (SParse pr) = pr++

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

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

@@ -0,0 +1,258 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++++module PositionedImages where++import System.IO++import Control.Monad+import Control.Monad.State++import Data.Map hiding (map)++--+-- Geometric types+--++-- Points measured with Int coordinates thus:+--+--  o------> x axis+--  |+--  |+--  V+--  y axis++type Point = (Int,Int)++origin = (0,0)++-- Bounding box: represented by NW and SE corners:+--+--  o------++--  |      |+--  |      |+--  +------o+--  ++data Box = Box Point Point+           deriving (Show, Eq)++emptyBox = Box origin origin++-- +-- Images and pictures+-- ++-- Pictures are rectangular assemblies of Basic images.+-- Each picture has a bounding box, memoised in the data structure ++-- An image is contained in a file ...++data File  = File String+             deriving (Show)++-- ... and is displayed in an area of size given by the Point:++data Image = Image File Point+             deriving (Show)++-- A basic image is an image, with the Point of its origin, and a Filter +-- of effects to be applied.++data Basic = Basic Image Point Filter+             deriving (Show)++data Filter = Filter {fH, fV, neg :: Bool}+              deriving (Show)++newFilter = Filter False False False++-- A Picture is a list of Basics.++data Picture = Picture [Basic]++-- Convert an Image to a Basic and to a Picture++basic :: Image -> Basic ++basic img = + Basic img origin newFilter++img :: Image -> Picture ++img img@(Image _ point) = + Picture [Basic img origin newFilter]++box :: Basic -> Box+  +box (Basic img@(Image _ (x,y)) (x',y') _)+ = Box (x',y') (x'+x, y'+y)+++--+-- The monad+--++-- Simple state monad keeping track of the dimensions of the current picture.+-- Folds into the definition the calculation of width and height and the+-- calculation of flatten, which is done as the picture is constructed.++type Def a = State Info a++-- State is a finite map from Ints to Basic images++type Info = Map Id Basic++-- Ids are Ints, which are the keys for the Info map++type Id = Int++-- Positions of the four corners of a rectangular image+-- Could also add N, W, E, S and Centre   TO DO++data Position = NW | NE | SW | SE++-- Monadic functions++-- Place an image at a given point in the canvas++placeId :: Image -> Point -> Def Id+placeId image point+ = +   do+     n <- gets size+     let basic = Basic image point newFilter+     modify (insert n basic) +     return n++place :: Image -> Point -> Def ()+place image point+ = +   do+     n <- gets size+     let basic = Basic image point newFilter+     modify (insert n basic) +     return ()++positionId :: Image -> Id -> Position -> Def Id+positionId image id pos+ = +   do+     n <- gets size+     b <- gets (box . just . Data.Map.lookup id)+     let  basic = Basic image (getPosition pos b) newFilter+     modify (insert n basic) +     return n++position :: Image -> Id -> Position -> Def ()+position image id pos+ = +   do+     n <- gets size+     b <- gets (box . just . Data.Map.lookup id)+     let  basic = Basic image (getPosition pos b) newFilter+     modify (insert n basic) +     return ()++just (Just n) = n++flatten :: Def a -> Picture++flatten defs +  = makePicture (execState defs empty)++makePicture :: Map Int Basic -> Picture+makePicture picMap  +  = Picture $ fold (:) [] picMap++--+-- Library functions+--++-- Extracting coordinates of the four corners of a box++getPosition :: Position -> Box -> Point++getPosition NW (Box pt _) = pt+getPosition NE (Box (_, y0) (x1, _)) = (x1, y0)+getPosition SW (Box (x0, _) (_, y1)) = (x0, y1)+getPosition SE (Box _ pt) = pt+++--+-- examples+--++horse :: Image++horse = Image (File "blk_horse_head.jpg") (150, 200)++test :: Def ()++test+  = +    do+      pic <- placeId horse (100,100)+      pic2 <- positionId horse pic SE+      position horse pic2 SW+      +testProgram :: IO ()++testProgram = render $ flatten $ test++-- flipFH is flip in a horizontal axis+-- flipFV is flip in a vertical axis+-- flipNeg negative negates each pixel+-- flip one of the flags for transforms / filter++flipFH (Basic img point f@(Filter {fH=boo})) = Basic img point f{fH = not boo}+flipFV (Basic img point f@(Filter {fV=boo})) = Basic img point f{fV = not boo}+flipNeg (Basic img point f@(Filter {neg=boo})) = Basic img point f{neg = not boo}++-- Convert is unchaged from the previous version, converts a basic +-- image to an SVG object.++convert :: Basic -> String++convert (Basic (Image (File name) (width, height)) (x, y) (Filter fH fV neg))+  = "\n  <image x=\"" ++ show x ++ "\" y=\"" ++ show y ++ "\" width=\"" ++ show width ++ "\" height=\"" +++    show height ++ "\" xlink:href=\"" ++ name ++ "\"" ++ flipPart ++ negPart ++ "/>\n"+        where+          flipPart = if fH && not fV +                     then " transform=\"translate(0," ++ show (2*y + height) ++ ") scale(1,-1)\" " +                     else +                         if fV && not fH +                         then " transform=\"translate(" ++ show (2*x + width) ++ ",0) scale(-1,1)\" " +                         else +                             if fV && fH +                             then " transform=\"translate(" ++ show (2*x + width) ++ "," ++ show (2*y + height) ++ ") scale(-1,-1)\" " +                             else ""+          negPart = if neg then " filter=\"url(#negative)\"" else "" ++-- Rendering a picture to a file++render :: Picture -> IO ()++render pic + = +   let+       Picture picList = pic+       svgString = concat (map convert picList)+       newFile = preamble ++ svgString ++ postamble+   in+     do+       outh <- openFile "/Users/simonthompson/Dropbox/craft3e/DSLs/svg/svgOut.xml" WriteMode+       hPutStrLn outh newFile+       hClose outh++preamble+ = "<svg width=\"100%\" height=\"200%\" version=\"1.1\"\n" +++   "xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\">\n" +++   "<filter id=\"negative\">\n" +++   "<feColorMatrix type=\"matrix\"\n"+++   "values=\"-1 0  0  0  0  0 -1  0  0  0  0  0 -1  0  0  1  1  1  0  0\" />\n" +++   "</filter>\n"++postamble+ = "\n</svg>\n"

@@ -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

@@ -68,15 +68,7 @@ a = Ch 'a' b = Ch 'b' -interp :: RE -> RegExp--interp Eps = epsilon-interp (Ch ch) = char ch-interp (re1 :|: re2)-    = interp re1 ||| interp re2-interp (re1 :*: re2)-    = interp re1 <*> interp re2-interp (St re) = star (interp re)+-- interp: RE -> RegExp: exercise.  -- Value recursion --  Eunmerating strings matching a regexp@@ -114,10 +106,6 @@ anbn :: RE  anbn = Eps :|: (a :*: (anbn :*: b))--palin :: RE --palin = (Eps :|: (a :*: (palin :*: a))) :|: (b :*: (palin :*: b))  -- Extending the implementation 

@@ -0,0 +1,227 @@+------------------------------------------------------------------------------+--+-- 	Haskell: The Craft of Functional Programming+-- 	Simon Thompson+-- 	(c) Addison-Wesley, 2011.+-- +-- 	Solutions19+--+------------------------------------------------------------------------------++module Solutions19 where++import RegExp +import ParseLib+import Data.Char (isLower)+import Test.QuickCheck+import QC+import QCfuns++--+-- Solution 19.1+--++interp :: RE -> RegExp++interp Eps         = epsilon+interp (Ch ch)     = char ch+interp (e1 :|: e2) = interp e1 ||| interp e2+interp (e1 :*: e2) = interp e1 <*> interp e2+interp (St e)      = star (interp e)+interp (Plus e)    = i <*> star i+                     where+                     i = interp e++--+-- Solution 19.2+--++-- First pretty printing, which shows the grammar used.+-- 'e' is the syntax for epsilon, here.++prettyRE :: RE -> String++prettyRE Eps         = "e"+prettyRE (Ch ch)     = [ch]+prettyRE (e1 :|: e2) = "("++ prettyRE e1 ++"|"++ prettyRE e2 ++ ")"+prettyRE (e1 :*: e2) = "("++ prettyRE e1 ++ prettyRE e2 ++ ")"+prettyRE (St e)      = "("++ prettyRE e ++ ")*"+prettyRE (Plus e)    = "("++ prettyRE e ++ ")+"++-- Little parsers++epsP, charP :: Parse Char RE++epsP = spot (=='e') `build` const Eps++charP = spot isLowerNoE `build` Ch++isLowerNoE ch = isLower ch && ch/='e'++altP :: Parse Char RE -> Parse Char RE -> Parse Char RE++altP p1 p2+  = (spot (=='(') >*>+     p1 >*>+     spot (=='|') >*>+     p2 >*>+     spot (==')'))+    `build`+    \ (_,(e1,(_,(e2,_)))) -> e1 :|: e2++seqP :: Parse Char RE -> Parse Char RE -> Parse Char RE++seqP p1 p2+  = (spot (=='(') >*>+     p1 >*>+     p2 >*>+     spot (==')'))+    `build`+    \ (_,(e1,(e2,_))) -> e1 :*: e2+++starP :: Parse Char RE -> Parse Char RE++starP p+  = (spot (=='(') >*>+     p >*>+     spot (==')') >*>+     spot (=='*'))+    `build`+    \ (_,(e,(_,_))) -> St e++-- pulling them together++reP :: Parse Char RE++reP = epsP +       `alt`+       charP+       `alt`+       altP reP reP+       `alt`+       seqP reP reP+       `alt`+       starP reP+        +-- top-level function.++parseRE :: String -> RE++parseRE st+  = e+    where+    [(e,"")] = reP st++-- Expected property: the two functions are inverses of each other, when applied to legal +-- representations of strings.++-- To test in QuickCheck, note that it's difficult to generate legal strings directly,+-- instead best to generarte REs and turn them into legal strings.++--+-- Solution 19.3+--++palin :: RE ++palin = (middle :|: (a :*: (palin :*: a))) :|: (b :*: (palin :*: b))++middle = (Eps :|: (a :|: b))++--+-- Solution 19.4+--++-- Just follow the pattern of recursion used in the definition of reP above.+-- Works just like 19.3.++--+-- Solution 19.5+--++-- I believe that "recursive regular expressions" = "context free grammars" and+-- so this set of strings will therefore not be representable.++--+-- Solution 19.6+--++-- What does extension mean? Add a construct to RE and then extend its+-- interpretations into RegExp, enumeration, concrete syntax etc.++-- MatchN Int RE, interpreted by++matchN :: Int -> RegExp -> RegExp++matchN n re+  | n<=0        = epsilon+  | otherwise   = re <*> matchN (n-1) re++--- Ranges etc. are all pretty straightforward.++--+-- Solution 19.7+--++--- Actually not so difficult to implement ...++matchBoth :: RegExp -> RegExp -> RegExp++matchBoth re1 re2 st +  = re1 st && re2 st++matchNot :: RegExp -> RegExp++matchNot re st+  = not (re st)++--+-- Solutions 19.8-10+--++-- See the module PositionedImages.hs++--+-- Solution 19.11+--++-- This was discussed in Solutions12,  question 12.19.++--+-- Solution 19.12+--++samplePretty :: IO ()++samplePretty+  = do exprs <- sample' (arbitrary :: Gen Expr)+       printLines (map ((++"\n").prettyE) exprs)++printLines :: [String] -> IO ()++printLines strs+  = if strs == [] +       then return ()+       else do putStr (head strs)+               printLines (tail strs)++--+-- Solution 19.13+--++-- Generators standard.++-- Properties +--   - should be able to round trip exp -> pretty -> exp+--   - not so obvious how to test the fact that the evaluator gives+--     the right result.+--   - one idea is to build pairs of expression and their values, which+--     are generated simultaneously ,,, of course, that is tantamount +--     to defining a second evaluation function (albeit implicitly).++--+-- Solution 19.14+--++-- Five finger exercise ...

@@ -2,7 +2,7 @@ -- -- 	Haskell: The Craft of Functional Programming -- 	Simon Thompson--- 	(c) Addison-Wesley, 2010.+-- 	(c) Addison-Wesley, 2011. --  -- 	Chapter 2 -- 

@@ -414,7 +414,7 @@ playSvsS :: Strategy -> Strategy -> Integer -> Tournament  playSvsS strategyA strategyB n-     = if n<=0 then ([],[]) else step strategyA strategyB (playSvsS strategyA strategyB (n-1))+     = error "exercise"   --

@@ -1,6 +1,6 @@  name: Craft3e-version: 0.1.0.3+version: 0.1.0.4 license: MIT license-file: LICENSE copyright: (c) Addison Wesley@@ -21,7 +21,7 @@   .   2. Go to directory: @cd Craft3e-<version>@   .-  3. Install dependencies: @cabal install@ +  3. Install dependencies: @cabal install --disable-documentation@  extra-source-files:   README.txt@@ -40,7 +40,7 @@     QuickCheck >= 2.1 && < 3,     old-locale == 1.0.*,     time >= 1.1 && < 1.3,-    mtl >= 1.1 && < 2.1,+    mtl >= 1.1 && < 2.2,     HUnit == 1.2.*      exposed-modules:

binary file changed (absent → 6148 bytes)

binary file changed (absent → 82 bytes)

@@ -0,0 +1,49 @@+-- (c) Addison-Wesley, 1996-2010.+-- 	DOtest.lhs+++test1 :: IO ()++test1 +  = do getLine+       getLine+       line3 <- getLine+       putStr (line3 ++ "\n")+++put4times :: String -> IO ()++put4times str +  = do putStrLn str+       putStrLn str+       putStrLn str+       putStrLn str++putNtimes :: Int -> String -> IO ()++putNtimes n str+  = if n <= 1 +       then putStrLn str+       else do putStrLn str+	       putNtimes (n-1) str++read2lines :: IO ()++read2lines +  = do getLine+       getLine+       putStrLn "Two lines read."++reverse2lines :: IO ()+reverse2lines+  = do line1 <- getLine+       line2 <- getLine+       putStrLn (reverse line2)+       putStrLn (reverse line1)++addOneInt :: IO ()+addOneInt +  = do line <- getLine+       putStrLn (show (1 + read line :: Int))+--  +

@@ -0,0 +1,171 @@+--------------------------------------------------------------------------+--                                                                      --+--	FirstEd.hs Using Monads for I/O					--+--	Haskell 1.4 version	  					--+--                                                                      --+--	(c) Addison-Wesley, 1996-2010.					--+--                                                                      --+--------------------------------------------------------------------------++import IO	-- not good enough! isEOF not implemented properly +		-- in Hugs 1.4 yet!++--------------------------------------------------------------------------+--	To read a line							--+--		getLine :: IO String					--+--                                                                      --+--      To write a string						--+--		putStr :: String -> IO ()				--+--									--+--	The `then' operation						--+--		(>>=) :: IO t -> (t -> IO u) -> IO u			--+--------------------------------------------------------------------------++--------------------------------------------------------------------------+--      To write a line                                                 --+--	That is write a String with a newline appended.			--+--------------------------------------------------------------------------++putLine :: String -> IO ()++putLine line = putStr (line ++ "\n")++--------------------------------------------------------------------------+--      Read then write							--+--------------------------------------------------------------------------++readWrite :: IO ()++readWrite = do line <- getLine+               putLine line++--------------------------------------------------------------------------+--      Read, reverse then write					--+--------------------------------------------------------------------------++readRevWrite :: IO ()++readRevWrite+  = do line <- getLine+       putLine (reverse line)++--------------------------------------------------------------------------+--      Return a value without doing any IO				--+--		return :: t -> IO t					--+--									--+--	Sequence without passing values between				--+--		(>>) :: IO t -> IO u -> IO u				--+--		f >> g = f >>= const g					--+--------------------------------------------------------------------------++--------------------------------------------------------------------------+--      Apply a function and return its result				--+--------------------------------------------------------------------------++apply :: (t -> u) -> t -> IO u+apply f a = return (f a)++--------------------------------------------------------------------------+--	Read, reverse then write (revisited)				--+--------------------------------------------------------------------------++readRevWrite' :: IO ()+readRevWrite' = (getLine >>= apply reverse) >>= putLine++--------------------------------------------------------------------------+--      Making a String transformer into an interaction.		--+--		interact :: (String -> String) -> IO ()			--+--------------------------------------------------------------------------++--------------------------------------------------------------------------+--      Iteration							--+--------------------------------------------------------------------------++while :: IO Bool -> IO () -> IO ()++while test oper+  = do res <- test+       if res then do oper+                      while test oper+              else return ()++--------------------------------------------------------------------------+--      Testing for the end of input					--+--		isEOF :: IO Bool					--+--      This version uses the NONSTANDARD hugsIsEOF for IO.hs		--+--	It's not clear how you use this interactively; I remember now   --+--	that C I/O is peculiar!						--+--------------------------------------------------------------------------++isEOF = hugsIsEOF++--------------------------------------------------------------------------+--	Copy lines until end of file.					--+--------------------------------------------------------------------------++copyInputToOutput :: IO ()+copyInputToOutput+  = while (do res <- isEOF+              return (not res))+          (do line <- getLine+              putLine (reverse line))+ ++-- reverse lines until you hit an empty line+-- can't see an easy way of building this with +-- combinators rather than recursion ...+-- ... goUntilEmpty is a failed attempt.++reverseUntilEmpty :: IO ()++reverseUntilEmpty+  = do line <- getLine+       if (line == [])+          then return ()+          else (do putLine (reverse line)+                   reverseUntilEmpty)+            +-- following version doesn't work: +-- forever outputs the first line read++goUntilEmpty :: IO ()+goUntilEmpty+ = do line <- getLine+      while (return (line /= []))+            (do putLine line+                line <- getLine+                return ())++-- get an integer on a line on its own +-- not particularly robust: gives an error+--	Program error: PreludeText.read: no parse+-- in case there is anything untoward in the input,+-- including perhaps multiple Ints per line.++getInt :: IO Int++getInt = do line <- getLine+            return (read line :: Int)++-- sum integers until 0 is input++sumInts :: IO Int++sumInts+  = do n <- getInt+       if n==0 +          then return 0+          else (do m <- sumInts+                   return (n+m))++-- an interactive wrapper for sumInts++sumInteract :: IO ()++sumInteract+  = do putLine "Enter integers one per line"+       putLine "These will be summed until zero is entered"+       sum <- sumInts+       putStr "The sum was "+       putLine (show sum)+       

@@ -0,0 +1,55 @@+--------------------------------------------------------------------------+--                                                                      --+--	 Tree and the identity monad.                                   --+--                                                                      --+--	(c) Addison-Wesley, 1996-2010.					--+--                                                                      --+--------------------------------------------------------------------------++import Prelude++--------------------------------------------------------------------------+--       Type of trees							--+--------------------------------------------------------------------------++data Tree t = Nil | Node t (Tree t) (Tree t) +              deriving (Eq, Show)++--------------------------------------------------------------------------+--       A direct computation of the sum of a tree.			--+--------------------------------------------------------------------------++sTree :: Tree Int -> Int++sTree Nil = 0++sTree (Node n t1 t2) = n + sTree t1 + sTree t2++--------------------------------------------------------------------------+--       A monadic computation of the sum of a tree.			--+--------------------------------------------------------------------------++sumTree :: Tree Int -> Id Int++sumTree Nil = return 0++sumTree (Node n t1 t2)+  = do num <- return n+       s1  <- sumTree t1+       s2  <- sumTree t2+       return (num + s1 + s2)++--------------------------------------------------------------------------+--	 The monad in question -- the identity monad			--+--------------------------------------------------------------------------++data Id t = Id t +            deriving (Eq, Ord, Show, Read)++instance Monad Id where+  return         = Id+  (>>=) (Id x) f = f x++extract :: Id t -> t+extract (Id x) = x+

@@ -0,0 +1,99 @@+--------------------------------------------------------------------------+--                                                                      --+--	 Tree and a State monad					        --+--                                                                      --+--	(c) Addison-Wesley, 1996-2010.					--+--                                                                      --+--------------------------------------------------------------------------++import Prelude hiding (lookup)++--------------------------------------------------------------------------+--       Type of trees							--+--------------------------------------------------------------------------++data Tree a = Nil | Node a (Tree a) (Tree a) +              deriving (Eq,Show)++--------------------------------------------------------------------------+--       A state monad							--+--------------------------------------------------------------------------++data State a b = State (Table a -> (Table a , b))++type Table a = [a]++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)++extract :: State a b -> b++extract (State st) = snd (st [])++--------------------------------------------------------------------------+--	 Assigning unique natural numbers to the members of a tree.	--+--------------------------------------------------------------------------++numTree :: Eq a => Tree a -> Tree Int+numTree = extract . numberTree++numberTree :: Eq a => Tree a -> State a (Tree Int)++numberTree Nil = return Nil++numberTree (Node x t1 t2)+  = do num <- numberNode x+       nt1 <- numberTree t1+       nt2 <- numberTree t2+       return (Node num nt1 nt2)++--------------------------------------------------------------------------+--      Numbering a Node involves a lookup, which in turn will modify 	--+--	the state in case the value is seen for the first time.		--+--------------------------------------------------------------------------++numberNode :: Eq a => a -> State a Int++numberNode x +  = State (\ table -> if elem x table+                         then (table , lookup x table)+                         else (table++[x] , length table) )++lookup :: Eq a => a -> Table a -> Int++lookup x table = look x table 0++look :: Eq a => a -> Table a -> Int -> Int++look x [] n = error "table lookup"+look x (y:ys) n+  | x==y	= n+  | otherwise	= look x ys (n+1)++--------------------------------------------------------------------------+--	Examples							--+--------------------------------------------------------------------------++example :: Tree Char++example = Node 'z' ex1 ex2++ex1 = Node 'f' ex2 ex2++ex2 = Node 'q' (Node 'z' Nil Nil) (Node 'e' Nil Nil)++data Children = Ahmet | Dweezil | Moon +		deriving Eq++zapTree :: Tree Children++zapTree = Node Moon (Node Ahmet Nil Nil)+		    (Node Dweezil (Node Ahmet Nil Nil)+				  (Node Moon Nil Nil))+

@@ -0,0 +1,177 @@+Calculator+Chapter1.hs+Chapter10.hs+Chapter11.hs+Chapter12.hs+Chapter13.hs+Chapter14_1.hs+Chapter14_2.hs+Chapter15+Chapter16+Chapter17.hs+Chapter18.hs+Chapter19+Chapter2.hs+Chapter20.hs+Chapter3.hs+Chapter4.hs+Chapter5.hs+Chapter6.hs+Chapter7.hs+Chapter8.hs+Chapter9.hs+Craft3e.cabal+FirstScript.hs+IO+Index.hs+LICENSE+LISTING+ParseLib.hs+Parsing.hs+PerformanceI.hs+PerformanceIA.hs+PerformanceIS.hs+Pic.hs+Pictures.hs+PicturesSVG.hs+QCfuns.hs+README.txt+RPS.hs+Relation.hs+Set.hs+Setup.hs+Simulation+UseMonads.hs+black.jpg+blk_horse_head.jpg+blue.jpg+dist+red.jpg+refresh.html+showPic.html+svgOut.xml+white.jpg++./Calculator:+CalcEval.hs+CalcParse.hs+CalcParseLib.hs+CalcStore.hs+CalcToplevel.hs+CalcTypes.hs++./Chapter15:+Ant.hs+Bee.hs+CodeTable.hs+Coding.hs+Cow.hs+Doe.hs+Frequency.hs+Main.hs+MakeCode.hs+MakeTree.hs+Test.hs+Types.hs++./Chapter16:+QCStoreTest.hs+Queues1.hs+Queues2.hs+Queues3.hs+Store.hs+StoreFun.hs+StoreTest.hs+Tree.hs+UseStore.hs+UseStoreFun.hs+UseTree.hs++./Chapter19:+QC.hs+RegExp.hs++./IO:+DoTest.hs+MonadIO.hs+TreeId.hs+TreeState.hs++./Simulation:+Base.hs+QueueState.hs+RandomGen.hs+ServerState.hs+TopLevelServe.hs++./dist:+Craft3e-0.1.0.1.tar.gz+build+package.conf.inplace+setup-config+src++./dist/build:+Chapter1.hi+Chapter1.o+Chapter10.hi+Chapter10.o+Chapter11.hi+Chapter11.o+Chapter12.hi+Chapter12.o+Chapter13.hi+Chapter13.o+Chapter14_1.hi+Chapter14_1.o+Chapter14_2.hi+Chapter14_2.o+Chapter17.hi+Chapter17.o+Chapter18.hi+Chapter18.o+Chapter2.hi+Chapter2.o+Chapter20.hi+Chapter20.o+Chapter3.hi+Chapter3.o+Chapter4.hi+Chapter4.o+Chapter5.hi+Chapter5.o+Chapter6.hi+Chapter6.o+Chapter7.hi+Chapter7.o+Chapter8.hi+Chapter8.o+Chapter9.hi+Chapter9.o+FirstScript.hi+FirstScript.o+HSCraft3e-0.1.0.1.o+HSCraft3e-0.1.o+Index.hi+Index.o+Pic.hi+Pic.o+Pictures.hi+Pictures.o+RPS.hi+RPS.o+RegExp.hi+RegExp.o+Relation.hi+Relation.o+Set.hi+Set.o+autogen+libHSCraft3e-0.1.0.1.a+libHSCraft3e-0.1.a++./dist/build/autogen:+Paths_Craft3e.hs+cabal_macros.h++./dist/src:

@@ -128,3 +128,5 @@ sparse :: SParse a b -> Parse a b  sparse (SParse pr) = pr++

@@ -129,7 +129,7 @@           []       -> start           (last:_) -> last --- Echo a move taht would have lost the last play; +-- Echo a move that would have lost the last play;  -- also have to supply starting Move.  sLostLast start moves 

@@ -150,12 +150,12 @@ --   -- Breaking the abstraction barrier for sets.			  -flatten :: Set a -> [a]--flatten = flatten                -- dummy definition+-- defined in Sets.hs+-- flatten :: Ord a => Set a -> [a]  -- Under the list implementation, we can use			--- 	flatten = id						+-- 	flatten = id+						 --   -- A list of new descendants.					 --  

@@ -20,7 +20,8 @@   filterSet          , -- (a -> Bool) -> Set a -> Set a   foldSet            , -- (a -> a -> a) -> a -> Set a -> a   showSet            , -- (a -> String) -> Set a -> String-  card                 -- Set a -> Int+  card               , -- Set a -> Int+  flatten              -- Set a -> [a]   ) where  import Data.List hiding ( union )@@ -125,15 +126,7 @@ card :: Set a -> Int card (Set xs)     = length xs ---  --- From the exercises....						----- symmDiff :: Set a -> Set a -> Set a---- powerSet :: Set a -> Set (Set a)---- setUnion :: Set (Set a) -> Set a--- setInter :: Set (Set a) -> Set a+-- Breaks the abstraction: used in Relation: +flatten (Set xs) = xs 

binary file changed (absent → 6148 bytes)

binary file changed (absent → 82 bytes)

@@ -33,7 +33,12 @@  addMessage  :: Inmess -> QueueState -> QueueState -addMessage im (QS time serv ml) = QS time serv (ml++[im])+addMessage im (QS time serv ml) +  | isYes im		= QS time serv (ml++[im])+  | otherwise		= QS time serv ml+    where+    isYes (Yes _ _)     = True+    isYes _             = False  -- A single step in the queue simulation. 

@@ -0,0 +1,92 @@+------------------------------------------------------------------------------
+--
+-- 	Haskell: The Craft of Functional Programming
+-- 	Simon Thompson
+-- 	(c) Addison-Wesley, 2011.
+-- 
+-- 	UsePictures
+-- 
+--      Solutions to Exercises 2.1-2.4
+--
+------------------------------------------------------------------------------
+
+
+module UsePictures where
+import Pictures
+
+--
+-- Solution 2.1
+--
+
+blackHorse :: Picture  
+blackHorse = (invertColour horse)
+
+rotateHorse :: Picture
+rotateHorse = flipH (flipV horse)
+
+--
+-- Solution 2.2
+-- 
+
+-- One approach is to define it all in one go ...
+
+square1 :: Picture
+
+square1 =  (black `beside` white) `above` (white `beside` black)
+
+-- ... another uses some auxilary definitions:
+
+bw, wb, square2 :: Picture
+
+bw = black `beside` white
+wb = white `beside` black
+
+square2 = bw `above` wb
+
+-- Other approaches put the squares above each other before putting 
+-- the results beside each other, using auxiliary definitions or not.
+
+-- Variants don't use infix functions, or define wb by inverting bw:
+
+wb1 = invertColour bw
+
+--
+-- Solution 2.3
+--
+
+-- Some of hese solutions use two auxiliary definitions
+
+-- White horse next to black horse, and vice versa
+
+blackWhite, whiteBlack :: Picture
+blackWhite = (beside horse blackHorse)
+whiteBlack = (beside blackHorse horse)
+
+-- A: White horse black horse, above black horse white horse
+
+checkBoard1 :: Picture
+checkBoard1 = (beside (above horse (blackHorse)) (above (blackHorse) horse))
+
+-- B: White horse, black horse above black horse white horse, flipped vertically
+
+checkBoard2 :: Picture
+checkBoard2 = (above (blackWhite) (flipV blackWhite))
+
+-- C: White horse black horse above black horse white horse, flipped horizontally
+
+checkBoard3 :: Picture
+checkBoard3 = (above (blackWhite) (flipV (flipH blackWhite)))
+
+--
+-- Solution 2.4
+--
+
+-- White horse black horse above upside down white horse black horse, flipped horizontally
+
+checkBoard4 :: Picture
+checkBoard4 = (above (blackWhite) (flipH whiteBlack))
+
+
+
+
+