diff --git a/._Calculator b/._Calculator new file mode 100644 Binary files /dev/null and b/._Calculator differ diff --git a/._Chapter15 b/._Chapter15 new file mode 100644 Binary files /dev/null and b/._Chapter15 differ diff --git a/._Chapter16 b/._Chapter16 new file mode 100644 Binary files /dev/null and b/._Chapter16 differ diff --git a/._Craft3e.cabal b/._Craft3e.cabal new file mode 100644 Binary files /dev/null and b/._Craft3e.cabal differ diff --git a/._IO b/._IO new file mode 100644 Binary files /dev/null and b/._IO differ diff --git a/._LICENSE b/._LICENSE new file mode 100644 Binary files /dev/null and b/._LICENSE differ diff --git a/._README.txt b/._README.txt new file mode 100644 Binary files /dev/null and b/._README.txt differ diff --git a/._Simulation b/._Simulation new file mode 100644 Binary files /dev/null and b/._Simulation differ diff --git a/._blk_horse_head.jpg b/._blk_horse_head.jpg new file mode 100644 Binary files /dev/null and b/._blk_horse_head.jpg differ diff --git a/Calculator/.DS_Store b/Calculator/.DS_Store new file mode 100644 Binary files /dev/null and b/Calculator/.DS_Store differ diff --git a/Calculator/._.DS_Store b/Calculator/._.DS_Store new file mode 100644 Binary files /dev/null and b/Calculator/._.DS_Store differ diff --git a/Chapter14_1.hs b/Chapter14_1.hs --- a/Chapter14_1.hs +++ b/Chapter14_1.hs @@ -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) diff --git a/Chapter14_2.hs b/Chapter14_2.hs --- a/Chapter14_2.hs +++ b/Chapter14_2.hs @@ -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 diff --git a/Chapter15/.DS_Store b/Chapter15/.DS_Store new file mode 100644 Binary files /dev/null and b/Chapter15/.DS_Store differ diff --git a/Chapter15/._.DS_Store b/Chapter15/._.DS_Store new file mode 100644 Binary files /dev/null and b/Chapter15/._.DS_Store differ diff --git a/Chapter15/Solutions15.hs b/Chapter15/Solutions15.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Solutions15.hs @@ -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 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). + + + + + + + + + + diff --git a/Chapter16/.DS_Store b/Chapter16/.DS_Store new file mode 100644 Binary files /dev/null and b/Chapter16/.DS_Store differ diff --git a/Chapter16/._.DS_Store b/Chapter16/._.DS_Store new file mode 100644 Binary files /dev/null and b/Chapter16/._.DS_Store differ diff --git a/Chapter16/Solutions16.hs b/Chapter16/Solutions16.hs new file mode 100644 --- /dev/null +++ b/Chapter16/Solutions16.hs @@ -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 Var -> Integer -> StoreS + +updateS [] v n = [(v,n)] + +updateS ((w,m):sto) v n + | w Var -> Maybe Integer + +valueS' [] _ = Nothing + +valueS' ((w,n):sto) v + | w Var -> Bool + +hasVal [] _ = False + +hasVal ((w,n):sto) v + | w 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 (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 + | xa = 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 +-- + + diff --git a/Chapter16/Tree.hs b/Chapter16/Tree.hs --- a/Chapter16/Tree.hs +++ b/Chapter16/Tree.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*> +-- +-- 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 + + diff --git a/Chapter19/Pic.hs b/Chapter19/Pic.hs new file mode 100644 --- /dev/null +++ b/Chapter19/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/Chapter19/Pictures.hs b/Chapter19/Pictures.hs new file mode 100644 --- /dev/null +++ b/Chapter19/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/Chapter19/PositionedImages.hs b/Chapter19/PositionedImages.hs new file mode 100644 --- /dev/null +++ b/Chapter19/PositionedImages.hs @@ -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 \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 + = "\n" ++ + "\n" ++ + "\n" ++ + "\n" + +postamble + = "\n\n" diff --git a/Chapter19/QCfuns.hs b/Chapter19/QCfuns.hs new file mode 100644 --- /dev/null +++ b/Chapter19/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/Chapter19/RegExp.hs b/Chapter19/RegExp.hs --- a/Chapter19/RegExp.hs +++ b/Chapter19/RegExp.hs @@ -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 diff --git a/Chapter19/Solutions19.hs b/Chapter19/Solutions19.hs new file mode 100644 --- /dev/null +++ b/Chapter19/Solutions19.hs @@ -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 ... diff --git a/Chapter2.hs b/Chapter2.hs --- a/Chapter2.hs +++ b/Chapter2.hs @@ -2,7 +2,7 @@ -- -- Haskell: The Craft of Functional Programming -- Simon Thompson --- (c) Addison-Wesley, 2010. +-- (c) Addison-Wesley, 2011. -- -- Chapter 2 -- diff --git a/Chapter8.hs b/Chapter8.hs --- a/Chapter8.hs +++ b/Chapter8.hs @@ -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" -- diff --git a/Craft3e.cabal b/Craft3e.cabal --- a/Craft3e.cabal +++ b/Craft3e.cabal @@ -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-@ . - 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: diff --git a/IO/.DS_Store b/IO/.DS_Store new file mode 100644 Binary files /dev/null and b/IO/.DS_Store differ diff --git a/IO/._.DS_Store b/IO/._.DS_Store new file mode 100644 Binary files /dev/null and b/IO/._.DS_Store differ diff --git a/IO/DoTest.hs b/IO/DoTest.hs new file mode 100644 --- /dev/null +++ b/IO/DoTest.hs @@ -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)) +-- + diff --git a/IO/MonadIO.hs b/IO/MonadIO.hs new file mode 100644 --- /dev/null +++ b/IO/MonadIO.hs @@ -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) + diff --git a/IO/TreeId.hs b/IO/TreeId.hs new file mode 100644 --- /dev/null +++ b/IO/TreeId.hs @@ -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 + diff --git a/IO/TreeState.hs b/IO/TreeState.hs new file mode 100644 --- /dev/null +++ b/IO/TreeState.hs @@ -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)) + diff --git a/LISTING b/LISTING new file mode 100644 --- /dev/null +++ b/LISTING @@ -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: diff --git a/ParseLib.hs b/ParseLib.hs --- a/ParseLib.hs +++ b/ParseLib.hs @@ -128,3 +128,5 @@ sparse :: SParse a b -> Parse a b sparse (SParse pr) = pr + + diff --git a/RPS.hs b/RPS.hs --- a/RPS.hs +++ b/RPS.hs @@ -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 diff --git a/Relation.hs b/Relation.hs --- a/Relation.hs +++ b/Relation.hs @@ -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. -- diff --git a/Set.hs b/Set.hs --- a/Set.hs +++ b/Set.hs @@ -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 diff --git a/Simulation/.DS_Store b/Simulation/.DS_Store new file mode 100644 Binary files /dev/null and b/Simulation/.DS_Store differ diff --git a/Simulation/._.DS_Store b/Simulation/._.DS_Store new file mode 100644 Binary files /dev/null and b/Simulation/._.DS_Store differ diff --git a/Simulation/QueueState.hs b/Simulation/QueueState.hs --- a/Simulation/QueueState.hs +++ b/Simulation/QueueState.hs @@ -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. diff --git a/UsePictures.hs b/UsePictures.hs new file mode 100644 --- /dev/null +++ b/UsePictures.hs @@ -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)) + + + + +