diff --git a/Calculator/CalcEval.hs b/Calculator/CalcEval.hs new file mode 100644 --- /dev/null +++ b/Calculator/CalcEval.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- CalcEval.hs +-- +-- Evaluating expressions and commands +-- +----------------------------------------------------------------------- + + +module CalcEval where + +import CalcTypes +import CalcStore + +eval :: Expr -> Store -> Integer + +eval (Lit n) st = n +eval (Var v) st = value st v +eval (Op op e1 e2) st + = opValue op v1 v2 + where + v1 = eval e1 st + v2 = eval e2 st + +opValue :: Ops -> Integer -> Integer -> Integer + +opValue Add = (+) +opValue Sub = (-) +opValue Mul = (*) +opValue Div = div +opValue Mod = mod + +command :: Command -> Store -> (Integer,Store) + +command Null st = (0 , st) +command (Eval e) st = (eval e st , st) +command (Assign v e) st + = (val , newSt) + where + val = eval e st + newSt = update st v val + diff --git a/Calculator/CalcParse.hs b/Calculator/CalcParse.hs new file mode 100644 --- /dev/null +++ b/Calculator/CalcParse.hs @@ -0,0 +1,144 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- CalcParse.hs +-- +-- Parsing expressions and commands +-- +----------------------------------------------------------------------- + +module CalcParse where + +import Data.Char + +import CalcTypes +import CalcParseLib + +-- A parser for expressions +-- +-- +-- The parser has three components, corresponding to the three +-- clauses in the definition of the syntactic type. +-- +parseExpr :: Parse Char Expr +parseExpr = (litParse `alt` varParse) `alt` opExpParse +-- +-- Spotting variables. +-- +varParse :: Parse Char Expr +varParse = spot isVar `build` Var + +isVar :: Char -> Bool +isVar x = ('a' <= x && x <= 'z') +-- +-- Parsing (fully bracketed) operator applications. +-- +opExpParse + = (token '(' >*> + parseExpr >*> + spot isOp >*> + parseExpr >*> + token ')') + `build` makeExpr + +makeExpr (_,(e1,(bop,(e2,_)))) = Op (charToOp bop) e1 e2 + +isOp :: Char -> Bool +isOp ch = elem ch "+-*/%" + +charToOp :: Char -> Ops +charToOp ch + = case ch of + '+' -> Add + '-' -> Sub + '*' -> Mul + '/' -> Div + '%' -> Mod + +-- +-- A number is a list of digits with an optional ~ at the front. +-- +litParse + = ((optional (token '~')) >*> + (neList (spot isDigit))) + `build` (charListToExpr.join) + where + join = uncurry (++) + +-- Converting strings representing numbers into numbers +-- +charListToExpr :: [Char] -> Expr +charListToExpr = Lit . charListToInt + +charListToInt :: [Char] -> Integer +charListToInt ('~':rest) = - (charListToNat rest) +charListToInt other = charListToNat other + +charListToNat :: [Char] -> Integer +charListToNat [] = 0 +charListToNat (ch:rest) + = charToNat ch * 10^(length rest) + charListToNat rest + +charToNat :: Char -> Integer +charToNat ch = + toInteger $ + if nch < n0 + 10 + then nch - n0 + else n0 + where + nch = fromEnum ch + n0 = fromEnum '0' + +-- +-- The top-level parser +-- +-- the b value is the result to be returned if there's no successful parse +-- otherwise return the result of the first successful parse + +topLevel :: Parse a b -> b -> [a] -> b +topLevel p defaultVal inp + = case results of + [] -> defaultVal + _ -> head results + where + results = [ found | (found,[]) <- p inp ] + +-- A parse for the type of commands. +-- + +parseCommand :: Parse Char Command +parseCommand + = ((parseExpr `build` Eval) + `alt` + (((spot isVar) >*> + (token ':') >*> + parseExpr) `build` makeComm)) + `alt` + endOfInput Null + +makeComm (v,(_,e)) = Assign v e + +-- This is the function which gets used in a top-level interaction..... + +calcLine :: String -> Command + +calcLine = topLevel parseCommand Null +-- + +opExpParseM :: SParse Char Expr + +opExpParseM = + do + tokenM '(' + e1 <- parseExprM + bop <- spotM isOp + e2 <- parseExprM + tokenM ')' + return (Op (charToOp bop) e1 e2) + +tokenM = SParse . token +spotM = SParse . spot +parseExprM = SParse parseExpr diff --git a/Calculator/CalcParseLib.hs b/Calculator/CalcParseLib.hs new file mode 100644 --- /dev/null +++ b/Calculator/CalcParseLib.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- CalcParseLib.hs +-- +-- Library functions for parsing +-- Note that this is not a monadic approach to parsing. +-- +----------------------------------------------------------------------- + + +module CalcParseLib 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 on top of this library + +newtype SParse a b = SParse { sparse :: (Parse a b) } + +instance Monad (SParse a) where + return x = SParse (succeed x) + fail s = SParse none + (SParse pr) >>= f + = SParse (\st -> concat [ sparse (f x) rest | (x,rest) <- pr st ]) diff --git a/Calculator/CalcStore.hs b/Calculator/CalcStore.hs new file mode 100644 --- /dev/null +++ b/Calculator/CalcStore.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- CalcStore.hs +-- +-- An abstract data type of stores of integers, implemented as +-- a list of pairs of variables and values. +-- +----------------------------------------------------------------------- + + + +module CalcStore + ( Store, + initial, -- Store + value, -- Store -> Var -> Integer + update -- Store -> Var -> Integer -> Store + ) where + +import CalcTypes + +-- The implementation is given by a newtype declaration, with one +-- constructor, taking an argument of type [ (Int,Var) ]. + +data Store = Sto [ (Integer,Var) ] + +instance Eq Store where + (Sto sto1) == (Sto sto2) = (sto1 == sto2) + +instance Show Store where + showsPrec n (Sto sto) = showsPrec n sto +-- +initial :: Store + +initial = Sto [] + +value :: Store -> Var -> Integer + +value (Sto []) v = 0 +value (Sto ((n,w):sto)) v + | v==w = n + | otherwise = value (Sto sto) v + +update :: Store -> Var -> Integer -> Store + +update (Sto sto) v n = Sto ((n,v):sto) + diff --git a/Calculator/CalcToplevel.hs b/Calculator/CalcToplevel.hs new file mode 100644 --- /dev/null +++ b/Calculator/CalcToplevel.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- CalcToplevel.hs +-- +-- Top-level interaction loop for a calculator +-- +----------------------------------------------------------------------- + +module CalcToplevel where + +import System.IO + +import CalcTypes +import CalcStore +import CalcParseLib +import CalcParse +import CalcEval + + +calcStep :: Store -> IO Store + +calcStep st + = do line <- getLine + let comm = calcLine line + let (val , newSt) = command comm st + print val + return newSt + + +calcSteps :: Store -> IO () + +calcSteps st = + do + eof <- isEOF + if eof + then return () + else do newSt <- calcStep st + calcSteps newSt + + +mainCalc :: IO () +mainCalc = + do + hSetBuffering stdin LineBuffering + calcSteps initial + hSetBuffering stdin NoBuffering + + + diff --git a/Calculator/CalcTypes.hs b/Calculator/CalcTypes.hs new file mode 100644 --- /dev/null +++ b/Calculator/CalcTypes.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- CalcTypes.hs +-- +-- Types for the calculator +-- +----------------------------------------------------------------------- + + +module CalcTypes where + +data Expr = Lit Integer | Var Var | Op Ops Expr Expr deriving (Eq,Show) + +data Ops = Add | Sub | Mul | Div | Mod deriving (Eq,Show) + +type Var = Char + +data Command = Eval Expr | Assign Var Expr | Null deriving (Eq,Show) + + + diff --git a/Chapter1.hs b/Chapter1.hs new file mode 100644 --- /dev/null +++ b/Chapter1.hs @@ -0,0 +1,74 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 1 +-- +-- The Pictures example code is given in the file Pitures.hs. +-- This file can be used by importing it; more details are given in +-- Chapter 2. +-- +------------------------------------------------------------------------- + +module Chapter1 where +import Pictures hiding (rotate) + +-- A first definition, of the integer value, size. + +size :: Integer +size = 12+13 + +-- Some definitions using Pictures. + +-- Inverting the colour of the horse picture, ... + +blackHorse :: Picture +blackHorse = invertColour horse + +-- ... rotating the horse picture, ... + +rotateHorse :: Picture +rotateHorse = flipH (flipV horse) + +-- Some function definitions. + +-- To square an integer, ... + +square :: Integer -> Integer +square n = n*n + +-- ... to double an integer, and ... + +double :: Integer -> Integer +double n = 2*n + +-- ... to rotate a picture we can perform the two reflections, +-- and so we define + +rotate :: Picture -> Picture +rotate pic = flipH (flipV pic) + +-- A different definition of rotateHorse can use rotate + +rotateHorse1 :: Picture +rotateHorse1 = rotate horse + +-- where the new definition is of a different name: you can't change a definition +-- in a script. + +-- Defining rotate a different way, as a composition of functions; see the +-- diagram in the book for a picture of what's going on. + +rotate1 :: Picture -> Picture +rotate1 = flipH . flipV + +-- Pictures + +-- The definitions of the functions modelling pictures are in the file +-- Pictures.hs. + +-- Tests and properties + +-- The functions test_rotate, prop_rotate etc are in the Pictures.hs module diff --git a/Chapter10.hs b/Chapter10.hs new file mode 100644 --- /dev/null +++ b/Chapter10.hs @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 10 +-- +------------------------------------------------------------------------- + +-- Generalization: patterns of computation +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +module Chapter10 where + +import Prelude hiding (map,filter,zipWith,foldr1,foldr,concat,and) +import Pictures hiding (flipV,beside) +import qualified Chapter7 + +-- Higher-order functions: functions as arguments +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Mapping a function along a list. +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +map,map' :: (a -> b) -> [a] -> [b] + +map' f xs = [ f x | x <- xs ] -- (map.0) + +map f [] = [] -- (map.1) +map f (x:xs) = f x : map f xs -- (map.2) + +-- Examples using map. + +-- Double all the elements of a list ... + +doubleAll :: [Integer] -> [Integer] + +doubleAll xs = map double xs + where + double x = 2*x + +-- ... convert characters to their numeric codes ... + +convertChrs :: [Char] -> [Int] +convertChrs xs = map fromEnum xs + +-- ... flip a Picture in a vertical mirror. + +flipV :: Picture -> Picture +flipV xs = map reverse xs + + +-- Modelling properties as functions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Is an integer even? + +isEven :: Integer -> Bool +isEven n = (n `mod` 2 == 0) + +-- Is a list sorted? + +isSorted :: [Integer] -> Bool +isSorted xs = (xs == iSort xs) + + +-- Filtering -- the filter function +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +filter :: (a -> Bool) -> [a] -> [a] + +filter p [] = [] -- (filter.1) +filter p (x:xs) + | p x = x : filter p xs -- (filter.2) + | otherwise = filter p xs -- (filter.3) + +-- A list comprehension also serves to define filter, + +filter' p xs = [ x | x <- xs , p x ] -- (filter.0) + + +-- Combining zip and map -- the zipWith function +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] + +zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys +zipWith f _ _ = [] + +beside :: Picture -> Picture -> Picture +beside pic1 pic2 = zipWith (++) pic1 pic2 + + +-- Folding and primitive recursion +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Folding an operation into a non-empty list + +foldr1 :: (a -> a -> a) -> [a] -> a + +foldr1 f [x] = x -- (foldr1.1) +foldr1 f (x:xs) = f x (foldr1 f xs) -- (foldr1.2) + +-- Examples using foldr1 + +foldEx1 = foldr1 (+) [3,98,1] +foldEx2 = foldr1 (||) [False,True,False] +foldEx3 = foldr1 (++) ["Freak ", "Out" , "", "!"] +foldEx4 = foldr1 min [6] +foldEx5 = foldr1 (*) [1 .. 6] + +-- Folding into an arbitrary list: using a starting value on the empty list. + +foldr f s [] = s -- (foldr.1) +foldr f s (x:xs) = f x (foldr f s xs) -- (foldr.2) + +-- Concatenating a list using foldr. + +concat :: [[a]] -> [a] +concat xs = foldr (++) [] xs + +-- Conjoining a list of Bool using foldr. + +and :: [Bool] -> Bool +and bs = foldr (&&) True bs + +-- Can define foldr1 using foldr: +-- foldr1 f (x:xs) = foldr f x xs -- (foldr1.0) + + +-- Folding in general -- foldr again +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The type of foldr is more general than you would initially expect... + +foldr :: (a -> b -> b) -> b -> [a] -> b + +rev :: [a] -> [a] +rev xs = foldr snoc [] xs + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + +-- Sorting a list using foldr + +iSort :: [Integer] -> [Integer] +iSort xs = foldr Chapter7.ins [] xs + +-- From the exercises: a mystery function ... + +mystery xs = foldr (++) [] (map sing xs) +sing x = [x] + + +-- Generalizing: splitting up lists +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Getting the first word from the front of a String ... + +getWord :: String -> String +getWord [] = [] -- (getWord.1) +getWord (x:xs) + | elem x Chapter7.whitespace = [] -- (getWord.2) + | otherwise = x : getWord xs -- (getWord.3) + +-- ... which generalizes to a function which gets items from the front of a list +-- until an item has the required property. + +getUntil :: (a -> Bool) -> [a] -> [a] +getUntil p [] = [] +getUntil p (x:xs) + | p x = [] + | otherwise = x : getUntil p xs + +-- The original getWord function defined from getUntil + +-- getWord xs +-- = getUntil p xs +-- where +-- p x = elem x whitespace + diff --git a/Chapter11.hs b/Chapter11.hs new file mode 100644 --- /dev/null +++ b/Chapter11.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 11 +-- +----------------------------------------------------------------------- + + + +-- Functions as values +-- ^^^^^^^^^^^^^^^^^^^ + +module Chapter11 where + +import Prelude hiding (succ,curry,uncurry,flip) +import Chapter10 (getUntil) +import Chapter7 (whitespace) +import Test.QuickCheck + +-- A fixity declaration for the forward composition operator, >.> + +infixl 9 >.> + + +-- Function composition and forward composition +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- A composition operator taking its arguments in the opposite order to `.'. + + +(>.>) :: (a -> b) -> (b -> c) -> (a -> c) + +g >.> f = f . g + + +-- Expressions for functions: lambda abstractions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +addOnes :: [Integer] + +addOnes = map (\x -> x+1) [2,3,4] + + +-- Mapping a list of functions onto a value + +mapFuns :: [a->b] -> a -> [b] + +mapFuns [] x = [] +mapFuns (f:fs) x = f x : mapFuns fs x + +-- Two alternative definitions + +mapFuns1 fs x = map (\f -> f x) fs + +mapFuns2 fs x = map applyToX fs + where + applyToX f = f x + +-- A function returning a function, namely the function to `add n to its +-- argument'. + +addNum :: Integer -> (Integer -> Integer) + +addNum n = (\m -> n+m) + +-- The `plumbing' function: + +comp2 :: (a -> b) -> (b -> b -> c) -> (a -> a -> c) + +comp2 f g = (\x y -> g (f x) (f y)) + +-- Using the `plumbing' function + +plumbingExample = comp2 sq add 3 4 + where + sq x = x*x + add y z = y+z + + +-- Partial Application +-- ^^^^^^^^^^^^^^^^^^^ + +-- The function multiply multiplies together two arguments. + +multiply :: Int -> Int -> Int +multiply x y = x*y + +-- Double all elements of an integer list. + +doubleAll :: [Int] -> [Int] +doubleAll = map (multiply 2) + +-- Another definition of addNum, using partial application to achieve the +-- `function as result'. + +addNum' n m = n+m + +-- Operator Sections + +-- Example of a function defined using partial application and operator sections. + +egFun :: [Int] -> [Int] + +egFun = filter (>0) . map (+1) + + + +-- Three examples from the text processing functions first seen in Chapter 7. + +dropSpace = dropWhile (member whitespace) +dropWord = dropWhile (not . member whitespace) +getWord = takeWhile (not . member whitespace) + +-- Auxiliary definitions ... + +member xs x = elem x xs + +-- Under the hood: curried functions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- An example function of type (Int -> Int) -> Int + +g :: (Int -> Int) -> Int +g h = (h 0) + (h 1) + +-- Currying and uncurrying +-- ^^^^^^^^^^^^^^^^^^^^^^^ + +-- An uncurried function to multiply together the two itegers in a pair. + +multiplyUC :: (Int,Int) -> Int +multiplyUC (x,y) = x*y + +-- Turn an uncurried function into a curried version, + +curry :: ((a,b) -> c) -> (a -> b -> c) +curry g x y = g (x,y) + +-- and vice versa. + +uncurry :: (a -> b -> c) -> ((a,b) -> c) +uncurry f (x,y) = f x y + +-- Zip property + +prop_zip :: [(Integer, Integer)] -> Bool +prop_zip xs = uncurry zip (unzip xs) == xs + +-- Defining higher-order functions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Using the operators + +-- Compose a function with itself: apply it twice, in other words. + +twice :: (a -> a) -> (a -> a) +twice f = (f . f) + +succ :: Int -> Int +succ n = n+1 + +-- We can generalize twice so that we pass a parameter giving the number +-- of times the functional argument is to be composed with itself: + +iter :: Int -> (a -> a) -> (a -> a) + +iter n f + | n>0 = f . iter (n-1) f + | otherwise = id + +-- An alternative definition of iter: + +iter' n f = foldr (.) id (replicate n f) + +-- Using local definitions + +addNum2 :: Integer -> Integer -> Integer + +addNum2 n = addN + where + addN m = n+m + +addNum3 n = let + addN m = n+m + in + addN + +-- Lambda abstractions + +flip' :: (a -> b -> c) -> (b -> a -> c) +flip' f = \x y -> f y x + +-- Change the order of arguments of a two argument curried function. + +flip :: (a -> b -> c) -> (b -> a -> c) +flip f x y = f y x + +-- Mystery function from "Point-free programming" + +puzzle = (.) (.) + +-- Final examples + +-- Double all integers in a list, + +doubleAll' :: [Int] -> [Int] +doubleAll' = map (*2) + +-- get the even numbers in a list of integers, + +getEvens :: [Int] -> [Int] +getEvens = filter ((==0).(`mod` 2)) + +-- get a word from the start of a string. + +getWord' = getUntil (`elem` whitespace) + + + + + +-- Verification and general functions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +prop_mf p f = + \xs -> (filter p . map f) xs == (map f . filter (p . f)) xs diff --git a/Chapter12.hs b/Chapter12.hs new file mode 100644 --- /dev/null +++ b/Chapter12.hs @@ -0,0 +1,189 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 12 +-- +----------------------------------------------------------------------- + +-- For Rock-Paper-Scissors examples see RPS.hs + +module Chapter12 where + +import Pictures hiding (flipH,rotate,flipV,beside,invertColour, + superimpose,printPicture) + + +-- Revisiting the Pictures example, yet again. + +flipV :: Picture -> Picture +flipV = map reverse + +beside :: Picture -> Picture -> Picture +beside = zipWith (++) + + +-- Revisiting the Picture example +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Some of the functions are already (re)defined in this script. +-- Among the other functions mentioned were + +invertColour :: Picture -> Picture +invertColour = map (map invert) + +superimpose :: Picture -> Picture -> Picture +superimpose = zipWith (zipWith combineChar) + +-- The definition of combineChar is left as an exercise: it's a dummy definition +-- here. + +combineChar :: Char -> Char -> Char +combineChar = combineChar + +-- Printing a picture: uses putStr after a newline has been added at the end of +-- every line and the lines are joined into a single string. + +printPicture :: Picture -> IO () +printPicture = putStr . concat . map (++"\n") + +-- Regular expressions + +type RegExp = String -> Bool + +char :: Char -> RegExp + +epsilon = (=="") + +char ch = (==[ch]) + +(|||) :: RegExp -> RegExp -> RegExp + +e1 ||| e2 = + \x -> e1 x || e2 x + +(<*>) :: RegExp -> RegExp -> RegExp + +e1 <*> e2 = + \x -> or [ e1 y && e2 z | (y,z) <- splits x ] + +(<**>) :: RegExp -> RegExp -> RegExp + +e1 <**> e2 = + \x -> or [ e1 y && e2 z | (y,z) <- fsplits x ] + +splits xs = [splitAt n xs | n<-[0..len]] + where + len = length xs + +star :: RegExp -> RegExp + +star p = epsilon ||| (p <**> star p) +-- epsilon ||| (p <*> star p) +-- is OK as long as p can't have epsilon match + +fsplits xs = tail (splits xs) + +-- +-- Case studies: functions as data +-- + +-- Natural numbers as functions. + +type Natural a = (a -> a) -> (a -> a) + +zero, one, two :: Natural a + +zero f = id +one f = f +two f = f.f + +int :: Natural Int -> Int + +int n = n (+1) 0 + +-- sends representation of n to rep. of n+1 + +succ :: Natural a -> Natural a +succ = error "succ" + +-- sends reps. of n and m to rep. of n+m + +plus :: Natural a -> Natural a -> Natural a +plus = error "plus" + +-- sends reps. of n and m to rep. of n*m +times :: Natural a -> Natural a -> Natural a +times = error "times" + +-- Creating an index +-- ^^^^^^^^^^^^^^^^^ + +-- See Index.hs + +-- Development in practice +-- ^^^^^^^^^^^^^^^^^^^^^^^ +-- Defining the .. notation (not executable code). +-- +-- [m .. n] +-- | m>n = [] +-- | otherwise = m : [m+1 .. n] + +-- [1 .. n] +-- | 1>n = [] +-- | otherwise = [1 .. n-1] ++ [n] + +-- A simple palindrome check. + +simplePalCheck :: String -> Bool +simplePalCheck st = (reverse st == st) + +-- The full check + +palCheck = simplePalCheck . clean + +-- where the clean function combines mapping (capitals to smalls) and +-- filtering (removing punctuation) + +clean :: String -> String + +clean = map toSmall . filter notPunct + +toSmall = toSmall -- dummy definition +notPunct = notPunct -- dummy definition + +-- Auxiliary functions + +-- When is one string a subsequence of another? + +subseq :: String -> String -> Bool + +subseq [] _ = True +subseq (_:_) [] = False +subseq (x:xs) (y:ys) + = subseq (x:xs) ys || frontseq (x:xs) (y:ys) + +-- When is one strong a subsequece of another, starting at the front? + +frontseq :: String -> String -> Bool +frontseq [] _ = True +frontseq (_:_) [] = False +frontseq (x:xs) (y:ys) + = (x==y) && frontseq xs ys + + +-- Understanding programs +-- ^^^^^^^^^^^^^^^^^^^^^^ + +mapWhile :: (a -> b) -> (a -> Bool) -> [a] -> [b] + +mapWhile f p [] = [] +mapWhile f p (x:xs) + | p x = f x : mapWhile f p xs + | otherwise = [] + +example1 = mapWhile (2+) (>7) [8,12,7,13,16] + + diff --git a/Chapter13.hs b/Chapter13.hs new file mode 100644 --- /dev/null +++ b/Chapter13.hs @@ -0,0 +1,304 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 13 +-- +----------------------------------------------------------------------- + +module Chapter13 where + +import Data.List +import Chapter5 (Shape(..),area) + +-- Overloading and type classes +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Why overloading? +-- ^^^^^^^^^^^^^^^^ + +-- Testing for membership of a Boolean list. + +elemBool :: Bool -> [Bool] -> Bool + +elemBool x [] = False +elemBool x (y:ys) + = (x == y) || elemBool x ys + +-- Testing for membership of a general list, with the equality function as a +-- parameter. + +elemGen :: (a -> a -> Bool) -> a -> [a] -> Bool + +elemGen eqFun x [] = False +elemGen eqFun x (y:ys) + = (eqFun x y) || elemGen eqFun x ys + + +-- Introducing classes +-- ^^^^^^^^^^^^^^^^^^^ + +-- Definitions of classes cannot be hidden, so the definitions etc. here are not +-- executable. + +-- class Eq a where +-- (==) :: a -> a -> Bool + +-- Functions which use equality +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Testing for three values equal: more general than Int -> Int -> Int -> Bool. + +allEqual :: Eq a => a -> a -> a -> Bool +allEqual m n p = (m==n) && (n==p) + +-- Erroneous expression + +-- error1 = allEqual suc suc suc + +suc = (+1) + +-- elem :: Eq a => a -> [a] -> Bool +-- books :: Eq a => [ (a,b) ] -> a -> [b] + +-- It is easier to see this typing if you remane books lookupFirst: + +lookupFirst :: Eq a => [ (a,b) ] -> a -> [b] + +lookupFirst ws x + = [ z | (y,z) <- ws , y==x ] + +-- borrowed :: Eq b => [ (a,b) ] -> b -> Bool +-- numBorrowed :: Eq a => [ (a,b) ] -> a -> Int + + +-- Signatures and Instances +-- ^^^^^^^^^^^^^^^^^^^^^^^^ + +-- A type is made a member or instance of a class by defining +-- the signature functions for the type. For example, + +-- instance Eq Bool where +-- True == True = True +-- False == False = True +-- _ == _ = False + +-- The Info class: + +class Info a where + examples :: [a] + size :: a -> Int + size _ = 1 + +-- Declaring instances of the Info class + + +instance Info Int where + examples = [-100..100] + --size _ = 1 + +instance Info Char where + examples = ['a','A','z','Z','0','9'] + -- size _ = 1 + +instance Info Bool where + examples = [True,False] + -- size _ = 1 + +-- An instance declaration for a data type. + +instance Info Shape where + examples = [ Circle 3.0, Rectangle 45.9 87.6 ] + size = round . area + + +-- Instance declaration with contexts. + +instance Info a => Info [a] where + examples = [ [] ] ++ [ [x] | x<-examples ] ++ [ [x,y] | x<-examples , y<-examples ] + size = foldr (+) 1 . map size + +instance (Info a,Info b) => Info (a,b) where + examples = [ (x,y) | x<-examples , y<-examples ] + size (x,y) = size x + size y + 1 + + +-- Default definitions +-- ^^^^^^^^^^^^^^^^^^^ + +-- To return to our example of equality, the Haskell equality class is in fact +-- defined by + +-- class Eq a where +-- (==), (/=) :: a -> a -> Bool +-- x /= y = not (x==y) +-- x == y = not (x/=y) + + +-- Derived classes +-- ^^^^^^^^^^^^^^^ + +-- Ordering is built on Eq. + +-- class Eq a => Ord a where +-- (<), (<=), (>), (>=) :: a -> a -> Bool +-- max, min :: a -> a -> a +-- compare :: a -> a -> Ordering + + +-- This is the same definition as in Chapter7, but now with an overloaded type. + +iSort :: Ord a => [a] -> [a] + +iSort [] = [] +iSort (x:xs) = ins x (iSort xs) + +-- To insert an element at the right place into a sorted list. + +ins :: Ord a => a -> [a] -> [a] + +ins x [] = [x] +ins x (y:ys) + | x <= y = x:(y:ys) + | otherwise = y : ins x ys + + +-- Multiple constraints +-- ^^^^^^^^^^^^^^^^^^^^ + +-- Sorting visible objects ... + +vSort :: (Ord a,Show a) => [a] -> String + +vSort = show . iSort + +-- Similarly, + +vLookupFirst :: (Eq a,Show b) => [(a,b)] -> a -> String + +vLookupFirst xs x = show (lookupFirst xs x) + +-- Multiple constraints can occur in an instance declaration, such as + +-- instance (Eq a,Eq b) => Eq (a,b) where +-- (x,y) == (z,w) = x==z && y==w + +-- Multiple constraints can also occur in the definition of a class, + +class (Ord a,Show a) => OrdVis a + +-- Can then give vSort the type: + +-- vSort :: OrdVis a => [a] -> String + +-- InfoCheck. Check a property for all examples + +-- infoCheck :: (Info a) => (a -> Bool) -> Bool + +-- infoCheck property = and (map property examples) + +class Checkable b where + infoCheck :: (Info a) => (a -> b) -> Bool + +instance Checkable Bool where + infoCheck property = and (map property examples) + +instance (Info a, Checkable b) => Checkable (a -> b) where + infoCheck property = and (map (infoCheck.property) examples) + +test0 = infoCheck (\x -> (x <=(0::Int) || x>0)) +test1 = infoCheck (\x y -> (x <=(0::Int) || y <= 0 || x*y >= x)) +test2 = infoCheck (\x y -> (x <=(0::Int) || y <= 0 || x*y > x)) + + + + +-- A tour of the built-in Haskell classes +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- For details of the code here, please see the standard Prelude and Libraries. + + +-- Types and Classes +-- ^^^^^^^^^^^^^^^^^ + +-- The code in this section is not legal Haskell. + +-- To evaluate the type of concat . map show, type + +-- :type concat . map show + +-- to the Hugs prompt. + +-- Type checking and type inference +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +prodFun :: (t -> t1) -> (t -> t2) -> t -> (t1,t2) + +prodFun f g = \x -> (f x, g x) + + + +-- Checking types +-- ^^^^^^^^^^^^^^ + +-- Non-type-correct definitions are included as comments. + +example1 = fromEnum 'c' + 3 + +-- example2 = fromEnum 'c' + False + +-- f n = 37+n +-- f True = 34 + +-- g 0 = 37 +-- g n = True + +-- h x +-- | x>0 = True +-- | otherwise = 37 + +-- k x = 34 +-- k 0 = 35 + + +-- Polymorphic type checking +-- ^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Examples without their types; use Hugs to find them out. + +f (x,y) = (x , ['a' .. y]) + +g (m,zs) = m + length zs + +h = g . f + +expr :: Int +expr = length ([]++[True]) + length ([]++[2,3,4]) + +-- The funny function does not type check. + +-- funny xs = length (xs++[True]) + length (xs++[2,3,4]) + + +-- Type checking and classes +-- ^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Membership on lists + +member :: Eq a => [a] -> a -> Bool + +member [] y = False +member (x:xs) y = (x==y) || member xs y + +-- Merging ordered lists. + +merge (x:xs) (y:ys) + | x Temp + +weather Summer = Hot +weather _ = Cold + +-- The Ordering type, as used in the class Ord. + +-- data Ordering = LT | EQ | GT + +-- Declaring Temp an instance of Eq. + +instance Eq Temp where + Cold == Cold = True + Hot == Hot = True + _ == _ = False + + + +-- Recursive algebraic types +-- ^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Expressions +-- ^^^^^^^^^^^ + +-- Representing an integer expression. + +data Expr = Lit Integer | + Add Expr Expr | + Sub Expr Expr + deriving (Show,Eq) + +-- Three examples from Expr. + +expr1 = Lit 2 +expr2 = Add (Lit 2) (Lit 3) +expr3 = Add (Sub (Lit 3) (Lit 1)) (Lit 3) + +-- Evaluating an expression. + +eval :: Expr -> Integer + +eval (Lit n) = n +eval (Add e1 e2) = (eval e1) + (eval e2) +eval (Sub e1 e2) = (eval e1) - (eval e2) + +-- Showing an expression. + +-- instance Show Expr where +-- +-- show (Lit n) = show n +-- show (Add e1 e2) +-- = "(" ++ show e1 ++ "+" ++ show e2 ++ ")" +-- show (Sub e1 e2) +-- = "(" ++ show e1 ++ "-" ++ show e2 ++ ")" + + +-- Trees of integers +-- ^^^^^^^^^^^^^^^^^ + +-- The type definition. + +data NTree = NilT | + NodeT 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) + +-- 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 + +depth NilT = 0 +depth (NodeT 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 + | n==p = 1 + occurs t1 p + occurs t2 p + | otherwise = occurs t1 p + occurs t2 p + + +-- Rearranging expressions +-- ^^^^^^^^^^^^^^^^^^^^^^^ + +-- Right-associating additions in expressions. + +assoc :: Expr -> Expr + +assoc (Add (Add e1 e2) e3) + = assoc (Add e1 (Add e2 e3)) +assoc (Add e1 e2) + = Add (assoc e1) (assoc e2) +assoc (Sub e1 e2) + = Sub (assoc e1) (assoc e2) +assoc (Lit n) + = Lit n + + +-- Infix constructors +-- ^^^^^^^^^^^^^^^^^^ + +-- An alternative definition of Expr. + +data Expr' = Lit' Integer | + Expr' :+: Expr' | + Expr' :-: Expr' + + + +-- Mutual Recursion +-- ^^^^^^^^^^^^^^^^ + +-- Mutually recursive types ... + +data Person = Adult Name Address Biog | + Child Name +data Biog = Parent String [Person] | + NonParent String + +type Name = String +type Address = [String] + +-- ... and functions. + +showPerson (Adult nm ad bio) + = show nm ++ show ad ++ showBiog bio +showBiog (Parent st perList) + = st ++ concat (map showPerson perList) + +-- Alternative definition of Expr (as used later in the calculator case +-- study. + +-- data Expr = Lit Int | +-- Op Ops Expr Expr + +-- data Ops = Add | Sub | Mul | Div + +-- It is possible to extend the type Expr so that it contains +-- conditional expressions, \texttt{If b e1 e2}. + +-- data Expr = Lit Int | +-- Op Ops Expr Expr | +-- If BExp Expr Expr + +-- Boolean expressions. + +data BExp = BoolLit Bool | + And BExp BExp | + Not BExp | + Equal Expr Expr | + Greater Expr Expr + +-- QuickCheck for algebraic types + +instance Arbitrary NTree where + arbitrary = sized arbNTree + +arbNTree :: Int -> Gen NTree + +arbNTree 0 = return NilT +arbNTree n + | n>0 + = frequency[(1, return NilT), + (3, liftM3 NodeT arbitrary bush bush)] + where + bush = arbNTree (div n 2) + +instance Arbitrary Expr where + arbitrary = sized arbExpr + +arbExpr :: Int -> Gen Expr + +arbExpr 0 = liftM Lit arbitrary +arbExpr n + | n>0 + = frequency[(1, liftM Lit arbitrary), + (2, liftM2 Add bush bush), + (2, liftM2 Sub bush bush)] + where + bush = arbExpr (div n 2) + +prop_assoc :: Expr -> Bool + +prop_assoc expr = + eval expr == eval (assoc expr) + +prop_depth :: NTree -> Bool + +prop_depth t = + size t < 2^(depth t) + +size :: NTree -> Integer + +size NilT = 0 +size (NodeT n t1 t2) = 1 + (size t1) + (depth t2) diff --git a/Chapter14_2.hs b/Chapter14_2.hs new file mode 100644 --- /dev/null +++ b/Chapter14_2.hs @@ -0,0 +1,425 @@ +-------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 14, part 2 +-- Details of the Simulation case study in the Simulation directory. +-- +-------------------------------------------------------------------- + +module Chapter14_2 where + +import Prelude hiding (Either(..),either,Maybe(..),maybe) +import Chapter14_1 hiding (Name) +import Test.QuickCheck +import Control.Monad + +-- Algebraic types, part 2 +-- ^^^^^^^^^^^^^^^^^^^^^^^ + + +-- Polymorphic algebraic types +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- A type of pairs of elements, taken from the same type. + +data Pairs a = Pr a a + +-- and example elements of the type are + +pair1 = Pr 2 3 :: Pairs Int +pair2 = Pr [] [3] :: Pairs [Int] +pair3 = Pr [] [] :: Pairs [a] + +-- Are the two halves equal? + +equalPair :: Eq a => Pairs a -> Bool +equalPair (Pr x y) = (x==y) + + +-- Lists +-- ^^^^^ + +-- Defining lists from scratch (which loses some of the special syntax for +-- lists). + +infixr 5 ::: + +data List a = NilL | a ::: (List a) + deriving (Eq,Ord,Show,Read) + +-- Binary trees +-- ^^^^^^^^^^^^ + + +-- Binary trees carrying elements of an arbitrary type. + +data Tree a = Nil | Node a (Tree a) (Tree a) + deriving (Eq,Ord,Show,Read) + +-- The depth of a binary tree. + +depthT :: Tree a -> Integer +depthT Nil = 0 +depthT (Node n t1 t2) = 1 + max (depthT t1) (depthT t2) + +-- Turning a tree into a list. + +collapse :: Tree a -> [a] +collapse Nil = [] +collapse (Node x t1 t2) + = collapse t1 ++ [x] ++ collapse t2 +-- +-- For example, +-- + +collapseEG + = collapse (Node 12 + (Node 34 Nil Nil) + (Node 3 (Node 17 Nil Nil) Nil)) + +-- Mapping a function over all elements in a tree, preserving the +-- structure. + +mapTree :: (a -> b) -> Tree a -> Tree b +mapTree f Nil = Nil +mapTree f (Node x t1 t2) + = Node (f x) (mapTree f t1) (mapTree f t2) + + +-- The union type, Either +-- ^^^^^^^^^^^^^^^^^^^^^^ + +-- A union type -- defined in the Prelude. + +data Either a b = Left a | Right b + deriving (Eq,Ord,Read,Show) + +-- Examples + +eitherEG1 = Left "Duke of Prunes" :: Either String Int +eitherEG2 = Right 33312 :: Either String Int + +-- In the left or the right? + +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft (Right _) = False + +-- To define a function from Either a b to c we have to deal with two cases, + +either :: (a -> c) -> (b -> c) -> Either a b -> c + +either f g (Left x) = f x +either f g (Right y) = g y + + +-- If we have a function f::a -> cand we wish to apply it to an element +-- of Either a b, there is a problem: what do we do if the element is +-- in the right-hand side of the Either type? A simple answer is to raise an error + +applyLeft :: (a -> c) -> Either a b -> c + +applyLeft f (Left x) = f x +applyLeft f (Right _) = error "applyLeft applied to Right" + +-- Arbitrarily branching trees + +data GTree a = Leaf a | Gnode [GTree a] + + +-- Case study: Program Errors +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- This section explores various ways of handling errors raised in program +-- execution. + +-- \subsection*{Dummy Values} +-- \index{dummy values at errors} + +-- The tail function re-defined to give an empty list when applied to the empty list. + +tl :: [a] -> [a] +tl (_:xs) = xs +tl [] = [] + +-- Zero returned when division by zero, + +divide :: Integer -> Integer -> Integer +divide n m + | (m /= 0) = n `div` m + | otherwise = 0 + +-- Head redefined to give a dummy value on the empty list; the value has +-- to be a parameter. + +hd :: a -> [a] -> a +hd y (x:_) = x +hd y [] = y + +-- Error types +-- ^^^^^^^^^^^ + +-- The Maybe type, as defined in the Prelude.lhs, + +data Maybe a = Nothing | Just a + deriving (Eq,Ord,Read,Show) + +-- An error-raising division function + +errDiv :: Integer -> Integer -> Maybe Integer +errDiv n m + | (m /= 0) = Just (n `div` m) + | otherwise = Nothing + +-- The function mapMaybe transmits an error value though the application of +-- the function g. + +mapMaybe :: (a -> b) -> Maybe a -> Maybe b + +mapMaybe g Nothing = Nothing +mapMaybe g (Just x) = Just (g x) + +-- In trapping an error, we aim to return a result of type b, from an +-- input of type Maybe a; there are two cases to deal with: +-- normal result (Just); error (Nothing). + +maybe :: b -> (a -> b) -> Maybe a -> b + +maybe n f Nothing = n +maybe n f (Just x) = f x + +-- Examples + +handle1, handle2 :: Integer +handle1 = maybe 56 (1+) (mapMaybe (*3) (errDiv 9 0)) +handle2 = maybe 56 (1+) (mapMaybe (*3) (errDiv 9 1)) + +-- Generalising the Maybe type to include an error message in the `Nothing' +-- part. + +data Err a = OK a | Error String + + +-- Design with Algebraic Data Types +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Case study: edit distance +-- ^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- A type to represent the different sorts of Edit operations. + +data Edit = Change Char | + Copy | + Delete | + Insert Char | + Kill + deriving (Eq,Show) + +-- Transforming one string into another, optimally, + +transform :: String -> String -> [Edit] + +transform [] [] = [] +transform xs [] = [Kill] +transform [] ys = map Insert ys +transform (x:xs) (y:ys) + | x==y = Copy : transform xs ys + | otherwise = best [ Delete : transform xs (y:ys) , + Insert y : transform (x:xs) ys , + Change y : transform xs ys ] +-- +-- How do we choose the best sequence? We choose the one with the lowest +-- cost. + +best :: [[Edit]] -> [Edit] + +best [x] = x +best (x:xs) + | cost x <= cost b = x + | otherwise = b + where + b = best xs + +-- The cost is given by charging one for every operation except copy, +-- which is equivalent to `leave unchanged'. + +cost :: [Edit] -> Int + +cost = length . filter (/=Copy) + +-- For testing purposes: does the best actually do the job: need to be +-- able to apply a list of edits to transform a string + +edit :: [Edit] -> String -> String + +edit [] string = string +edit (e:es) [] = + case e of + Insert ch -> ch : edit es [] + Kill -> [] + +edit (e:es) string@(x:xs) = + case e of + Change ch -> ch : edit es xs + Copy -> x : edit es xs + Delete -> edit es xs + Insert ch -> ch : edit es string + Kill -> [] + +-- Simulation +-- ^^^^^^^^^^ + +-- NOTE: details of the Simulation case study are collected separately. + +-- +-- Algebraic types and type classes +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + +-- Movable objects +-- ^^^^^^^^^^^^^^^ + +data Vector = Vec Float Float + +class Movable a where + move :: Vector -> a -> a + reflectX :: a -> a + reflectY :: a -> a + rotate180 :: a -> a + rotate180 = reflectX . reflectY + +data Point = Point Float Float + deriving Show + +instance Movable Point where + move (Vec v1 v2) (Point c1 c2) = Point (c1+v1) (c2+v2) + reflectX (Point c1 c2) = Point c1 (-c2) + reflectY (Point c1 c2) = Point (-c1) c2 + rotate180 (Point c1 c2) = Point (-c1) (-c2) + +data Figure = Line Point Point | + Circle Point Float + deriving Show + +instance Movable Figure where + move v (Line p1 p2) = Line (move v p1) (move v p2) + move v (Circle p r) = Circle (move v p) r + + reflectX (Line p1 p2) = Line (reflectX p1) (reflectX p2) + reflectX (Circle p r) = Circle (reflectX p) r + + reflectY (Line p1 p2) = Line (reflectY p1) (reflectY p2) + reflectY (Circle p r) = Circle (reflectY p) r + +instance Movable a => Movable [a] where + move v = map (move v) + reflectX = map reflectX + reflectY = map reflectY + + +-- Named objects +-- ^^^^^^^^^^^^^ + +-- Named objects: + +class Named a where + lookName :: a -> String + giveName :: String -> a -> a + +-- A named type ... + +data Name a = Pair a String + +-- ... as witnessed by the instance declaration. + +instance Named (Name a) where + lookName (Pair obj nm) = nm + giveName nm (Pair obj _) = (Pair obj nm) + +-- Putting together classes +-- ^^^^^^^^^^^^^^^^^^^^^^^^ + +-- See the text for details of what is going on here. + +mapName :: (a -> b) -> Name a -> Name b + +mapName f (Pair obj nm) = Pair (f obj) nm + +instance Movable a => Movable (Name a) where + move v = mapName (move v) + reflectX = mapName reflectX + reflectY = mapName reflectY + +class (Movable b, Named b) => NamedMovable b + +instance Movable a => NamedMovable (Name a) + + + + +-- Reasoning about algebraic types +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The functions discussed here are all defined elsewhere. + + +-- QuickCheck for algebraic types + +instance Arbitrary a => Arbitrary (Tree a) where + arbitrary = sized arbTree + +arbTree :: Arbitrary a => Int -> Gen (Tree a) + +arbTree 0 = return Nil +arbTree n + | n>0 + = frequency[(1, return Nil), + (3, liftM3 Node arbitrary bush bush)] + where + bush = arbTree (div n 2) + +-- collapse, map and mapTree + +prop_collapse :: Eq b => (a -> b) -> Tree a -> Bool + +prop_collapse f = + \t -> map f (collapse t) == collapse (mapTree f t) + +-- two different ways of measuring the size of a tree + +prop_sizeT :: Tree a -> Bool + +prop_sizeT t = + sizeT t == (leavesT t) + length (collapse t) + +-- functions used above: count the number of leaves +-- and the overall size of the tree ... + +leavesT :: Tree a -> Int + +leavesT Nil = 1 +leavesT (Node _ t1 t2) = leavesT t1 + leavesT t2 + +sizeT :: Tree a -> Int + +sizeT Nil = 1 +sizeT (Node _ t1 t2) = 1 + sizeT t1 + sizeT t2 + +-- edit distance + +-- does the transform actually do the right transformation? + +prop_transform :: String -> String -> Property + +prop_transform xs ys = + length (xs++ys) <= 15 ==> edit (transform xs ys) xs == ys + +-- is it short enough? + +prop_transformLength :: String -> String -> Property + +prop_transformLength xs ys = + length (xs++ys) <= 15 ==> cost (transform xs ys) <= length ys + 1 diff --git a/Chapter15/Ant.hs b/Chapter15/Ant.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Ant.hs @@ -0,0 +1,9 @@ +module Ant where + +type Ants = Int + +anteater :: Int -> Int + +anteater x = x+1 + +aardvark = anteater diff --git a/Chapter15/Bee.hs b/Chapter15/Bee.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Bee.hs @@ -0,0 +1,9 @@ +module Bee where + +import Ant hiding ( anteater ) +import qualified Ant + +honeyEater = Ant.anteater + +beekeeper y = honeyEater y + 1 + diff --git a/Chapter15/CodeTable.hs b/Chapter15/CodeTable.hs new file mode 100644 --- /dev/null +++ b/Chapter15/CodeTable.hs @@ -0,0 +1,73 @@ +------------------------------------------------------------------------- +-- +-- CodeTable.hs +-- +-- Converting a Huffman tree to a ord table. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module CodeTable ( codeTable ) where + +import Types ( Tree(Leaf,Node), Bit(L,R), HCode, Table ) + +-- Making a table from a Huffman tree. + +codeTable :: Tree -> Table + +codeTable = convert [] + +-- Auxiliary function used in conversion to a table. The first argument is +-- the HCode which codes the path in the tree to the current Node, and so +-- codeTable is initialised with an empty such sequence. + +convert :: HCode -> Tree -> Table + +convert cd (Leaf c n) = [(c,cd)] +convert cd (Node n t1 t2) + = (convert (cd++[L]) t1) ++ (convert (cd++[R]) t2) + + +-- Show functions +-- ^^^^^^^^^^^^^^ + +-- Show a tree, using indentation to show structure. +-- +showTree :: Tree -> String + +showTree t = showTreeIndent 0 t + +-- The auxiliary function showTreeIndent has a second, current +-- level of indentation, as a parameter. + +showTreeIndent :: Int -> Tree -> String + +showTreeIndent m (Leaf c n) + = spaces m ++ show c ++ " " ++ show n ++ "\n" +showTreeIndent m (Node n t1 t2) + = showTreeIndent (m+4) t1 ++ + spaces m ++ "[" ++ show n ++ "]" ++ "\n" ++ + showTreeIndent (m+4) t2 + +-- A String of n spaces. + +spaces :: Int -> String + +spaces n = replicate n ' ' + +-- To show a sequence of Bits. + +showCode :: HCode -> String +showCode = map conv + where + conv R = 'R' + conv L = 'L' + +-- To show a table of codes. + +showTable :: Table -> String +showTable + = concat . map showPair + where + showPair (ch,co) = [ch] ++ " " ++ showCode co ++ "\n" diff --git a/Chapter15/Coding.hs b/Chapter15/Coding.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Coding.hs @@ -0,0 +1,55 @@ +------------------------------------------------------------------------- +-- +-- Coding.hs +-- +-- Huffman coding in Haskell. +-- The top-level functions for coding and decoding. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module Coding ( codeMessage , decodeMessage ) where + +import Types ( Tree(Leaf,Node), Bit(L,R), HCode, Table ) + +-- Code a message according to a table of codes. + +codeMessage :: Table -> [Char] -> HCode + +codeMessage tbl = concat . map (lookupTable tbl) + +-- lookupTable looks up the meaning of an individual char in +-- a Table. + +lookupTable :: Table -> Char -> HCode + +lookupTable [] c = error "lookupTable" +lookupTable ((ch,n):tb) c + | (ch==c) = n + | otherwise = lookupTable tb c + + +-- Decode a message according to a tree. +-- +-- The first tree arguent is constant, being the tree of codes; +-- the second represents the current position in the tree relative +-- to the (partial) HCode read so far. + + +decodeMessage :: Tree -> HCode -> String + +decodeMessage tr + = decodeByt tr + where + + decodeByt (Node n t1 t2) (L:rest) + = decodeByt t1 rest + + decodeByt (Node n t1 t2) (R:rest) + = decodeByt t2 rest + + decodeByt (Leaf c n) rest + = c : decodeByt tr rest + + decodeByt t [] = [] diff --git a/Chapter15/Cow.hs b/Chapter15/Cow.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Cow.hs @@ -0,0 +1,5 @@ +module Cow where + +import Bee + +fish = honeyEater diff --git a/Chapter15/Doe.hs b/Chapter15/Doe.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Doe.hs @@ -0,0 +1,7 @@ +module Doe where + + maxD x y + | x>y = x + + maxD x y + = y diff --git a/Chapter15/Frequency.hs b/Chapter15/Frequency.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Frequency.hs @@ -0,0 +1,85 @@ +------------------------------------------------------------------------- +-- +-- Frequency.hs +-- +-- Calculating the frequencies of words in a text, used in +-- Huffman coding. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module Frequency ( frequency ) where + +import Test.QuickCheck hiding ( frequency ) + +-- Calculate the frequencies of characters in a list. +-- +-- This is done by sorting, then counting the number of +-- repetitions. The counting is made part of the merge +-- operation in a merge sort. + +frequency :: [Char] -> [ (Char,Int) ] + +frequency + = mergeSort freqMerge . mergeSort alphaMerge . map start + where + start ch = (ch,1) + +-- Merge sort parametrised on the merge operation. This is more +-- general than parametrising on the ordering operation, since +-- it permits amalgamation of elements with equal keys +-- for instance. +-- +mergeSort :: ([a]->[a]->[a]) -> [a] -> [a] + +mergeSort merge xs + | length xs < 2 = xs + | otherwise + = merge (mergeSort merge first) + (mergeSort merge second) + where + first = take half xs + second = drop half xs + half = (length xs) `div` 2 + +-- Order on first entry of pairs, with +-- accumulation of the numeric entries when equal first entry. + +alphaMerge :: [(Char,Int)] -> [(Char,Int)] -> [(Char,Int)] + +alphaMerge xs [] = xs +alphaMerge [] ys = ys +alphaMerge ((p,n):xs) ((q,m):ys) + | (p==q) = (p,n+m) : alphaMerge xs ys + | (p [(Char,Int)] -> [(Char,Int)] + +freqMerge xs [] = xs +freqMerge [] ys = ys +freqMerge ((p,n):xs) ((q,m):ys) + | (n Bool + +prop_mergeSort xs = + sorted (mergeSort merge xs) + where + sorted [] = True + sorted [_] = True + sorted (x:y:ys) = x<=y && sorted (y:ys) + + merge [] xs = xs + merge ys [] = ys + merge (x:xs) (y:ys) + | x<=y = x: merge xs (y:ys) + | otherwise = y: merge (x:xs) ys diff --git a/Chapter15/Main.hs b/Chapter15/Main.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Main.hs @@ -0,0 +1,50 @@ +------------------------------------------------------------------------- +-- +-- Main.hs +-- +-- The main module of the Huffman example +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +-- The main module of the Huffman example + +module Main (main, codeMessage, decodeMessage, codes, codeTable ) where + +import Types ( Tree(Leaf,Node), Bit(L,R), HCode , Table ) +import Coding ( codeMessage, decodeMessage ) +import MakeCode ( codes, codeTable ) + + +main = print decoded + + +-- Examples +-- ^^^^^^^^ + +-- The coding table generated from the text "there is a green hill". + +tableEx :: Table +tableEx = codeTable (codes "there is a green hill") + +-- The Huffman tree generated from the text "there is a green hill", +-- from which tableEx is produced by applying codeTable. + +treeEx :: Tree +treeEx = codes "there is a green hill" + +-- A message to be coded. + +message :: String +message = "there are green hills here" + +-- The message in code. + +coded :: HCode +coded = codeMessage tableEx message + +-- The coded message decoded. + +decoded :: String +decoded = decodeMessage treeEx coded diff --git a/Chapter15/MakeCode.hs b/Chapter15/MakeCode.hs new file mode 100644 --- /dev/null +++ b/Chapter15/MakeCode.hs @@ -0,0 +1,23 @@ +------------------------------------------------------------------------- +-- +-- MakeCode.hs +-- +-- Huffman coding in Haskell. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module MakeCode ( codes, codeTable ) where + +import Types +import Frequency ( frequency ) +import MakeTree ( makeTree ) +import CodeTable ( codeTable ) + +-- Putting together frequency calculation and tree conversion + +codes :: [Char] -> Tree + +codes = makeTree . frequency + diff --git a/Chapter15/MakeTree.hs b/Chapter15/MakeTree.hs new file mode 100644 --- /dev/null +++ b/Chapter15/MakeTree.hs @@ -0,0 +1,70 @@ +------------------------------------------------------------------------- +-- +-- MakeTree.hs +-- +-- Turn a frequency table into a Huffman tree +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module MakeTree ( makeTree ) where + +import Types ( Tree(Leaf,Node), Bit(L,R), HCode, Table ) + +-- Convert the trees to a list, then amalgamate into a single +-- tree. + +makeTree :: [ (Char,Int) ] -> Tree + +makeTree = makeCodes . toTreeList + +-- Huffman codes are created bottom up: look for the least +-- two frequent letters, make these a new "isAlpha" (i.e. tree) +-- and repeat until one tree formed. + +-- The function toTreeList makes the initial data structure. + +toTreeList :: [ (Char,Int) ] -> [ Tree ] + +toTreeList = map (uncurry Leaf) + +-- The value of a tree. + +value :: Tree -> Int + +value (Leaf _ n) = n +value (Node n _ _) = n + +-- Pair two trees. + +pair :: Tree -> Tree -> Tree + +pair t1 t2 = Node (v1+v2) t1 t2 + where + v1 = value t1 + v2 = value t2 + +-- Insert a tree in a list of trees sorted by ascending value. + +insTree :: Tree -> [Tree] -> [Tree] + +insTree t [] = [t] +insTree t (t1:ts) + | (value t <= value t1) = t:t1:ts + | otherwise = t1 : insTree t ts +-- +-- Amalgamate the front two elements of the list of trees. + +amalgamate :: [ Tree ] -> [ Tree ] + +amalgamate ( t1 : t2 : ts ) + = insTree (pair t1 t2) ts + +-- Make codes: amalgamate the whole list. + +makeCodes :: [Tree] -> Tree + +makeCodes [t] = t +makeCodes ts = makeCodes (amalgamate ts) + diff --git a/Chapter15/Test.hs b/Chapter15/Test.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Test.hs @@ -0,0 +1,34 @@ +------------------------------------------------------------------------- +-- +-- Test.hs +-- +-- The test module of the Huffman example +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module Test where + +-- The test module of the Huffman example + +import Main +import Test.QuickCheck +import Data.List ( nub ) + + +-- QuickCheck testing + +checkInverse :: String -> Bool + +checkInverse string = + decodeMessage tree (codeMessage table string) == string + where + tree = codes string + table = codeTable tree + +-- prop_Hufmann :: String -> Bool + +prop_Hufmann string = + (length (nub string) > 1) ==> checkInverse string + diff --git a/Chapter15/Types.hs b/Chapter15/Types.hs new file mode 100644 --- /dev/null +++ b/Chapter15/Types.hs @@ -0,0 +1,29 @@ +------------------------------------------------------------------------- +-- +-- Types.hs +-- +-- The types used in the Huffman coding example. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +-- The interface to the module Types is written out +-- explicitly here, after the module name. + +module Types ( Tree(Leaf,Node), Bit(L,R), + HCode , Table ) where + +-- Trees to represent the relative frequencies of characters +-- and therefore the Huffman codes. + +data Tree = Leaf Char Int | Node Int Tree Tree + +-- The types of bits, Huffman codes and tables of Huffman codes. + +data Bit = L | R deriving (Eq,Show) + +type HCode = [Bit] + +type Table = [ (Char,HCode) ] + diff --git a/Chapter16/QCStoreTest.hs b/Chapter16/QCStoreTest.hs new file mode 100644 --- /dev/null +++ b/Chapter16/QCStoreTest.hs @@ -0,0 +1,29 @@ +------------------------------------------------------------------------- +-- +-- QCStoreTest.hs +-- +-- QuickCheck tests for stores. -- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + + +module QCStoreTest where + +import StoreTest +import Test.QuickCheck + +prop_Update1 :: Char -> Integer -> Store -> Bool + +prop_Update1 ch int st = + value (update st ch int) ch == int + +prop_Update2 :: Char -> Char -> Integer -> Store -> Bool + +prop_Update2 ch1 ch2 int st = + ch1 == ch2 || value (update st ch2 int) ch1 == value st ch1 + +prop_Initial :: Char -> Bool + +prop_Initial ch = + value initial ch == 0 diff --git a/Chapter16/Queues1.hs b/Chapter16/Queues1.hs new file mode 100644 --- /dev/null +++ b/Chapter16/Queues1.hs @@ -0,0 +1,41 @@ +------------------------------------------------------------------------- +-- +-- Queues1.hs +-- +-- An abstract data type of queues, implemented as a list, with +-- new elements added at the end of the list. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + + +module Queues1 + ( Queue , + emptyQ , -- Queue a + isEmptyQ , -- Queue a -> Bool + addQ , -- a -> Queue a -> Queue a + remQ -- Queue a -> ( a , Queue a ) + ) where + +newtype Queue a = Queue [a] +-- +emptyQ :: Queue a + +emptyQ = Queue [] + +isEmptyQ :: Queue a -> Bool + +isEmptyQ (Queue []) = True +isEmptyQ _ = False + +addQ :: a -> Queue a -> Queue a + +addQ x (Queue xs) = Queue (xs++[x]) + +remQ :: Queue a -> ( a , Queue a ) + +remQ q@(Queue xs) + | not (isEmptyQ q) = (head xs , Queue (tail xs)) + | otherwise = error "remQ" + diff --git a/Chapter16/Queues2.hs b/Chapter16/Queues2.hs new file mode 100644 --- /dev/null +++ b/Chapter16/Queues2.hs @@ -0,0 +1,40 @@ +------------------------------------------------------------------------- +-- +-- Queues2.hs +-- +-- An abstract data type of queues, implemnted as a list, with +-- new elements added at the beginning of the list. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module Queues2 + ( Queue , + emptyQ , -- Queue a + isEmptyQ , -- Queue a -> Bool + addQ , -- a -> Queue a -> Queue a + remQ -- Queue a -> ( a , Queue a ) + ) where + +newtype Queue a = Queue [a] +-- +emptyQ :: Queue a + +emptyQ = Queue [] + +isEmptyQ :: Queue a -> Bool + +isEmptyQ (Queue []) = True +isEmptyQ _ = False + +addQ :: a -> Queue a -> Queue a + +addQ x (Queue xs) = Queue (x:xs) + +remQ :: Queue a -> ( a , Queue a ) + +remQ q@(Queue xs) + | not (isEmptyQ q) = (last xs , Queue (init xs)) + | otherwise = error "remQ" + diff --git a/Chapter16/Queues3.hs b/Chapter16/Queues3.hs new file mode 100644 --- /dev/null +++ b/Chapter16/Queues3.hs @@ -0,0 +1,40 @@ +------------------------------------------------------------------------- +-- +-- Queues3.hs +-- +-- An abstract data type of queues, implemnted as two lists, with +-- new elements added at the beginning of the second list. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module Queues3 + ( Queue , + emptyQ , -- Queue a + isEmptyQ , -- Queue a -> Bool + addQ , -- a -> Queue a -> Queue a + remQ -- Queue a -> ( a , Queue a ) + ) where + +data Queue a = Queue [a] [a] + +emptyQ :: Queue a + +emptyQ = Queue [] [] + +isEmptyQ :: Queue a -> Bool + +isEmptyQ (Queue [] []) = True +isEmptyQ _ = False + +addQ :: a -> Queue a -> Queue a + +addQ x (Queue xs ys) = Queue xs (x:ys) + +remQ :: Queue a -> ( a , Queue a ) + +remQ (Queue (x:xs) ys) = (x , Queue xs ys) +remQ (Queue [] ys@(z:zs)) = remQ (Queue (reverse ys) []) +remQ (Queue [] []) = error "remQ" + diff --git a/Chapter16/Store.hs b/Chapter16/Store.hs new file mode 100644 --- /dev/null +++ b/Chapter16/Store.hs @@ -0,0 +1,48 @@ +------------------------------------------------------------------------- +-- +-- Store.hs +-- +-- An abstract data type of stores of integers, implemented as +-- a list of pairs of variables and values. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module Store + ( Store, + initial, -- Store + value, -- Store -> Var -> Integer + update -- Store -> Var -> Integer -> Store + ) where + +-- Var is the type of variables. + +type Var = Char + +-- The implementation is given by a newtype declaration, with one +-- constructor, taking an argument of type [ (Integer,Var) ]. + +data Store = Store [ (Integer,Var) ] + +instance Eq Store where + (Store sto1) == (Store sto2) = (sto1 == sto2) + +instance Show Store where + showsPrec n (Store sto) = showsPrec n sto +-- +initial :: Store + +initial = Store [] + +value :: Store -> Var -> Integer + +value (Store []) v = 0 +value (Store ((n,w):sto)) v + | v==w = n + | otherwise = value (Store sto) v + +update :: Store -> Var -> Integer -> Store + +update (Store sto) v n = Store ((n,v):sto) + diff --git a/Chapter16/StoreFun.hs b/Chapter16/StoreFun.hs new file mode 100644 --- /dev/null +++ b/Chapter16/StoreFun.hs @@ -0,0 +1,42 @@ +------------------------------------------------------------------------- +-- +-- StoreFun.hs +-- +-- An abstract data type of stores of integers, implemented as functions. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + + +-- An alternative implementation of Store.hs. Note that although +-- it is equivalent to the list implementation as far as the operations +-- initial, value, update are concerned, it is not possible to compare for +-- equality or to show as a String. + +module StoreFun + ( Store, + initial, -- Store + value, -- Store -> Var -> Integer + update -- Store -> Var -> Integer -> Store + ) where + +-- Var is the type of variables. + +type Var = Char + +newtype Store = Store (Var -> Integer) +-- +initial :: Store + +initial = Store (\v -> 0) + +value :: Store -> Var -> Integer + +value (Store sto) v = sto v + +update :: Store -> Var -> Integer -> Store + +update (Store sto) v n + = Store (\w -> if v==w then n else sto w) + diff --git a/Chapter16/StoreTest.hs b/Chapter16/StoreTest.hs new file mode 100644 --- /dev/null +++ b/Chapter16/StoreTest.hs @@ -0,0 +1,64 @@ +------------------------------------------------------------------------- +-- +-- StoreTest.hs +-- +-- An abstract data type of stores of integers, together with +-- QuickCheck generator. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + + +module StoreTest + ( Store, + initial, -- Store + value, -- Store -> Var -> Integer + update -- Store -> Var -> Integer -> Store + ) where + +import Test.QuickCheck + +-- Var is the type of variables. + +type Var = Char + +-- The implementation is given by a newtype declaration, with one +-- constructor, taking an argument of type [ (Integer,Var) ]. + +data Store = Store [ (Integer,Var) ] + +instance Eq Store where + (Store sto1) == (Store sto2) = (sto1 == sto2) + +instance Show Store where + showsPrec n (Store sto) = showsPrec n sto +-- +initial :: Store + +initial = Store [] + +value :: Store -> Var -> Integer + +value (Store []) v = 0 +value (Store ((n,w):sto)) v + | v==w = n + | otherwise = value (Store sto) v + +update :: Store -> Var -> Integer -> Store + +update (Store sto) v n = Store ((n,v):sto) + +-- QuickCheck stuff + +instance Arbitrary Store where + arbitrary = do + list <- listOf element + return $ Store list + where + element = + do + n <- arbitrary + v <- elements ['a'..'z'] + return (n,v) + diff --git a/Chapter16/Tree.hs b/Chapter16/Tree.hs new file mode 100644 --- /dev/null +++ b/Chapter16/Tree.hs @@ -0,0 +1,95 @@ +------------------------------------------------------------------------- +-- +-- Tree.hs +-- +-- Search trees as an ADT +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + +module Tree + (Tree, + nil, -- Tree a + isNil, -- Tree a -> Bool + isNode, -- Tree a -> Bool + leftSub, -- Tree a -> Tree a + rightSub, -- Tree a -> Tree a + 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 + ) where + +data Tree a = Nil | Node a (Tree a) (Tree a) +-- + +nil :: Tree a + +nil = Nil + +isNil :: Tree a -> Bool +isNil Nil = True +isNil _ = False + +isNode :: Tree a -> Bool +isNode Nil = False +isNode _ = True + +leftSub, rightSub :: Tree a -> Tree a + +leftSub Nil = error "leftSub" +leftSub (Node _ t1 _) = t1 + +rightSub Nil = error "rightSub" +rightSub (Node v t1 t2) = t2 + +treeVal :: Tree a -> a + +treeVal Nil = error "treeVal" +treeVal (Node v _ _) = v + +insTree :: Ord a => a -> Tree a -> Tree a + +insTree val Nil = (Node val Nil Nil) + +insTree val (Node v t1 t2) + | v==val = Node v t1 t2 + | val > v = Node v t1 (insTree val t2) + | val < v = Node v (insTree val t1) t2 + +delete :: Ord a => a -> Tree a -> Tree a + +delete val (Node v t1 t2) + | val < v = Node v (delete val t1) t2 + | val > v = Node v t1 (delete val t2) + | isNil t2 = t1 + | isNil t1 = t2 + | otherwise = join t1 t2 + + +minTree :: Ord a => Tree a -> Maybe a + +minTree t + | isNil t = Nothing + | isNil t1 = Just v + | otherwise = minTree t1 + where + t1 = leftSub t + v = treeVal t + + +-- The join function is an auxiliary, used in delete, where note that it +-- joins two trees with the property that all elements in the left are +-- smaller than all in the right; that will be the case for the call in +-- delete. + +-- join is not exported. + +join :: Ord a => Tree a -> Tree a -> Tree a + +join t1 t2 + = Node mini t1 newt + where + (Just mini) = minTree t2 + newt = delete mini t2 diff --git a/Chapter16/UseStore.hs b/Chapter16/UseStore.hs new file mode 100644 --- /dev/null +++ b/Chapter16/UseStore.hs @@ -0,0 +1,37 @@ +------------------------------------------------------------------------- +-- +-- UseStore.hs +-- +-- Using the abstract data type Store of stores of integers. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + + +module UseStore where + +import Store + +-- Testing the exported definitions of the show and equality. + +exam1 = show initial + +exam2 = (initial == initial) + +-- Can you check a Store against its representation? You need to uncomment +-- the definition before you use it. + +-- checkAbs = (initial == Store []) + +-- A complex store. + +store3 = update (update (update initial 'a' 4) 'b' 5) 'a' 3 + +-- Show the store3. + +exam3 = show store3 + +-- Lookup 'a' in store3; can see that 'a' has the value 3 rather than 4. + +exam4 = value store3 'a' diff --git a/Chapter16/UseStoreFun.hs b/Chapter16/UseStoreFun.hs new file mode 100644 --- /dev/null +++ b/Chapter16/UseStoreFun.hs @@ -0,0 +1,23 @@ +------------------------------------------------------------------------- +-- +-- UseStoreFun.hs +-- +-- Using an abstract data type StoreFun of stores of integers. +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + + + +module UseStoreFun where + +import StoreFun + +-- A complex store. + +store = update (update (update initial 'a' 4) 'b' 5) 'a' 3 + +-- Lookup 'a' in store3; can see that 'a' has the value 3 rather than 4. + +find = value store 'a' diff --git a/Chapter16/UseTree.hs b/Chapter16/UseTree.hs new file mode 100644 --- /dev/null +++ b/Chapter16/UseTree.hs @@ -0,0 +1,42 @@ +------------------------------------------------------------------------- +-- +-- UseTree.hs +-- +-- Using the search tree ADT +-- +-- (c) Addison-Wesley, 1996-2011. +-- +------------------------------------------------------------------------- + + + +module UseTree where + +import Tree +-- +-- The size function definable using the operations of the +-- abstype. +-- + +size :: Tree a -> Integer +size t + | isNil t = 0 + | otherwise = 1 + size (leftSub t) + size (rightSub t) + +-- +-- Finding the nth element of a tree. +-- + +indexT :: Integer -> Tree a -> a + +indexT n t + | isNil t = error "indexT" + | n < st1 = indexT n t1 + | n == st1 = v + | otherwise = indexT (n-st1-1) t2 + where + v = treeVal t + t1 = leftSub t + t2 = rightSub t + st1 = size t1 + diff --git a/Chapter17.hs b/Chapter17.hs new file mode 100644 --- /dev/null +++ b/Chapter17.hs @@ -0,0 +1,426 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 17 +-- +-- Lazy programming. +-- +------------------------------------------------------------------------- + + +-- Lazy programming +-- ^^^^^^^^^^^^^^^^ + +module Chapter17 where + +import Data.List ((\\)) +import Chapter13 (iSort) -- for iSort +import Set -- for Relation +import Relation -- for graphs + +-- Lazy evaluation +-- ^^^^^^^^^^^^^^^ + +-- Some example functions illustrating aspects of laziness. + +f x y = x+y + +g x y = x+12 + +switch :: Int -> a -> a -> a +switch n x y + | n>0 = x + | otherwise = y + +h x y = x+x + +pm (x,y) = x+1 + + +-- Calculation rules and lazy evaluation +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Some more examples. + +f1 :: [Int] -> [Int] -> Int +f1 [] ys = 0 +f1 (x:xs) [] = 0 +f1 (x:xs) (y:ys) = x+y + +f2 :: Int -> Int -> Int -> Int +f2 m n p + | m>=n && m>=p = m + | n>=m && n>=p = n + | otherwise = p + +f3 :: Int -> Int -> Int + +f3 a b + | notNil xs = front xs + | otherwise = b + where + xs = [a .. b] + +front (x:y:zs) = x+y +front [x] = x + +notNil [] = False +notNil (_:_) = True + + + +-- List comprehensions revisited +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Simpler examples +-- ^^^^^^^^^^^^^^^^ + +-- All pairs formed from elements of two lists + +pairs :: [a] -> [b] -> [(a,b)] +pairs xs ys = [ (x,y) | x<-xs , y<-ys ] + +pairEg = pairs [1,2,3] [4,5] + +-- Illustrating the order in which elements are chosen in multiple +-- generators. + +triangle :: Int -> [(Int,Int)] +triangle n = [ (x,y) | x <- [1 .. n] , y <- [1 .. x] ] + +-- Pythagorean triples + +pyTriple n + = [ (x,y,z) | x <- [2 .. n] , y <- [x+1 .. n] , + z <- [y+1 .. n] , x*x + y*y == z*z ] + + +-- Calculating with list comprehensions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The running example from this section. + +runningExample = [ x+y | x <- [1,2] , isEven x , y <- [x .. 2*x] ] + +isEven :: Int -> Bool +isEven n = (n `mod` 2 == 0) + + +-- List permutations +-- ^^^^^^^^^^^^^^^^^ + + +-- One definition of the list of all permutations. + +perms :: Eq a => [a] -> [[a]] + +perms [] = [[]] +perms xs = [ x:ps | x <- xs , ps <- perms (xs\\[x]) ] + +-- Another algorithm for permutations + +perm :: [a] -> [[a]] + +perm [] = [[]] +perm (x:xs) = [ ps++[x]++qs | rs <- perm xs , + (ps,qs) <- splits rs ] + +-- All the splits of a list into two halves. + +splits :: [a]->[([a],[a])] + +splits [] = [ ([],[]) ] +splits (y:ys) = ([],y:ys) : [ (y:ps,qs) | (ps,qs) <- splits ys] + + + +-- Vectors and Matrices +-- ^^^^^^^^^^^^^^^^^^^^ + + +-- A vector is a sequence of real numbers, + +type Vector = [Float] + +-- and the scalar product of two vectors. + +scalarProduct :: Vector -> Vector -> Float +scalarProduct xs ys = sum [ x*y | (x,y) <- zip xs ys ] + +-- The type of matrices. + +type Matrix = [Vector] + +-- and matrix product. + +matrixProduct :: Matrix -> Matrix -> Matrix +matrixProduct m p + = [ [scalarProduct r c | c <- columns p] | r <- m ] + +-- where the function columns gives the representation of a matrix as a +-- list of columns. + +columns :: Matrix -> Matrix + +columns y = [ [ z!!j | z <- y ] | j <- [0 .. s] ] + where + s = length (head y)-1 + + +-- Refutable patterns: an example +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +refPattEx = [ x | (x:xs) <- [[],[2],[],[4,5]] ] + + + +-- Data-directed programming +-- ^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Summing fourth powers of numbers up to n. + +sumFourthPowers :: Int -> Int +sumFourthPowers n = sum (map (^4) [1 .. n]) + +-- List minimum: take the head of the sorted list. Only makes sense in an +-- lazy context. + +minList :: [Int] -> Int + +minList = head . iSort + +-- Example: routes through a graph +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- A example graph. + +graphEx = makeSet [(1,2),(1,3),(2,4),(3,5),(5,6),(3,6)] + +-- Look for all paths from one point to another. (Assumes the graph is acyclic.) + +routes :: Ord a => Relation a -> a -> a -> [[a]] + +routes rel x y + | x==y = [[x]] + | otherwise = [ x:r | z <- nbhrs rel x , + r <- routes rel z y ] +-- +-- The neighbours of a point in a graph. + +nbhrs :: Ord a => Relation a -> a -> [a] +nbhrs rel x = flatten (image rel x) + +-- Example evaluations + +routeEx1 = routes graphEx 1 4 + +routeEx2 = routes graphEx 1 6 + +-- Accommodating cyclic graphs. + +routesC :: Ord a => Relation a -> a -> a -> [a] -> [[a]] +routesC rel x y avoid + | x==y = [[x]] + | otherwise = [ x:r | z <- nbhrs rel x \\ avoid , + r <- routesC rel z y (x:avoid) ] + + +-- Case study: Parsing expressions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- See under case studies for parsing and the calculator.. + + + +-- Infinite lists +-- ^^^^^^^^^^^^^^ + +-- The infinite list of ones. + +ones :: [Int] +ones = 1 : ones + +-- Add the first two elements of a list. + +addFirstTwo :: [Int] -> Int +addFirstTwo (x:y:zs) = x+y + +-- Example, applied to ones. + +infEx1 = addFirstTwo ones + +-- Arithmetic progressions + +from :: Int -> [Int] +from n = n : from (n+1) + +fromStep :: Int -> Int -> [Int] +fromStep n m = n : fromStep (n+m) m + +-- and an example. + +infEx2 = fromStep 3 2 + +-- Infinite list comprehensions. + +-- Pythagorean triples + +pythagTriples = + [ (x,y,z) | z <- [2 .. ] , y <- [2 .. z-1] , + x <- [2 .. y-1] , x*x + y*y == z*z ] + +-- The powers of an integer + +powers :: Int -> [Int] +powers n = [ n^x | x <- [0 .. ] ] + +-- Iterating a function (from the Prelude) + +-- iterate :: (a -> a) -> a -> [a] +-- iterate f x = x : iterate f (f x) + +-- Sieve of Eratosthenes + +primes :: [Int] + +primes = sieve [2 .. ] +sieve (x:xs) = x : sieve [ y | y <- xs , y `mod` x > 0] + +-- Membership of an ordered list. + +memberOrd :: Ord a => [a] -> a -> Bool +memberOrd (x:xs) n + | x Int +nextRand n = (multiplier*n + increment) `mod` modulus + +-- A (pseudo-)random sequence is given by iterating this function, + +randomSequence :: Int -> [Int] +randomSequence = iterate nextRand + +-- Suitable values for the constants. + +seed, multiplier, increment, modulus :: Int + +seed = 17489 +multiplier = 25173 +increment = 13849 +modulus = 65536 + +-- Scaling the numbers to come in the (integer) range a to b (inclusive). + +scaleSequence :: Int -> Int -> [Int] -> [Int] +scaleSequence s t + = map scale + where + scale n = n `div` denom + s + range = t-s+1 + denom = modulus `div` range + +-- Turn a distribution into a function. + +makeFunction :: [(a,Double)] -> (Double -> a) + +makeFunction dist = makeFun dist 0.0 + +makeFun ((ob,p):dist) nLast rand + | nNext >= rand && rand > nLast + = ob + | otherwise + = makeFun dist nNext rand + where + nNext = p*fromIntegral modulus + nLast + +-- Random numbers from 1 to 6 according to the example distribution, dist. + +randomTimes = map (makeFunction dist . fromIntegral) (randomSequence seed) + +-- The distribution in question + +dist = [(1,0.2), (2,0.25), (3,0.25), (4,0.15), (5,0.1), (6,0.05)] + + + +-- A pitfall of infinite list generators +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- An incorrect Pythagorean triples program. + +pythagTriples2 + = [ (x,y,z) | x <- [2 .. ] , + y <- [x+1 .. ] , + z <- [y+1 .. ] , + x*x + y*y == z*z ] + + +-- Why infinite lists? +-- ^^^^^^^^^^^^^^^^^^^ + +-- Running sums of a list of numbers. + +listSums :: [Int] -> [Int] + +listSums iList = out + where + out = 0 : zipWith (+) iList out + +-- We give a calculation of an example now. + +listSumsEx = listSums [1 .. ] + +-- Another definition of listSums which uses scanl1', a generalisation of the +-- original function. + +listSums' = scanl' (+) 0 + +-- A function which combines values from the list +-- using the function f, and whose first output is st. + +scanl' :: (a -> b -> b) -> b -> [a] -> [b] +scanl' f st iList + = out + where + out = st : zipWith f iList out + +-- Factorial Values + +facVals = scanl' (*) 1 [1 .. ] + + + +-- Case study: Simulation +-- ^^^^^^^^^^^^^^^^^^^^^^ + +-- See case studies. + + + +-- Two factorial lists +-- ^^^^^^^^^^^^^^^^^^^ + +-- The factorial function + +fac :: Int -> Int + +fac 0 = 1 +fac m = m * fac (m-1) +-- +-- Two factorial lists + +facMap, facs :: [Int] + +facMap = map fac [0 .. ] +facs = 1 : zipWith (*) [1 .. ] facs diff --git a/Chapter18.hs b/Chapter18.hs new file mode 100644 --- /dev/null +++ b/Chapter18.hs @@ -0,0 +1,334 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 18 +-- +----------------------------------------------------------------------- + + +module Chapter18 where + +import Prelude hiding (lookup) +import System.IO +import Control.Monad.Identity +import Chapter8 (getInt) +import Data.Time +import System.Locale +import System.IO.Unsafe (unsafePerformIO) + +-- Programming with monads +-- ^^^^^^^^^^^^^^^^^^^^^^^ + + +-- The basics of input/output +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Reading input is done by getLine and getChar: see Prelude for details. + +-- getLine :: IO String +-- getChar :: IO Char + +-- Text strings are written using +-- +-- putStr :: String -> IO () +-- putStrLn :: String -> IO () + +-- A hello, world program + +helloWorld :: IO () +helloWorld = putStr "Hello, World!" + +-- Simple examples + +readWrite :: IO () + +readWrite = + do + getLine + putStrLn "one line read" + +readEcho :: IO () + +readEcho = + do + line <-getLine + putStrLn ("line read: " ++ line) + + +-- Adding a sequence of integers from the input + +sumInts :: Integer -> IO Integer + +sumInts s + = do n <- getInt + if n==0 + then return s + else sumInts (s+n) + +-- Adding a list of integers, using an accumulator + +sumAcc :: Integer -> [Integer] -> Integer + +sumAcc s [] = s +sumAcc s (n:ns) + = if n==0 + then s + else sumAcc (s+n) ns + + +-- Addiing a sequence of integers, courteously. + +sumInteract :: IO () +sumInteract + = do putStrLn "Enter integers one per line" + putStrLn "These will be summed until zero is entered" + sum <- sumInts 0 + putStr "The sum is " + print sum + + +-- Further I/O +-- ^^^^^^^^^^^ + +-- Interaction at the terminal + +copyInteract :: IO () + +copyInteract = + do + hSetBuffering stdin LineBuffering + copyEOF + hSetBuffering stdin NoBuffering + +copyEOF :: IO () + +copyEOF = + do + eof <- isEOF + if eof + then return () + else do line <- getLine + putStrLn line + copyEOF + +-- Input and output as lazy lists + +-- Reverse all the lines in the input. + +listIOprog :: String -> String + +listIOprog = unlines . map reverse . lines + + +-- Generating random numbers + +randomInt :: Integer -> IO Integer +randomInt n = + do + time <- getCurrentTime + return ( (`rem` n) $ read $ take 6 $ formatTime defaultTimeLocale "%q" time) + +randInt :: Integer -> Integer +randInt = unsafePerformIO . randomInt + + + +-- The calculator +-- ^^^^^^^^^^^^^^ + +-- This is available separately in the Calculator directory. + + +-- The do notation revisited +-- ^^^^^^^^^^^^^^^^^^^^^^^^^ + +addOneInt :: IO () + +addOneInt + = do line <- getLine + putStrLn (show (1 + read line :: Int)) + +addOneInt' + = getLine >>= \line -> + putStrLn (show (1 + read line :: Int)) + +-- Monads for Functional Programming +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The definition of the Monad class +-- class Monad m where +-- (>>=) :: m a -> (a -> m b) -> m b +-- return :: a -> m a +-- fail :: String -> m a + +-- Kelisli composition for monadic functions. + +-- (>@>) :: Monad m => (a -> m b) -> +-- (b -> m c) -> +-- (a -> m c) + +-- f >@> g = \ x -> (f x) >>= g + + +-- Some examples of monads +-- ^^^^^^^^^^^^^^^^^^^^^^^ + +-- Some examples from the standard prelude. + +-- The list monad + +-- instance Monad [] where +-- xs >>= f = concat (map f xs) +-- return x = [x] +-- zero = [] + +-- The Maybe monad + +-- instance Monad Maybe where +-- (Just x) >>= k = k x +-- Nothing >>= k = Nothing +-- return = Just + + +-- The parsing monad + +-- data SParse a b = SParse (Parse a b) + +-- instance Monad (SParse a) where +-- return x = SParse (succeed x) +-- zero = SParse fail +-- (SParse pr) >>= f +-- = SParse (\s -> concat [ sparse (f x) rest | (x,rest) <- pr st ]) + +-- sparse :: SParse a b -> Parse a b +-- sparse (SParse pr) = pr + +-- A state monad (the state need not be a table; this example is designed +-- to support the example discussed below.) + +type Table a = [a] + +data State a b = State (Table a -> (Table a , b)) + +instance Monad (State a) where + + return x = State (\tab -> (tab,x)) + + (State st) >>= f + = State (\tab -> let + (newTab,y) = st tab + (State trans) = f y + in + trans newTab) + + +-- Example: Monadic computation over trees +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- A type of binary trees. + +data Tree a = Nil | Node a (Tree a) (Tree a) + deriving (Eq,Ord,Show) + +-- Summing a tree of integers + +-- A direct solution: + +sTree :: Tree Integer -> Integer + +sTree Nil = 0 +sTree (Node n t1 t2) = n + sTree t1 + sTree t2 + +-- A monadic solution: first giving a value of type Identity Int ... + +sumTree :: Tree Integer -> Identity Integer + +sumTree Nil = return 0 + +sumTree (Node n t1 t2) + = do num <- return n + s1 <- sumTree t1 + s2 <- sumTree t2 + return (num + s1 + s2) + +-- ... then adapted to give an Int solution + +sTree' :: Tree Integer -> Integer + +sTree' = identity . sumTree + +identity :: Identity a -> a + +identity (Identity x) = x + +-- Using a state monad in a tree calculation +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The top level function ... + +numTree :: Eq a => Tree a -> Tree Integer + +-- ... and the function which does all the work: + +numberTree :: Eq a => Tree a -> State a (Tree Integer) + +-- Its structure mirrors exactly the structure of the earlier program to +-- sum the tree. + +numberTree Nil = return Nil + +numberTree (Node x t1 t2) + = do num <- numberNode x + nt1 <- numberTree t1 + nt2 <- numberTree t2 + return (Node num nt1 nt2) + +-- The work of the algorithm is done node by node, hence the function + +numberNode :: Eq a => a -> State a Integer + +numberNode x = State (nNode x) + +-- +-- Looking up a value in the table; will side-effect the table if the value +-- is not present. + +nNode :: Eq a => a -> (Table a -> (Table a , Integer)) +nNode x table + | elem x table = (table , lookup x table) + | otherwise = (table++[x] , integerLength table) + where + integerLength = toInteger.length + +-- Looking up a value in the table when known to be present + +lookup :: Eq a => a -> Table a -> Integer + +lookup x tab = + locate 0 tab + where + locate n (y:ys) = + if x==y then n else locate (n+1) ys + +-- Extracting a value froma state monad. + +runST :: State a b -> b +runST (State st) = snd (st []) + +-- The top-level function defined eventually. + +numTree = runST . numberTree + +-- Example tree + +egTree :: Tree String + +egTree = Node "Moon" + (Node "Ahmet" Nil Nil) + (Node "Dweezil" + (Node "Ahmet" Nil Nil) + (Node "Moon" Nil Nil)) + diff --git a/Chapter19/QC.hs b/Chapter19/QC.hs new file mode 100644 --- /dev/null +++ b/Chapter19/QC.hs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- QC.hs +-- +-- Generating values randomly. +-- +----------------------------------------------------------------------- + +module QC where + +import Test.QuickCheck + +import Control.Monad (liftM,liftM2) +import System.IO.Unsafe (unsafePerformIO) +import Data.List (nub) +import QCfuns -- to Show functions + +-- Simple examples for data generation + +data Card = Card Int String + deriving (Eq,Show) + +data Info = Number Int | Email String + deriving (Eq, Show) + +data List a = Empty | Cons a (List a) + deriving (Eq, Show) + +instance Arbitrary Card where + arbitrary = + do + int <- arbitrary + string <- arbitrary + return (Card int string) + +instance Arbitrary Info where + arbitrary = + do + boo <- arbitrary + if boo + then do + int <- arbitrary + return (Number int) + else do + string <- arbitrary + return (Email string) + +-- Generating lists of samples + +-- instance Arbitrary a => Arbitrary (List a) where +-- arbitrary = +-- do +-- boo <- elements [True, False] +-- if boo +-- then +-- return $ Empty +-- else do +-- val <- arbitrary +-- list <- arbitrary +-- return $ Cons val list + +instance Arbitrary a => Arbitrary (List a) where + arbitrary = + do + switch <- elements [1,2,3] + case switch of + 1 -> return Empty + _ -> + do + val <- arbitrary + list <- arbitrary + return (Cons val list) + +-- The expr type from the calculator + +data Expr = Lit Integer | + Add Expr Expr | + Sub Expr Expr + deriving (Show,Eq) + +instance Arbitrary Expr where + arbitrary = sized arbExpr + +arbExpr :: Int -> Gen Expr + +arbExpr 0 = liftM Lit arbitrary + +arbExpr n = frequency + [(1, liftM Lit arbitrary), + (2, liftM2 Add subExp subExp), + (2, liftM2 Sub subExp subExp)] + where + subExp = arbExpr (div n 2) +{- +arbExpr 0 = + do int <- arbitrary + return (Lit int) + +arbExpr n + | n>0 = + do + pick <- choose (0,2::Int) + case pick of + 0 -> do + int <- arbitrary + return (Lit int) + 1 -> do + left <- subExp + right <- subExp + return (Add left right) + 2 -> do + left <- subExp + right <- subExp + return (Sub left right) + where + subExp = arbExpr (div n 2) +-} + +prettyE :: Expr -> String + +prettyE (Lit n) = show n +prettyE (Add e1 e2) = "("++prettyE e1 ++"+"++prettyE e2 ++")" +prettyE (Sub e1 e2) = "("++prettyE e1 ++"-"++prettyE e2 ++")" + +-- Property of map + +prop_map f g xs = + map (f::Int->Int) (map (g::Int -> Int) xs) == map (g.f) xs + diff --git a/Chapter19/RegExp.hs b/Chapter19/RegExp.hs new file mode 100644 --- /dev/null +++ b/Chapter19/RegExp.hs @@ -0,0 +1,145 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- RegExp.hs +-- +-- Regular Expressions +-- +----------------------------------------------------------------------- + +module RegExp where + +type RegExp = String -> Bool + +char :: Char -> RegExp + +epsilon = (=="") + +char ch = (==[ch]) + +(|||) :: RegExp -> RegExp -> RegExp + +e1 ||| e2 = + \x -> e1 x || e2 x + +(<*>) :: RegExp -> RegExp -> RegExp + +e1 <*> e2 = + \x -> or [ e1 y && e2 z | (y,z) <- splits x ] + +(<**>) :: RegExp -> RegExp -> RegExp + +e1 <**> e2 = + \x -> or [ e1 y && e2 z | (y,z) <- fsplits x ] + +splits xs = [splitAt n xs | n<-[0..len]] + where + len = length xs + +star :: RegExp -> RegExp + +star p = epsilon ||| (p <**> star p) +-- epsilon ||| (p <*> star p) +-- is OK as long as p can't have epsilon match + +fsplits xs = tail (splits xs) + +-- a = char 'a' + +-- b = char 'b' + +infixr 7 :*: +infixr 5 :|: + +data RE = Eps | + Ch Char | + RE :|: RE | + RE :*: RE | + St RE | + Plus RE + deriving(Eq,Show) + +evens = St two +two = (a :|: b) :*: (a :|: b) + +a = Ch 'a' +b = Ch 'b' + +interp :: RE -> RegExp + +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) + +-- Value recursion +-- Eunmerating strings matching a regexp + +enumerate :: RE -> [String] + +enumerate Eps = [""] +enumerate (Ch ch) = [[ch]] +enumerate (re1 :|: re2) + = enumerate re1 `interleave` enumerate re2 +enumerate (re1 :*: re2) + = enumerate re1 `cartesian` enumerate re2 +enumerate (St re) + = result + where + result = + [""] ++ (enumerate re `cartesian` result) + +-- Auxiliary functions +-- interleave and product for potentially infinite lists + +interleave :: [a] -> [a] -> [a] + +interleave [] ys = ys +interleave (x:xs) ys = x : interleave ys xs + +cartesian :: [[a]] -> [[a]] -> [[a]] + +cartesian [] ys = [] +cartesian (x:xs) ys + = [ x++y | y<-ys ] `interleave` cartesian xs ys + +-- Recursive regular expressions + +anbn :: RE + +anbn = Eps :|: (a :*: (anbn :*: b)) + +palin :: RE + +palin = (Eps :|: (a :*: (palin :*: a))) :|: (b :*: (palin :*: b)) + +-- Extending the implementation + +plus :: RE -> RE +plus re = re :*: St re + +-- Simplification + +simplify :: RE -> RE + +simplify (St (St re)) = simplify (St re) +simplify (Plus (St re)) = simplify (St re) +simplify (St (Plus re)) = simplify (St re) +simplify (re1 :|: re2) = + if sre1==sre2 then sre1 else sre1 :|: sre2 + where + sre1 = simplify re1; sre2 = simplify re2 +simplify re = re + +-- smart constructors + +starC :: RE -> RE +starC (St re) = re +starC (Plus re) = re +starC re = St re diff --git a/Chapter2.hs b/Chapter2.hs new file mode 100644 --- /dev/null +++ b/Chapter2.hs @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 2010. +-- +-- Chapter 2 +-- +-- The example script FirstScript.hs is provided separately, +-- as are the Pictures.hs and PicturesSVG.hs modules. +-- +------------------------------------------------------------------------------ + +module Chapter2 where +import Chapter1 + +-- Some example expressions + +ex1, ex2 :: Integer +ex1 = double 32 - square (size - double 3) +ex2 = double 320 - square (size - double 6) + +-- Some examples of expressions which cause errors; that's why +-- they appear as comments and not as Haskell text. +-- +-- 2+(3+4 +-- 2+(3+4)) +-- double square +-- 4 double +-- 4 5 +-- 4 `div` (3*2-6) diff --git a/Chapter20/Chapter20.hs b/Chapter20/Chapter20.hs new file mode 100644 --- /dev/null +++ b/Chapter20/Chapter20.hs @@ -0,0 +1,237 @@ + +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2010. + +-- Chapter 20 + +-- Time and space behaviour +-- ^^^^^^^^^^^^^^^^^^^^^^^^ + +module Chapter20 where + +import Prelude hiding (map) + +-- Various functions whose complexity is discussed. +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Naive Fibonacci function + +fib :: Integer -> Integer + +fib 0 = 0 +fib 1 = 1 +fib m = fib (m-2) + fib (m-1) + +-- Naive factorial function + +fac :: Integer -> Integer +fac 0 = 1 +fac n = n * fac (n-1) + +-- Insertion sort + +iSort :: Ord a => [a] -> [a] + +iSort [] = [] +iSort (x:xs) = ins x (iSort xs) + +ins :: Ord a => a -> [a] -> [a] + +ins x [] = [x] +ins x (y:ys) + | (x<=y) = x:y:ys + | otherwise = y:ins x ys + +-- Quicksort + +qSort :: Ord a => [a] -> [a] + +qSort [] = [] +qSort (x:xs) = qSort [z|z<-xs,z<=x] ++ [x] ++ qSort [z|z<-xs,z>x] + +-- Two reverse functions + +rev1 [] = [] +rev1 (x:xs) = rev1 xs ++ [x] + +rev2 = shunt [] +shunt xs [] = xs +shunt xs (y:ys) = shunt (y:xs) ys + +-- Two multiplication functions + +mult n 0 = 0 +mult n m = mult n (m-1) + n + +russ n 0 = 0 +russ n m + | (m `mod` 2 == 0) = russ (n+n) (m `div` 2) + | otherwise = russ (n+n) (m `div` 2) + n + +-- The merge sort function + +mSort :: Ord a => [a] -> [a] + +mSort xs + | (len < 2) = xs + | otherwise = mer (mSort (take m xs)) (mSort (drop m xs)) + where + len = length xs + m = len `div` 2 + +mer :: Ord a => [a] -> [a] -> [a] + +mer (x:xs) (y:ys) + | (x<=y) = x : mer xs (y:ys) + | otherwise = y : mer (x:xs) ys +mer (x:xs) [] = (x:xs) +mer [] ys = ys + +-- Implementations of sets +-- ^^^^^^^^^^^^^^^^^^^^^^^ + +-- Sets implemented as _unordered_ lists. + +-- type Set a = [a] + +-- empty = [] +-- memSet = member +-- inter xs ys = filter (member xs) ys +-- union = (++) +-- subSet xs ys = and (map (member ys) xs) +-- eqSet xs ys = subSet xs ys && subSet ys xs +-- makeSet = id +-- mapSet = map +-- + + +-- Space behaviour +-- ^^^^^^^^^^^^^^^ + +-- Lazy evaluation +-- ^^^^^^^^^^^^^^^ + +-- List examples + +exam1 n = [1 .. n] ++ [1 .. n] + +exam2 n = list ++ list + where + list=[1 .. n] + +exam3 n = [1 .. n] ++ [last [1 .. n]] + +exam4 n = list ++ [last list] + where + list=[1 .. n] + + +-- Saving space? +-- ^^^^^^^^^^^^^ + +-- A new version of factorial + +newFac :: Integer -> Integer +newFac n = aFac n 1 + +aFac :: Integer -> Integer -> Integer +aFac 0 p = p +aFac n p = aFac (n-1) (p*n) + +-- This can be modified thus: +-- aFac n p +-- | p==p = aFac (n-1) (p*n) + +-- Miscellaneous functions + +sumSquares :: Integer -> Integer +sumSquares n = sumList (map sq [1 .. n]) + +sumList = foldr (+) 0 +sq n = n*n + + + +-- Folding revisited +-- ^^^^^^^^^^^^^^^^^ + +-- Map defined using foldr + +map f = foldr ((:).f) [] + +-- Factorial using foldr + +facFold n = foldr (*) 1 [1 .. n] + +-- Examples + +foldEx1 n = foldr (&&) True (map (==2) [2 .. n]) + + + +-- Avoiding re-computation: memoization +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The Fibonacci numbers + +-- A naive algorithm is given earlier in this script. + +-- An algorithm which returns a pair of consecutive Fibonacci numbers. + +fibP :: Integer -> (Integer,Integer) + +fibP 0 = (0,1) +fibP n = (y,x+y) + where + (x,y) = fibP (n-1) + +-- The list of Fibonacci values, defined directly. + +fibs ::[Integer] + +fibs = 0 : 1 : zipWith (+) fibs (tail fibs) + + +-- Dynamic programming: maximal common subsequence +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The naive algorithm ... + +mLen :: Eq a => [a] -> [a] -> Integer + +mLen xs [] = 0 +mLen [] ys = 0 +mLen (x:xs) (y:ys) + | x==y = 1 + mLen xs ys + | otherwise = max (mLen xs (y:ys)) (mLen (x:xs) ys) + +-- ... translated to talk about sub-components of lists, described by their +-- endpoints ... + +maxLen :: Eq a => [a] -> [a] -> Int -> Int -> Int + +maxLen xs ys 0 j = 0 +maxLen xs ys i 0 = 0 +maxLen xs ys i j + | xs!!(i-1) == ys!!(j-1) = (maxLen xs ys (i-1) (j-1)) + 1 + | otherwise = max (maxLen xs ys i (j-1)) + (maxLen xs ys (i-1) j) + +-- ... and then transliterated into a memoised version. + +maxTab :: Eq a => [a] -> [a] -> [[Int]] + +maxTab xs ys + = result + where + result = [0,0 .. ] : zipWith f [0 .. ] result + f i prev + = ans + where + ans = 0 : zipWith g [0 .. ] ans + g j v + | xs!!i == ys!!j = prev!!j + 1 + | otherwise = max v (prev!!(j+1)) + + diff --git a/Chapter20/PerformanceI.hs b/Chapter20/PerformanceI.hs new file mode 100644 --- /dev/null +++ b/Chapter20/PerformanceI.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- PerformanceI.hs +-- +----------------------------------------------------------------------- + +module Main where + +main = putStrLn (show (sumI 1 1000000)) +-- main = putStrLn (show (sumIA 1 1000000)) +-- main = putStrLn (show (sumIS 1 1000000)) + +sumI :: Integer -> Integer -> Integer + +sumI n m + | n>m = 0 + | otherwise = n + sumI (n+1) m + +sumIA :: Integer -> Integer -> Integer + +sumIA n m = accIA n m 0 + +accIA n m s + | n>m = s + | otherwise = accIA (n+1) m (n+s) + +sumIS :: Integer -> Integer -> Integer + +sumIS n m = accIS n m 0 + +accIS n m s + | n>m = s + | otherwise = accIS (n+1) m $! (n+s) diff --git a/Chapter20/PerformanceIA.hs b/Chapter20/PerformanceIA.hs new file mode 100644 --- /dev/null +++ b/Chapter20/PerformanceIA.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- PerformanceIA.hs +-- +----------------------------------------------------------------------- + +module Main where + +-- main = putStrLn (show (sumI 1 1000000)) +main = putStrLn (show (sumIA 1 1000000)) +--- main = putStrLn (show (sumIS 1 1000000)) + +sumI :: Integer -> Integer -> Integer + +sumI n m + | n>m = 0 + | otherwise = n + sumI (n+1) m + +sumIA :: Integer -> Integer -> Integer + +sumIA n m = accIA n m 0 + +accIA n m s + | n>m = s + | otherwise = accIA (n+1) m (n+s) + +sumIS :: Integer -> Integer -> Integer + +sumIS n m = accIS n m 0 + +accIS n m s + | n>m = s + | otherwise = accIS (n+1) m $! (n+s) diff --git a/Chapter20/PerformanceIS.hs b/Chapter20/PerformanceIS.hs new file mode 100644 --- /dev/null +++ b/Chapter20/PerformanceIS.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- PerformanceIS.hs +-- +----------------------------------------------------------------------- + +module Main where + +-- main = putStrLn (show (sumI 1 1000000)) +-- main = putStrLn (show (sumIA 1 1000000)) +main = putStrLn (show (sumIS 1 1000000)) + +sumI :: Integer -> Integer -> Integer + +sumI n m + | n>m = 0 + | otherwise = n + sumI (n+1) m + +sumIA :: Integer -> Integer -> Integer + +sumIA n m = accIA n m 0 + +accIA n m s + | n>m = s + | otherwise = accIA (n+1) m (n+s) + +sumIS :: Integer -> Integer -> Integer + +sumIS n m = accIS n m 0 + +accIS n m s + | n>m = s + | otherwise = accIS (n+1) m $! (n+s) diff --git a/Chapter3.hs b/Chapter3.hs new file mode 100644 --- /dev/null +++ b/Chapter3.hs @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 3 +-- +------------------------------------------------------------------------------ + +module Chapter3 where + +import Prelude hiding (max) +import Test.QuickCheck + +-- The import statement which follows hides certain of the Prelude functions +-- so that they can be given the definitions they have in their book. + + +-- The Booleans. +-- ^^^^^^^^^^^^^ + +-- Exclusive or: this gives the result True if one of its arguments is True and +-- the other False, and gives the result False in other cases. + +exOr :: Bool -> Bool -> Bool +exOr x y = (x || y) && not (x && y) + +-- Using literals instead of variables in a definition; a simple example of +-- pattern matching to give another definition of `not', ... + +myNot :: Bool -> Bool +myNot True = False +myNot False = True + +prop_myNot :: Bool -> Bool + +prop_myNot x = + not x == myNot x + +-- ... and of `exclusive or'. + +exOr1 True x = not x +exOr1 False x = x + +-- Test exOrs + +prop_exOrs :: Bool -> Bool -> Bool + +prop_exOrs x y = + exOr x y == exOr1 x y + +prop_exOr2 :: Bool -> Bool -> Bool + +prop_exOr2 x y = + exOr x y == (x /= y) + +-- Integers and guards. +-- ^^^^^^^^^^^^^^^^^^^^ + +-- A to test whether three Ints are equal. + +threeEqual :: Integer -> Integer -> Integer -> Bool +threeEqual m n p = (m==n) && (n==p) + +-- The maximum of two integers; this is already defined in the Prelude, +-- so its definition is hidden by the import statement at the top of this file. + +max :: Integer -> Integer -> Integer +max x y + | x >= y = x + | otherwise = y + +-- The maximum of three integers. + +maxThree :: Integer -> Integer -> Integer -> Integer +maxThree x y z + | (x >= y) && (x >= z) = x + | y >= z = y + | otherwise = z + +-- An alternative definition of max which uses if ... then ... else ... + +max' :: Integer -> Integer -> Integer +max' x y + = if x >= y then x else y + +prop_compareMax :: Integer -> Integer -> Bool +prop_compareMax x y = + max x y == max' x y + +prop_max1, prop_max2, prop_max3 :: Integer -> Integer -> Bool + +prop_max1 x y = + x <= max x y && y <= max x y + +prop_max2 x y = + x == max x y || y == max x y + +prop_max3 x y = + (x == max x y) `exOr` (y == max x y) + + +-- Characters. +-- ^^^^^^^^^^^ + +-- Converting lower-case letters to upper-case; does something odd if you apply +-- it to anythig else: how would you modify it to return anything else +-- unchanged? + +toUpper :: Char -> Char +toUpper ch = toEnum (fromEnum ch + offset) + +offset = fromEnum 'A' - fromEnum 'a' + +-- A check whether a character is a digit. + +isDigit :: Char -> Bool +isDigit ch = ('0' <= ch) && (ch <= '9') + + +-- The String type +-- ^^^^^^^^^^^^^^^ + +-- Example strings + +str1, str2, str3, str4, str5 :: String + +str1 = "baboon" +str2 = "" +str3 = "\99a\116" +str4 = "gorilla\nhippo\nibex" +str5 = "1\t23\t456" + +pstr1, pstr2, pstr3, pstr4, pstr5 :: IO () + +pstr1 = putStr str1 +pstr2 = putStr str2 +pstr3 = putStr str3 +pstr4 = putStr str4 +pstr5 = putStr str5 + + + +-- Some syntax. +-- ^^^^^^^^^^^^ + +-- Layout: two definitions on one line, separated by a `;'. + +answer = 42 ; facSix = 720 + +-- Adding two integers: you can use longer names for variables than x and y! + +addTwo :: Integer -> Integer -> Integer +addTwo first second = first+second + +-- Defining an operator for yourself: another version of max! + +(&&&) :: Integer -> Integer -> Integer +x &&& y + | x > y = y + | otherwise = x diff --git a/Chapter4.hs b/Chapter4.hs new file mode 100644 --- /dev/null +++ b/Chapter4.hs @@ -0,0 +1,367 @@ +-------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 4 +-- +-------------------------------------------------------------------------- + +-- NOTE +-- +-- Added HUnit and QuickCheck tests +-- +-- HUnit 1.0 documentation is out of date +-- re package name. + +module Chapter4 where + +import Test.HUnit +import Test.QuickCheck +import PicturesSVG hiding (test2) + +-- Designing a program in Haskell +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +maxThree :: Int -> Int -> Int -> Int +maxThree x y z = (x `max` y) `max` z + +testMax1 = TestCase (assertEqual "for: maxThree 6 4 1" 6 (maxThree 6 4 1)) +testMax2 = TestCase (assertEqual "for: maxThree 6 6 6" 6 (maxThree 6 6 6)) +testMax3 = TestCase (assertEqual "for: maxThree 2 6 6" 6 (maxThree 2 6 6)) +testMax4 = TestCase (assertEqual "for: maxThree 2 2 6" 6 (maxThree 2 2 6)) + +-- run as +-- runTestTT testsMax + +testsMax = TestList [testMax1, testMax2, testMax3, testMax4] + +-- NOTE +-- +-- Added this type synonym so that can switch easily +-- between Integer and Int. + +type MyNum = Integer + +middleNumber :: MyNum -> MyNum -> MyNum -> MyNum +middleNumber x y z + | between y x z = x + | between x y z = y + | otherwise = z + +-- What follows here is a dummy definition of between; you need to replace this +-- with a proper definition for the function middleNumber to work. + +between :: MyNum -> MyNum -> MyNum -> Bool + +-- dummy definition +-- for you to complete! + +between = between + + +-- NOTE +-- +-- HUnit tests added +-- +-- To run evaluate: runTestTT tests + +test1 = TestCase (assertEqual "for: between 2 3 4" True (between 2 3 4)) +test2 = TestCase (assertEqual "for: between 2 3 2" False (between 2 3 2)) +test3 = TestCase (assertEqual "for: between 2 3 3" True (between 2 3 3)) +test4 = TestCase (assertEqual "for: between 3 3 3" True (between 3 3 3)) +test5 = TestCase (assertEqual "for: between 3 2 3" False (between 3 2 3)) +test6 = TestCase (assertEqual "for: between 3 2 1" True (between 3 2 1)) + +testsBetween = TestList [test1, test2, test3, test4, test5, test6] + +-- NOTE +-- +-- Interesting to vary the implementation and see which tests fail. +-- Simple form of mutation testing. + +-- QuickCheck test +-- +-- Does the tricky implementation of between work in the +-- same way as the case analysis? + +prop_between :: MyNum -> MyNum -> MyNum -> Bool + +prop_between x y z + = (between x y z) == ((x<=y)&&(y<=z))||((x>=y)&&(y>=z)) + +-- Unit tests as Quick Check properties + +prop_between1 :: Bool + +prop_between1 + = between 2 3 4 == True + +-- Local definitions +-- ^^^^^^^^^^^^^^^^^ + +-- Four ways of defining a Picture using +-- different combinations of loca definitions. + + +fourPics1 :: Picture -> Picture + +fourPics1 pic = + left `beside` right + where + left = pic `above` invertColour pic + right = invertColour (flipV pic) `above` flipV pic + +fourPics2 :: Picture -> Picture +fourPics2 pic = + left `beside` right + where + left = pic `above` invertColour pic + right = invertColour flipped `above` flipped + flipped = flipV pic + +fourPics3 :: Picture -> Picture + +fourPics3 pic = + left `beside` right + where + left = pic `above` invertColour pic + right = invertColour (flipV left) + +fourPics4 :: Picture -> Picture + +fourPics4 pic = + left `beside` right + where + stack p = p `above` invertColour p + left = stack pic + right = stack (invertColour (flipV pic)) + +-- Area of a triangle + +triArea' :: Float -> Float -> Float -> Float + +triArea' a b c + | possible = sqrt(s*(s-a)*(s-b)*(s-c)) + | otherwise = 0 + where + s = (a+b+c)/2 + possible = possible -- dummy definition + +-- Sum of squares + +sumSquares :: Integer -> Integer -> Integer + +sumSquares n m + = sqN + sqM + where + sqN = n*n + sqM = m*m + + +-- Let expressions +-- ^^^^^^^^^^^^^^^ + +-- Two examples which use `let'. + +letEx1 :: Integer +letEx1 = let x = 3+2 in x^2 + 2*x - 4 + +letEx2 :: Integer +letEx2 = let x = 3+2 ; y = 5-1 in x^2 + 2*x - y + + +-- Scopes + +isOdd, isEven :: Int -> Bool + +isOdd n + | n<=0 = False + | otherwise = isEven (n-1) + +isEven n + | n<0 = False + | n==0 = True + | otherwise = isOdd (n-1) + + +-- Defining types for ourselves +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Rock - Paper - Scissors + +data Move = Rock | + Paper | + Scissors + deriving Eq + +-- Showing Moves in an abbreviated form. + +instance Show Move where + show Rock = "r" + show Paper = "p" + show Scissors = "s" + +-- For QuickCheck to work over the Move type. + +instance Arbitrary Move where + arbitrary = elements [Rock, Paper, Scissors] + +-- Calculating the Move to beat or lose against the +-- argument Move. + +beat, lose :: Move -> Move + +beat Rock = Paper +beat Paper = Scissors +beat Scissors = Rock + +lose Rock = Scissors +lose Paper = Rock +lose Scissors = Paper + + +-- Primitive recursion over Int +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The factorial of n is 1*2*...*(n-1)*n, so that factorial of four is 24. +-- It is often written n! + +fac :: Integer -> Integer +fac n + | n==0 = 1 + | n>0 = fac (n-1) * n + | otherwise = error "fac only defined on natural numbers" + +-- n +-- Raising two to a power: power2 n is 2 in mathematical notation. + +power2 :: Integer -> Integer +power2 n + | n==0 = 1 + | n>0 = 2 * power2 (n-1) + +-- The sum of the factorials up to a particular value, 0! + 1! + ... n!. + +sumFacs :: Integer -> Integer +sumFacs n + | n==0 = 1 + | n>0 = sumFacs (n-1) + fac n + +-- The sum of the values of a function up to a particular value: +-- f 0 + f 1 + ... f n +-- from which you can reconstruct sumFacs: sumFacs n = sumFun fac n + +sumFun :: (Integer -> Integer) -> Integer -> Integer +sumFun f n + | n==0 = f 0 + | n>0 = sumFun f (n-1) + f n + +-- The maximum number of regions into which n lines can cut a plane. + +regions :: Integer -> Integer +regions n + | n==0 = 1 + | n>0 = regions (n-1) + n + +-- The Fibonacci numbers 0, 1, 1, 2, 3, 5, ..., u, v, u+v, ... + +fib :: Integer -> Integer +fib n + | n==0 = 0 + | n==1 = 1 + | n>1 = fib (n-2) + fib (n-1) + +-- Division of integers + +remainder :: Integer -> Integer -> Integer +remainder m n + | m Integer -> Integer +divide m n + | m Integer -> Integer -> Integer +mysteryMax x y z + | x > y && x > z = x + | y > x && y > z = y + | otherwise = z + +testMMax1 = TestCase (assertEqual "for: mysteryMax 6 4 1" 6 (mysteryMax 6 4 1)) +testMMax2 = TestCase (assertEqual "for: mysteryMax 6 6 6" 6 (mysteryMax 6 6 6)) +testMMax3 = TestCase (assertEqual "for: mysteryMax 2 6 6" 6 (mysteryMax 2 6 6)) +testMMax4 = TestCase (assertEqual "for: mysteryMax 2 2 6" 6 (mysteryMax 2 2 6)) +testMMax5 = TestCase (assertEqual "for: mysteryMax 6 6 2" 6 (mysteryMax 6 6 2)) + + +testsMMax = TestList [testMMax1, testMMax2, testMMax3, testMMax4, testMMax5] + + +-- Numbers of roots + +numberNDroots :: Float -> Float -> Float -> Integer + +numberNDroots a b c + | bsq > fac = 2 + | bsq == fac = 1 + | bsq < fac = 0 + where + bsq = b*b + fac = 4.0*a*c + +-- Area of a triangle + +triArea :: Float -> Float -> Float -> Float + +triArea a b c + | possible a b c = sqrt(s*(s-a)*(s-b)*(s-c)) + | otherwise = 0 + where + s = (a+b+c)/2 + +possible :: Float -> Float -> Float -> Bool + +possible a b c = True -- dummy definition + +fact :: Int -> Int + +fact n + | n>1 = n * fact (n-1) + | otherwise = 1 + +prop_fact n = + fact n > 0 + +-- Extended exercise +-- ^^^^^^^^^^^^^^^^^ + +blackSquares :: Integer -> Picture + +blackSquares n + | n<=1 = black + | otherwise = black `beside` blackSquares (n-1) + +blackWhite :: Integer -> Picture + +blackWhite n + | n<=1 = black + | otherwise = black `beside` whiteBlack (n-1) + +whiteBlack = error "exercise for you" + +blackChess :: Integer -> Integer -> Picture + +blackChess n m + | n<=1 = blackWhite m + | otherwise = blackWhite m `above` whiteChess (n-1) m + +whiteChess n m = error "exercise for you" diff --git a/Chapter5.hs b/Chapter5.hs new file mode 100644 --- /dev/null +++ b/Chapter5.hs @@ -0,0 +1,311 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 5 +-- +------------------------------------------------------------------------- + +module Chapter5 where + +import Prelude hiding (id) +import Test.QuickCheck +import Data.Char + +-- Data types: tuples and lists +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Introducing tuples, lists and strings +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +type ShopItem = (String,Int) +type Basket = [ShopItem] + +basket1 :: Basket +basket1 = [ ("Salt: 1kg",139) , ("Plain crisps",25) , ("Gin: 1lt",1099) ] + +basket2 :: Basket +basket2 = [] + +basket3 :: Basket +basket3 = [ ("Salt: 1kg",139) , ("Plain crisps",25) , ("Plain crisps",25) ] + + +-- Tuple types +-- ^^^^^^^^^^^ + +-- Minimum and maximum of two integers. + +minAndMax :: Integer -> Integer -> (Integer,Integer) +minAndMax x y + | x>=y = (y,x) + | otherwise = (x,y) + +-- Adding a pair of intgers. + +addPair :: (Integer,Integer) -> Integer +addPair (x,y) = x+y + +-- Shifting around the structure of an ((Int,Int),Int). + +shift :: ((Integer,Integer),Integer) -> (Integer,(Integer,Integer)) +shift ((x,y),z) = (x,(y,z)) + +-- Selecting parts of a tuple + +name :: ShopItem -> String +price :: ShopItem -> Int + +name (n,p) = n +price (n,p) = p + +-- Adding a pair using the built-in selectors, fst and snd. + +addPair' :: (Integer,Integer) -> Integer +addPair' p = fst p + snd p + +-- Fibonacci numbers: an efficient function, fastFib. + +fibStep :: (Integer,Integer) -> (Integer,Integer) +fibStep (u,v) = (v,u+v) + +fibPair :: Integer -> (Integer,Integer) +fibPair n + | n==0 = (0,1) + | otherwise = fibStep (fibPair (n-1)) + +fastFib :: Integer -> Integer +fastFib = fst . fibPair + +fibTwoStep :: Integer -> Integer -> (Integer,Integer) +fibTwoStep x y = (y,x+y) + +-- Introducing algebraic types +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- We give a sequence of examples of increasing complexity ... + + +-- Product types +-- ^^^^^^^^^^^^^ + +-- A person is represented by their name and age ... + +data People = Person Name Age + +-- where Name and Age are the appropriate synonyms. + +type Name = String +type Age = Int + +jemima, ronnie :: People +jemima = Person "Electric Aunt Jemima" 77 +ronnie = Person "Ronnie" 14 + +-- Turning a person into a string. + +showPerson :: People -> String +showPerson (Person st n) = st ++ " -- " ++ show n + +-- An alternative to Age, + +data NewAge = Years Int + + +-- Alternatives +-- ^^^^^^^^^^^^ + +-- A shape in a simple geometrical program is either a circle or a +-- rectangle. These alternatives are given by the type + +data Shape = Circle Float | + Rectangle Float Float + deriving (Eq,Ord,Show,Read) + +shape1 = Circle 3.0 +shape2 = Rectangle 45.9 87.6 + +-- Pattern matching allows us to define functions by cases, as in, + +isRound :: Shape -> Bool +isRound (Circle _) = True +isRound (Rectangle _ _) = False + +-- and also lets us use the components of the elements: + +area :: Shape -> Float +area (Circle r) = pi*r*r +area (Rectangle h w) = h*w + +-- Derived instances ... + +-- data Season = Spring | Summer | Autumn | Winter +-- deriving (Eq,Ord,Enum,Show,Read) + + + +-- Lists in Haskell +-- ^^^^^^^^^^^^^^^^ + +-- Various examples of lists + +list1 :: [Integer] +list1 = [1,2,3,4,1,4] + +list2 :: [Bool] +list2 = [True] + +list3 :: String +list3 = ['a','a','b'] + +list4 :: String +list4 = "aab" + +list5 :: [ Integer -> Integer ] +list5 = [fastFib,fastFib] + +list6 :: [ [Integer] ] +list6 = [[12,2],[2,12],[]] + +list7 :: [Integer] +list7 = [2 .. 7] + +list8 :: [Float] +list8 = [3.1 .. 7.0] + +list9 :: String +list9 = ['a' .. 'm'] + +list10 :: [Integer] +list10 = [7,6 .. 3] + +list11 :: [Float] +list11 = [0.0,0.3 .. 1.0] + +list12 :: String +list12 = ['a','c' .. 'n'] + + +-- List comprehensions +-- ^^^^^^^^^^^^^^^^^^^ +-- Examples of list comprehensions + +ex :: [Integer] +ex = [2,4,7] + +comp1 :: [Integer] +comp1 = [ 2*n | n<-ex] + +comp2 :: [Bool] +comp2 = [ isEven n | n<-ex ] + +isEven :: Integer -> Bool +isEven n = (n `mod` 2 == 0) + +comp3 :: [Integer] +comp3 = [ 2*n | n <- ex , isEven n , n>3 ] + +-- Add all the pairs in a list of pairs. + +addPairs :: [(Integer,Integer)] -> [Integer] +addPairs pairList = [ m+n | (m,n) <- pairList ] + +-- Return only the sums of pairs which are increasing. + +addOrdPairs :: [(Integer,Integer)] -> [Integer] +addOrdPairs pairList = [ m+n | (m,n) <- pairList , m String +digits st = [ ch | ch<-st , isDigit ch ] + +-- Are all the integers in a list even? or odd? + +allEven, allOdd :: [Integer] -> Bool +allEven xs = (xs == [x | x<-xs, isEven x]) +allOdd xs = ([] == [x | x<-xs, isEven x]) + +-- Summing the radii of the circles in a list, ignores the other shapes + +totalRadii :: [Shape] -> Float +totalRadii shapes = sum [r | Circle r <- shapes] + +-- Extracting all the singletons in a list of integer lists, +-- ignoring the other lists. + +sings :: [[Integer]] -> [Integer] +sings xss = [x | [x] <-xss ] + + +-- A library database +-- ^^^^^^^^^^^^^^^^^^ + +-- Types + +type Person = String +type Book = String + +type Database = [ (Person , Book) ] + +-- An example database. + +exampleBase :: Database +exampleBase + = [ ("Alice" , "Tintin") , ("Anna" , "Little Women") , + ("Alice" , "Asterix") , ("Rory" , "Tintin") ] + +-- The books borrowed by a particular person in the given database. + +books :: Database -> Person -> [Book] +books dBase findPerson + = [ book | (person,book) <- dBase , person==findPerson ] + +-- Making a loan is done by adding a pair to the database. + +makeLoan :: Database -> Person -> Book -> Database +makeLoan dBase pers bk = [ (pers,bk) ] ++ dBase + +-- To return a loan. + +returnLoan :: Database -> Person -> Book -> Database +returnLoan dBase pers bk + = [ pair | pair <- dBase , pair /= (pers,bk) ] + +-- Testing the database. + +-- Commented out because borrowed is not defined here. + +-- test1 :: Bool +-- test1 = borrowed exampleBase "Asterix" + +test2 :: Database +test2 = makeLoan exampleBase "Alice" "Rotten Romans" + +-- QuickCheck properties for the database + +-- Check that bk is in the list of loaned books to pers +-- after making the loan of book to pers + +prop_db1 :: Database -> Person -> Book -> Bool + +prop_db1 dBase pers bk = + elem bk loanedAfterLoan == True + where + afterLoan = makeLoan dBase pers bk + loanedAfterLoan = books afterLoan pers + +-- Check that bk is not in the list of loaned books to pers +-- after returning the loan of book to pers + +prop_db2 :: Database -> Person -> Book -> Bool + +prop_db2 dBase pers bk = + elem bk loanedAfterReturn == False + where + afterReturn = returnLoan dBase pers bk + loanedAfterReturn = books afterReturn pers + + diff --git a/Chapter6.hs b/Chapter6.hs new file mode 100644 --- /dev/null +++ b/Chapter6.hs @@ -0,0 +1,225 @@ +-------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 6 +-- +-------------------------------------------------------------------------- + +module Chapter6 where + +import Prelude hiding (id) +import Test.QuickCheck + +-- Polymorphism +-- ^^^^^^^^^^^^ + +-- Defining the identity function + +id :: a -> a + +id x = x + +-- Extracting the first element of a pair. + +fst :: (a,b) -> a + +fst (x,y) = x + +-- A "mystery" function + +mystery :: (Bool,a) -> Char +mystery (x,y) = if x then 'c' else 'd' + + +-- The Picture example, revisited. +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The type of pictures. + +type Picture = [[Char]] + +-- To flip a +-- picture in a horizontal mirror, + +flipH :: Picture -> Picture +flipH = reverse + +-- and to place one picture above another it is sufficient to join the two lists of +-- lines together. + +above :: Picture -> Picture -> Picture +above = (++) + +-- To flip a picture in a vertical mirror. + +flipV :: Picture -> Picture +flipV pic + = [ reverse line | line <- pic ] + +-- To place two pictures side by side. + +beside :: Picture -> Picture -> Picture +beside picL picR + = [ lineL ++ lineR | (lineL,lineR) <- zip picL picR ] + +-- To invert the colour of a single character ... + +invertChar :: Char -> Char +invertChar ch + = if ch=='.' then '#' else '.' + +-- a line ... + +invertLine :: [Char] -> [Char] +invertLine line + = [ invertChar ch | ch <- line ] + +-- and a picture. + +invertColour :: Picture -> Picture +invertColour pic + = [ invertLine line | line <- pic ] + +-- Alternative definition of invertColour: + +invertColour' :: Picture -> Picture +invertColour' pic + = [ [ invertChar ch | ch <- line ] | line <- pic ] + +-- Properties for Pictures +-- ^^^^^^^^^^^^^^^^^^^^^^^ + +prop_AboveFlipV, prop_AboveFlipH :: Picture -> Picture -> Bool + +prop_AboveFlipV pic1 pic2 = + flipV (pic1 `above` pic2) == (flipV pic1) `above` (flipV pic2) + +prop_AboveFlipH pic1 pic2 = + flipH (pic1 `above` pic2) == (flipH pic1) `above` (flipH pic2) + +propAboveBeside :: Picture -> Picture -> Picture -> Picture -> Bool + +propAboveBeside nw ne sw se = + (nw `beside` ne) `above` (sw `beside` se) + == + (nw `above` sw) `beside` (ne `above` se) + +propAboveBeside3Correct :: Picture -> Picture -> Property + +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) + +rectangular :: Picture -> Bool + +rectangular = error "for you to define" + +height :: Picture -> Int + +height = error "for you to define" + +-- Extended exercise: positioned pictures +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Positions on a plane. + +type Position = (Int,Int) + +-- An Image is a picture with a position. + +type Image = (Picture,Position) + +-- makeImage :: Picture -> Position -> Image +-- changePosition :: Image -> Position -> Image +-- moveImage :: Image -> Int -> Int -> Image +-- printImage :: Image -> IO () + + +-- Local definitions +-- ^^^^^^^^^^^^^^^^^ + +-- The sum of the squares of two numbers. + +sumSquares :: Integer -> Integer -> Integer + +sumSquares n m + = sqN + sqM + where + sqN = n*n + sqM = m*m + +-- Add corresponding elements in two lists; lists truncated to the length of the +-- shorter one. + +addPairwise :: [Integer] -> [Integer] -> [Integer] +addPairwise intList1 intList2 + = [ m + n | (m,n) <- zip intList1 intList2 ] + +-- A variant of addPairwise which doesn't truncate; see book for details of how +-- it works. + +addPairwise' :: [Integer] -> [Integer] -> [Integer] + +addPairwise' intList1 intList2 + = front ++ rear + where + minLength = min (length intList1) (length intList2) + front = addPairwise (take minLength intList1) + (take minLength intList2) + rear = drop minLength intList1 ++ drop minLength intList2 + +-- and a variant of this ... + +addPairwise'' :: [Integer] -> [Integer] -> [Integer] + +addPairwise'' intList1 intList2 + = front ++ rear + where + minLength = min (length intList1) (length intList2) + front = addPairwise front1 front2 + rear = rear1 ++ rear2 + (front1,rear1) = splitAt minLength intList1 + (front2,rear2) = splitAt minLength intList2 + + + +-- Extended exercise: supermarket billing +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Types of names, prices (pence) and bar-codes. + +type Name = String +type Price = Int +type BarCode = Int + +-- The database linking names prices and bar codes. + +type Database = [ (BarCode,Name,Price) ] + +-- The example database we use is + +codeIndex :: Database +codeIndex = [ (4719, "Fish Fingers" , 121), + (5643, "Nappies" , 1010), + (3814, "Orange Jelly", 56), + (1111, "Hula Hoops", 21), + (1112, "Hula Hoops (Giant)", 133), + (1234, "Dry Sherry, 1lt", 540)] + +-- The lists of bar codes, and of Name,Price pairs. + +type TillType = [BarCode] +type BillType = [(Name,Price)] + +-- The length of a line in the bill. + +lineLength :: Int +lineLength = 30 + + diff --git a/Chapter7.hs b/Chapter7.hs new file mode 100644 --- /dev/null +++ b/Chapter7.hs @@ -0,0 +1,272 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 7 +-- +------------------------------------------------------------------------- + +module Chapter7 where + +-- Defining functions over lists +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- For pedagogical reasons, this chapter repeats many of the definitions in the +-- standard Prelude. They are repeated in this file, and so the original +-- definitions have to be hidden when the Prelude is imported: + +import Prelude hiding (id,head,tail,null,sum,concat,(++),zip,take,getLine) +import qualified Prelude + +import Chapter5 (digits,isEven) +import Test.QuickCheck + +-- Pattern matching revisited +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- An example function using guards ... + +mystery :: Integer -> Integer -> Integer +mystery x y + | x==0 = y + | otherwise = x + +-- ... or pattern matching + +mystery' :: Integer -> Integer -> Integer +mystery' 0 y = y +mystery' x _ = x + +-- To join two strings + +joinStrings :: (String,String) -> String +joinStrings (st1,st2) = st1 ++ "\t" ++ st2 + + +-- Lists and list patterns +-- ^^^^^^^^^^^^^^^^^^^^^^^ +-- From the Prelude ... + +head :: [a] -> a +head (x:_) = x + +tail :: [a] -> [a] +tail (_:xs) = xs + +null :: [a] -> Bool +null [] = True +null (_:_) = False + + +-- The case construction +-- ^^^^^^^^^^^^^^^^^^^^^ + +-- Return the first digit in a string. + +firstDigit :: String -> Char + +firstDigit st + = case (digits st) of + [] -> '\0' + (x:_) -> x + + +-- Primitive recursion over lists +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The sum of a list of Ints. + +sum :: [Integer] -> Integer + +sum [] = 0 +sum (x:xs) = x + sum xs + +-- Property to test the re-implementation of sum +-- against the version in the prelude. + +prop_sum :: [Integer] -> Bool + +prop_sum xs = sum xs == Prelude.sum xs + +-- Finding primitive recursive definitions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +-- Concatenating a list of lists. + +concat :: [[a]] -> [a] + +concat [] = [] +concat (x:xs) = x ++ concat xs + +-- Joining two lists + +(++) :: [a] -> [a] -> [a] + +[] ++ ys = ys +(x:xs) ++ ys = x:(xs++ys) + +-- Testing whether something is a member of a list. + +-- Renamed to elem' as we use the elem from Prelude +-- elsewhere in the file. + +elem' :: Integer -> [Integer] -> Bool + +elem' x [] = False +elem' x (y:ys) = (x==y) || (elem' x ys) + + +-- To double every element of an integer list + +doubleAll :: [Integer] -> [Integer] + +doubleAll xs = [ 2*x | x<-xs ] + +doubleAll' [] = [] +doubleAll' (x:xs) = 2*x : doubleAll' xs + +-- To select the even elements from an integer list. + +selectEven :: [Integer] -> [Integer] + +selectEven xs = [ x | x<-xs , isEven x ] + +selectEven' [] = [] +selectEven' (x:xs) + | isEven x = x : selectEven' xs + | otherwise = selectEven' xs + +-- To sort a list of numbers into ascending order. + +iSort :: [Integer] -> [Integer] + +iSort [] = [] +iSort (x:xs) = ins x (iSort xs) + +-- To insert an element at the right place into a sorted list. + +ins :: Integer -> [Integer] -> [Integer] + +ins x [] = [x] +ins x (y:ys) + | x <= y = x:(y:ys) + | otherwise = y : ins x ys + + +-- General recursions over lists +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + +-- Zipping together two lists. + +zip :: [a] -> [b] -> [(a,b)] + +zip (x:xs) (y:ys) = (x,y) : zip xs ys +zip (x:xs) [] = [] +zip [] zs = [] + +-- Taking a given number of elements from a list. + +take :: Int -> [a] -> [a] + +take 0 _ = [] +take _ [] = [] +take n (x:xs) + | n>0 = x : take (n-1) xs +take _ _ = error "PreludeList.take: negative argument" + +-- Quicksort over lists. + +qSort :: [Integer] -> [Integer] + +qSort [] = [] +qSort (x:xs) + = qSort [ y | y<-xs , y<=x] ++ [x] ++ qSort [ y | y<-xs , y>x] + + + +-- Example: Text Processing +-- ^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The `whitespace' characters. + +whitespace :: String +whitespace = ['\n','\t',' '] + +-- Get a word from the front of a string. + +getWord :: String -> String +getWord [] = [] +getWord (x:xs) + | elem x whitespace = [] + | otherwise = x : getWord xs + +-- In a similar way, the first word of a string can be dropped. + +dropWord :: String -> String +dropWord [] = [] +dropWord (x:xs) + | elem x whitespace = (x:xs) + | otherwise = dropWord xs + +-- To remove the whitespace character(s) from the front of a string. + +dropSpace :: String -> String +dropSpace [] = [] +dropSpace (x:xs) + | elem x whitespace = dropSpace xs + | otherwise = (x:xs) + +-- A word is a string. + +type Word = String + +-- Splitting a string into words. + +splitWords :: String -> [Word] +splitWords st = split (dropSpace st) + +split :: String -> [Word] +split [] = [] +split st + = (getWord st) : split (dropSpace (dropWord st)) + +-- Splitting into lines of length at most lineLen + +lineLen :: Int +lineLen = 80 + +-- A line is a list of words. + +type Line = [Word] + +-- Getting a line from a list of words. + +getLine :: Int -> [Word] -> Line +getLine len [] = [] +getLine len (w:ws) + | length w <= len = w : restOfLine + | otherwise = [] + where + newlen = len - (length w + 1) + restOfLine = getLine newlen ws + +-- Dropping the first line from a list of words. + +dropLine :: Int -> [Word] -> Line + +dropLine = dropLine -- DUMMY DEFINITION + +-- Splitting into lines. + +splitLines :: [Word] -> [Line] +splitLines [] = [] +splitLines ws + = getLine lineLen ws + : splitLines (dropLine lineLen ws) + +-- To fill a text string into lines, we write + +fill :: String -> [Line] +fill = splitLines . splitWords diff --git a/Chapter8.hs b/Chapter8.hs new file mode 100644 --- /dev/null +++ b/Chapter8.hs @@ -0,0 +1,476 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 8 +-- +------------------------------------------------------------------------- + +module Chapter8 where + +import Data.Time +import System.Locale +import System.IO.Unsafe +import System.IO +import Test.QuickCheck + +-- +-- Basic types and functions over the type +-- + +-- A type of moves + +data Move = Rock | + Paper | + Scissors + deriving Eq + +-- Showing Moves in an abbreviated form. + +instance Show Move where + show Rock = "r" + show Paper = "p" + show Scissors = "s" + +-- For QuickCheck to work over the Move type. + +instance Arbitrary Move where + arbitrary = elements [Rock, Paper, Scissors] + +-- Convert from 0,1,2 to a Move + +convertToMove :: Integer -> Move + +convertToMove 0 = Rock +convertToMove 1 = Paper +convertToMove 2 = Scissors + +-- Convert a character to the corresponding Move element. + +convertMove :: Char -> Move + +convertMove 'r' = Rock +convertMove 'R' = Rock +convertMove 'p' = Paper +convertMove 'P' = Paper +convertMove 's' = Scissors +convertMove 'S' = Scissors + +-- Outcome of a play +-- +1 for first player wins +-- -1 for second player wins +-- 0 for a draw + +outcome :: Move -> Move -> Integer + +outcome = outcome -- dummy def + +-- Outcome of a tournament + +tournamentOutcome :: Tournament -> Integer + +tournamentOutcome = tournamentOutcome -- dummy definition + +-- Calculating the Move to beat or lose against the +-- argument Move. + +beat, lose :: Move -> Move + +beat Rock = Paper +beat Paper = Scissors +beat Scissors = Rock + +lose Rock = Scissors +lose Paper = Rock +lose Scissors = Paper + +-- QuickCheck property about the "sanity" of the +-- beat and lose functions. + +prop_WinLose :: Move -> Bool + +prop_WinLose x = + beat x /= lose x && + beat x /= x && + lose x /= x + + +-- +-- Strategies +-- + +type Strategy = [Move] -> Move + +-- Random choice of Move + +randomStrategy :: Strategy +randomStrategy _ = convertToMove $ randInt 3 + +-- Constant strategies + +sConst :: Move -> Strategy + +sConst x _ = x + +rock, paper, scissors :: Strategy + +rock = sConst Rock +paper = sConst Paper +scissors = sConst Scissors + +-- Cycle through the three moves. + +cycle :: Strategy + +cycle moves + = case (length moves) `rem` 3 of + 0 -> Rock + 1 -> Paper + 2 -> Scissors + +-- Play the move that would have lost the opponent's last play. + +sLostLast :: Move -> Strategy + +sLostLast move = rock -- dummy definition --- for you to complete + +-- Echo the previous move; also have to supply starting Move. + +echo :: Move -> Strategy + +echo start moves + = case moves of + [] -> start + (last:_) -> last + +-- Make a random choice of which Strategy to use, +-- each turn. + +sToss :: Strategy -> Strategy -> Strategy + +sToss str1 str2 moves = + case randInt 2 of + 1 -> str1 moves + 0 -> str2 moves + +-- +-- Random stuff from time +-- + +-- Generate a random integer within the IO monad. + +randomInt :: Integer -> IO Integer + +randomInt n = + do + time <- getCurrentTime + return ( (`rem` n) $ read $ take 6 $ formatTime defaultTimeLocale "%q" time) + +-- Extract the random number from the IO monad, unsafely! + +randInt :: Integer -> Integer + +randInt = unsafePerformIO . randomInt + + +--- Basics of I/O +--- ^^^^^^^^^^^^^ + + + + +-- The basics of input/output +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Reading input is done by getLine and getChar: see Prelude for details. + +-- getLine :: IO String +-- getChar :: IO Char + +-- Text strings are written using +-- +-- putStr :: String -> IO () +-- putStrLn :: String -> IO () + +-- A hello, world program + +helloWorld :: IO () +helloWorld = putStr "Hello, World!" + +-- Writing values in general + +-- print :: Show a => a -> IO () + + +-- The do notation: a series of sequencing examples. +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Put a string and newline. + +-- putStrLn :: String -> IO () +-- putStrLn str = do putStr str +-- putStr "\n" + +-- Put four times. + +put4times :: String -> IO () +put4times str + = do putStrLn str + putStrLn str + putStrLn str + putStrLn str + +-- Put n times + +putNtimes :: Integer -> String -> IO () +putNtimes n str + = if n <= 1 + then putStrLn str + else do putStrLn str + putNtimes (n-1) str + +-- Read two lines, then write a message. + +read2lines :: IO () +read2lines + = do getLine + getLine + putStrLn "Two lines read." + +-- Read then write. + +getNput :: IO () +getNput = do line <- getLine + putStrLn line + +-- Read, process then write. + +reverse2lines :: IO () +reverse2lines + = do line1 <- getLine + line2 <- getLine + putStrLn (reverse line2) + putStrLn (reverse line1) + +-- Last example redefined to use a local definition. + +reverse2lines' :: IO () +reverse2lines' + = do line1 <- getLine + line2 <- getLine + let rev1 = reverse line1 + let rev2 = reverse line2 + putStrLn rev2 + putStrLn rev1 + +-- Reading an Int. + +getInt :: IO Integer +getInt = do line <- getLine + return (read line :: Integer) + + + +-- Simple examples + +readWrite :: IO () + +readWrite = + do + getLine + putStrLn "one line read" + +readEcho :: IO () + +readEcho = + do + line <-getLine + putStrLn ("line read: " ++ line) + + +-- Adding a sequence of integers + +sumInts :: Integer -> IO Integer + +sumInts s + = do n <- getInt + if n==0 + then return s + else sumInts (s+n) + +-- Addiing a sequence of integers, courteously. + +sumInteract :: IO () +sumInteract + = do putStrLn "Enter integers one per line" + putStrLn "These will be summed until zero is entered" + sum <- sumInts 0 + putStr "The sum is " + print sum + +-- Copy from input to output + +copyEOF :: IO () + +copyEOF = + do + eof <- isEOF + if eof + then return () + else do line <- getLine + putStrLn line + copyEOF + +copyInteract :: IO () + +copyInteract = + do + hSetBuffering stdin LineBuffering + copyEOF + hSetBuffering stdin NoBuffering + +copy :: IO () + +copy = + do line <- getLine + putStrLn line + copy + +copyEmpty :: IO () + +copyEmpty = + do line <- getLine + if line == "" + then return () + else do putStrLn line + copyEmpty + + +copyCount :: Integer -> IO () + +copyCount n = + do line <- getLine + if line == "" + then putStrLn (show n ++ " lines copied.") + else do putStrLn line + copyCount (n+1) + +copyN :: Integer -> IO () + +copyN n = + if n <= 0 + then return () + else do line <- getLine + putStrLn line + copyN (n-1) + +copyWrong :: IO () + +copyWrong = + do + line <- getLine + let whileCopy = + do + if (line == "") + then (return ()) + else + do putStrLn line + line <- getLine + whileCopy + whileCopy + + +--- Playing Rock - Paper - Scissors +--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + +-- +-- Tournaments +-- + +-- The Tournament type. + +type Tournament = ([Move],[Move]) + +-- The result of a Tournament, calculates the outcome of each +-- stage and sums the results. + +result :: Tournament -> Integer + +result = sum . map (uncurry outcome) . uncurry zip + + +-- +-- Play one Strategy against another +-- + +step :: Strategy -> Strategy -> Tournament -> Tournament + +step strategyA strategyB ( movesA, movesB ) + = ( strategyA movesB : movesA , strategyB movesA : movesB ) + +playSvsS :: Strategy -> Strategy -> Integer -> Tournament + +playSvsS strategyA strategyB n + = if n<=0 then ([],[]) else step strategyA strategyB (playSvsS strategyA strategyB (n-1)) + + +-- +-- Playing interactively +-- + +-- Top-level function + +play :: Strategy -> IO () + +play strategy = + playInteractive strategy ([],[]) + +-- The worker function + +playInteractive :: Strategy -> Tournament -> IO () + +playInteractive s t@(mine,yours) = + do + ch <- getChar + if not (ch `elem` "rpsRPS") + then showResults t + else do let next = s yours + putStrLn ("\nI play: " ++ show next ++ " you play: " ++ [ch]) + let yourMove = convertMove ch + playInteractive s (next:mine, yourMove:yours) + + +-- Calculate the winner and report the result. + +showResults :: Tournament -> IO () + +showResults t = + do + let res = result t + putStrLn (case compare res 0 of + GT -> "I won!" + EQ -> "Draw!" + LT -> "You won: well done!") + +-- Play against a randomly chosen strategy + +randomPlay :: IO () + +randomPlay = + do + rand <- randomInt 10 + play (case rand of + 0 -> echo Paper + 1 -> sLostLast Scissors + 2 -> const Rock + 3 -> randomStrategy + 4 -> sToss randomStrategy (echo Paper) + 5 -> echo Rock + 6 -> sLostLast Paper + 7 -> sToss (const Rock) (const Scissors) + 8 -> const Paper + 9 -> randomStrategy) + diff --git a/Chapter9.hs b/Chapter9.hs new file mode 100644 --- /dev/null +++ b/Chapter9.hs @@ -0,0 +1,197 @@ +--------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Chapter 9 +-- +--------------------------------------------------------------------- + +-- Reasoning about programs +-- ^^^^^^^^^^^^^^^^^^^^^^^^ + +module Chapter9 where + +import Prelude hiding (sum,length,(++),reverse,unzip) +import Test.QuickCheck + + +-- Testing and verification +-- ^^^^^^^^^^^^^^^^^^^^^^^^ +-- A function supposed to give the maximum of three (integer) values. + +mysteryMax :: Integer -> Integer -> Integer -> Integer +mysteryMax x y z + | x > y && x > z = x + | y > x && y > z = y + | otherwise = z + +prop_mystery :: Integer -> Integer -> Integer -> Bool + +prop_mystery x y z = + mysteryMax x y z == (x `max` y) `max` z + +-- Definedness and termination +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- A factorial function, giving an undefined result on negative integers. + +fact :: Integer -> Integer +fact n + | n==0 = 1 + | otherwise = n * fact (n-1) + +-- An infinite list + +posInts :: [Integer] +posInts = [1, 2 .. ] + + +-- Induction +-- ^^^^^^^^^ + +-- The sum function, defined recursively. + +sum :: [Integer] -> Integer + +sum [] = 0 -- (sum.1) +sum (x:xs) = x + sum xs -- (sum.2) + +-- Double every element of an integer list. + +doubleAll :: [Integer] -> [Integer] + +doubleAll [] = [] -- (doubleAll.1) +doubleAll (z:zs) = 2*z : doubleAll zs -- (doubleAll.2) + +-- The property linking the two: +-- sum (doubleAll xs) = 2 * sum xs -- (sum+dblAll) + +prop_SumDoubleAll :: [Integer] -> Bool + +prop_SumDoubleAll xs = + sum (doubleAll xs) == 2 * sum xs + +-- Other functions used in the examples +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The definitions given here use explicit recursion, rather than applying +-- higher-order functions as may happen in the Prelude definitions. + +length :: [a] -> Int + +length [] = 0 -- (length.1) +length (z:zs) = 1 + length zs -- (length.2) + +(++) :: [a] -> [a] -> [a] + +[] ++ zs = zs -- (++.1) +(w:ws) ++ zs = w:(ws++zs) -- (++.2) + +-- QuickCheck property + +prop_lengthPlusPlus :: [a] -> [a] -> Bool + +prop_lengthPlusPlus xs ys = + length (xs ++ ys) == length xs + length ys + +reverse :: [a] -> [a] + +reverse [] = [] -- (reverse.1) +reverse (z:zs) = reverse zs ++ [z] -- (reverse.2) + +-- QuickCheck properties +-- Why does prop_reversePlusPlus' not fail? Because a defaults to (). +-- See note on "QuickCheck and properties over [a]" at the end of +-- Section 9.6. + +prop_reversePlusPlus' :: Eq a => [a] -> [a] -> Bool + +prop_reversePlusPlus' xs ys = + reverse (xs ++ ys) == reverse xs ++ reverse ys + +-- The "right" property here. + +prop_reversePlusPlusOops :: [Integer] -> [Integer] -> Bool + +prop_reversePlusPlusOops xs ys = + reverse (xs ++ ys) == reverse xs ++ reverse ys + +-- The "right" property here. + +prop_reversePlusPlus :: [Integer] -> [Integer] -> Bool + +prop_reversePlusPlus xs ys = + reverse (xs ++ ys) == reverse ys ++ reverse xs + +-- Associativity of ++ + +prop_assocPlusPlus :: [Integer] -> [Integer] -> [Integer] -> Bool + +prop_assocPlusPlus xs ys zs = + (xs ++ ys) ++ zs == xs ++ (ys ++ zs) + + + +unzip :: [(a,b)] -> ([a],[b]) + +unzip [] = ([],[]) +unzip ((x,y):ps) + = (x:xs,y:ys) + where + (xs,ys) = unzip ps + + +-- Generalizing the proof goal +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The shunting function + +shunt :: [a] -> [a] -> [a] + +shunt [] ys = ys -- (shunt.1) +shunt (x:xs) ys = shunt xs (x:ys) -- (shunt.2) + +-- QuickCheck property of shunt. + +prop_shunt :: [Integer] -> [Integer] -> Bool + +prop_shunt xs zs = + shunt (shunt xs zs) [] == shunt zs xs + +-- Alternative reverse. + +rev :: [a] -> [a] + +rev xs = shunt xs [] -- (rev.1) + +-- Do they always match? + +prop_reverses :: [Integer] -> Bool + +prop_reverses xs = + reverse xs == rev xs + +-- An alternative definition of the factorial function. + +fac2 :: Integer -> Integer + +fac2 n = facAux n 1 + +facAux :: Integer -> Integer -> Integer + +facAux 0 p = p +facAux n p = facAux (n-1) (n*p) + +-- QuickChecking the two factorials: + +prop_facs' :: Integer -> Bool + +prop_facs' x = + fact x == fac2 x + +prop_facs :: Integer -> Bool + +prop_facs x = + (x<0) || fact x == fac2 x diff --git a/Craft3e.cabal b/Craft3e.cabal new file mode 100644 --- /dev/null +++ b/Craft3e.cabal @@ -0,0 +1,131 @@ + +name: Craft3e +version: 0.1.0.2 +license: MIT +license-file: LICENSE +copyright: (c) Addison Wesley +author: Simon Thompson +maintainer: Simon Thompson +bug-reports: mailto:s.j.thompson@kent.ac.uk +stability: stable +homepage: http://www.haskellcraft.com/ +synopsis: Code for Haskell: the Craft of Functional Programming, 3rd ed. +category: Education +cabal-version: >= 1.6 +build-type: Simple +description: + . + Use as follows: + . + 1. Download via: @cabal unpack@ + . + 2. Go to directory: @cd Craft3e-@ + . + 3. Install dependencies: @cabal install@ + +extra-source-files: + README.txt + black.jpg + white.jpg + red.jpg + blue.jpg + blk_horse_head.jpg + svgOut.xml + showPic.html + refresh.html + +library + build-depends: + base >= 4 && < 5, + QuickCheck >= 2.1 && < 3, + old-locale == 1.0.*, + time >= 1.1 && < 1.3, + mtl >= 1.1 && < 2.1, + HUnit == 1.2.* + + exposed-modules: + + + other-modules: + Chapter1 + Chapter10 + Chapter11 + Chapter12 + Chapter13 + Chapter14_1 + Chapter14_2 + Chapter17 + Chapter18 + Chapter2 + Chapter20 + Chapter3 + Chapter4 + Chapter5 + Chapter6 + Chapter7 + Chapter8 + Chapter9 + FirstScript + Index + ParseLib + ParsingBasics + Pic + Pictures + PicturesSVG + QCfuns + RPS + Relation + Set + Setup + UseMonads + CalcEval + CalcParse + CalcParseLib + CalcStore + CalcToplevel + CalcTypes + Ant + Bee + CodeTable + Coding + Cow + Doe + Frequency + Main + MakeCode + MakeTree + Test + Types + QCStoreTest + Queues1 + Queues2 + Queues3 + Store + StoreFun + StoreTest + Tree + UseStore + UseStoreFun + UseTree + QC + RegExp + Base + QueueState + RandomGen + ServerState + TopLevelServe + + hs-source-dirs: . ./Calculator ./Chapter15 ./Chapter16 ./Chapter19 ./Simulation ./Chapter20 + +executable performanceI + main-is: PerformanceI.hs + hs-source-dirs: ./Chapter20 + +executable performanceIA + main-is: PerformanceIA.hs + hs-source-dirs: ./Chapter20 + +executable performanceIS + main-is: PerformanceIS.hs + hs-source-dirs: ./Chapter20 + diff --git a/FirstScript.hs b/FirstScript.hs new file mode 100644 --- /dev/null +++ b/FirstScript.hs @@ -0,0 +1,30 @@ +{- ######################################################### + + FirstScript.hs + Simon Thompson, August 2010. + +######################################################### -} + +module FirstScript where + +-- The value size is an integer (Integer), defined to be +-- the sum of twelve and thirteen. + +size :: Integer +size = 12+13 + +-- The function to square an integer. + +square :: Integer -> Integer +square n = n*n + +-- The function to double an integer. + +double :: Integer -> Integer +double n = 2*n + +-- An example using double, square and size. + +example :: Integer +example = double (size - square (2+2)) + diff --git a/Index.hs b/Index.hs new file mode 100644 --- /dev/null +++ b/Index.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Index +-- +----------------------------------------------------------------------- + + + +module Index where + +import Chapter11 ((>.>)) +import qualified Chapter7 + + + +-- Example: creating an index +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- The basic type symonyms + +type Doc = String +type Line = String +type Word = String + +-- The type of the top-level function + +makeIndex :: Doc -> [ ([Int],Word) ] + +-- The top-level definition + +makeIndex + = lines >.> -- Doc -> [Line] + numLines >.> -- [Line] -> [(Int,Line)] + allNumWords >.> -- [(Int,Line)] -> [(Int,Word)] + sortLs >.> -- [(Int,Word)] -> [(Int,Word)] + makeLists >.> -- [(Int,Word)] -> [([Int],Word)] + amalgamate >.> -- [([Int],Word)] -> [([Int],Word)] + shorten -- [([Int],Word)] -> [([Int],Word)] + +-- Implementing the component functions +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +-- Attach a number to each line. + +numLines :: [Line] -> [ ( Int , Line ) ] +numLines linels + = zip [1 .. length linels] linels + +-- Associate each word with a line number + +numWords :: ( Int , Line ) -> [ ( Int , Word ) ] + +numWords (number , line) + = [ (number , word) | word <- Chapter7.splitWords line ] + +-- The definition uses splitWords from Chapter 7, modified to use a different +-- version of whitespace. For this to take effect, need to make the modification +-- in the Chapter7.hs file. + +whitespace :: String +whitespace = " \n\t;:.,\'\"!?()-" + +-- Apply numWords to each integer,line pair. + +allNumWords :: [ ( Int , Line ) ] -> [ ( Int , Word ) ] +allNumWords = concat . map numWords + +-- The list must next be +-- sorted by word order, and lists of lines on which a word appears be built. +-- The ordering relation on pairs of numbers and +-- words is given by + +orderPair :: ( Int , Word ) -> ( Int , Word ) -> Bool +orderPair ( n1 , w1 ) ( n2 , w2 ) + = w1 < w2 || ( w1 == w2 && n1 < n2 ) + +-- Sorting the list using the orderPair ordering on pairs. + +sortLs :: [ ( Int , Word ) ] -> [ ( Int , Word ) ] + +sortLs [] = [] +sortLs (p:ps) + = sortLs smaller ++ [p] ++ sortLs larger + where + smaller = [ q | q<-ps , orderPair q p ] + larger = [ q | q<-ps , orderPair p q ] + +-- The entries for the same word need to be accumulated together. +-- First each entry is converted to having a list of line numbers associated with +-- it, thus + +makeLists :: [ (Int,Word) ] -> [ ([Int],Word) ] +makeLists + = map mklis + where + mklis ( n , st ) = ( [n] , st ) + +-- After this, the lists associated with the same words are amalgamated. + +amalgamate :: [ ([Int],Word) ] -> [ ([Int],Word) ] + +amalgamate [] = [] +amalgamate [p] = [p] +amalgamate ((l1,w1):(l2,w2):rest) + | w1 /= w2 = (l1,w1) : amalgamate ((l2,w2):rest) + | otherwise = amalgamate ((l1++l2,w1):rest) + +-- Remove all the short words. + +shorten :: [([Int],Word)] -> [([Int],Word)] + +shorten + = filter sizer + where + sizer (nl,wd) = length wd > 3 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 1996-2010 Addison-Wesley + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/ParseLib.hs b/ParseLib.hs new file mode 100644 --- /dev/null +++ b/ParseLib.hs @@ -0,0 +1,130 @@ +------------------------------------------------------------------------- +-- +-- 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 diff --git a/ParsingBasics.hs b/ParsingBasics.hs new file mode 100644 --- /dev/null +++ b/ParsingBasics.hs @@ -0,0 +1,183 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Case study: Parsing expressions +-- +-- Note that this is not a monadic approach to parsing. +-- +--------------------------------------------------------------------------- + +module ParsingBasics where + +import Data.Char + +infixr 5 >*> +-- +-- Syntactic types +-- +type Var = Char +data Expr = Lit Int | Var Var | Op Op Expr Expr +data Op = Add | Sub | Mul | Div | Mod +-- +-- 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 +-- +-- 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 (:) +-- +-- From the exercises... +-- +neList :: Parse a b -> Parse a [b] +neList = neList -- dummy definition +optional :: Parse a b -> Parse a [b] +optional = optional -- dummy definition +nTimes :: Int -> Parse a b -> Parse a [b] +nTimes = nTimes -- dummy definition +-- +-- A parser for expressions +-- +-- +-- The parser has three components, corresponding to the three +-- clauses in the definition of the syntactic type. +-- +parser :: Parse Char Expr +parser = (litParse `alt` varParse) `alt` opExpParse +-- +-- Spotting variables. +-- +varParse :: Parse Char Expr +varParse = spot isVar `build` Var + +isVar :: Char -> Bool +isVar x = ('a' <= x && x <= 'z') +-- +-- Parsing (fully bracketed) operator applications. +-- +opExpParse + = (token '(' >*> + parser >*> + spot isOp >*> + parser >*> + token ')') + `build` makeExpr + +makeExpr (_,(e1,(bop,(e2,_)))) = Op (charToOp bop) e1 e2 + +isOp :: Char -> Bool +isOp = isOp -- dummy definition + +charToOp :: Char -> Op +charToOp = charToOp -- dummy definition + +-- +-- A number is a list of digits with an optional ~ at the front. +-- +litParse + = ((optional (token '~')) >*> + (neList (spot isDigit))) + `build` (charlistToExpr.join) + where + join = uncurry (++) +-- +-- From the exercises... +-- +charlistToExpr :: [Char] -> Expr +charlistToExpr = charlistToExpr -- dummy definition +-- +-- A grammar for unbracketed expressions. +-- +-- eXpr ::= Int | Var | (eXpr Op eXpr) | +-- lexpr mop mexpr | mexpr aop eXpr +-- lexpr ::= Int | Var | (eXpr Op eXpr) +-- mexpr ::= Int | Var | (eXpr Op eXpr) | lexpr mop mexpr +-- mop ::= 'a' | '/' | '\%' +-- aop ::= '+' | '-' +-- +-- +-- The top-level parser +-- +topLevel :: Parse a b -> [a] -> b +topLevel p inp + = case results of + [] -> error "parse unsuccessful" + _ -> head results + where + results = [ found | (found,[]) <- p inp ] +-- +-- The type of commands. +-- +data Command = Eval Expr | Assign Var Expr | Null +commandParse :: Parse Char Command +commandParse = commandParse -- dummy definition +-- +-- From the exercises. +-- +-- tokenList :: [a] -> Parse a [a] +-- spotWhile :: (a -> Bool) -> Parse a [a] diff --git a/Pic.hs b/Pic.hs new file mode 100644 --- /dev/null +++ b/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/Pictures.hs b/Pictures.hs new file mode 100644 --- /dev/null +++ b/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/PicturesSVG.hs b/PicturesSVG.hs new file mode 100644 --- /dev/null +++ b/PicturesSVG.hs @@ -0,0 +1,233 @@ +----------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- PicturesSVG +-- +-- The Pictures functionality implemented by translation +-- SVG (Scalable Vector Graphics) +-- +-- These Pictures could be rendered by conversion to ASCII art, +-- but instead are rendered into SVG, which can then be viewed in +-- a browser: google chrome does a good job. +-- +----------------------------------------------------------------------- + + +module PicturesSVG where + +import System.IO + +-- Pictures represened by a type of trees, so this is a deep +-- embedding. + +data Picture + = Img Image + | Above Picture Picture + | Beside Picture Picture + | Over Picture Picture + | FlipH Picture + | FlipV Picture + | Negative Picture + deriving (Show) + +-- Coordinates are pairs (x,y) of integers +-- +-- o------> x axis +-- | +-- | +-- V +-- y axis + + +type Point = (Int,Int) + +-- The Point in an Image gives the dimensions of the image in pixels. + +data Image = Image Name Point + deriving (Show) + +data Name = Name String + deriving (Show) + +-- +-- The functions over Pictures +-- + +above, beside, over :: Picture -> Picture -> Picture + +above = Above +beside = Beside +over = Over + +-- flipH is flip in a horizontal axis +-- flipV is flip in a vertical axis +-- negative negates each pixel + +-- The definitions of flipH, flipV, negative push the +-- constructors through the binary operations to the images +-- at the leaves. + +-- Original implementation incorrect: it pushed the +-- flipH and flipV through all constructors ... +-- Now it distributes appropriately over Above, Beside and Over. + +flipH, flipV, negative :: Picture -> Picture + +flipH (Above pic1 pic2) = (flipH pic2) `Above` (flipH pic1) +flipH (Beside pic1 pic2) = (flipH pic1) `Beside` (flipH pic2) +flipH (Over pic1 pic2) = (flipH pic1) `Over` (flipH pic2) +flipH pic = FlipH pic + +flipV (Above pic1 pic2) = (flipV pic1) `Above` (flipV pic2) +flipV (Beside pic1 pic2) = (flipV pic2) `Beside` (flipV pic1) +flipV (Over pic1 pic2) = (flipV pic1) `Over` (flipV pic2) +flipV pic = FlipV pic + +negative = Negative + +invertColour = Negative + +-- Convert an Image to a Picture + +img :: Image -> Picture + +img = Img + +-- +-- Library functions +-- + +-- Dimensions of pictures + +width,height :: Picture -> Int + +width (Img (Image _ (x,_))) = x +width (Above pic1 pic2) = max (width pic1) (width pic2) +width (Beside pic1 pic2) = (width pic1) + (width pic2) +width (Over pic1 pic2) = max (width pic1) (width pic2) +width (FlipH pic) = width pic +width (FlipV pic) = width pic +width (Negative pic) = width pic + +height (Img (Image _ (x,y))) = y +height (Above pic1 pic2) = (height pic1) + (height pic2) +height (Beside pic1 pic2) = max (height pic1) (height pic2) +height (Over pic1 pic2) = max (height pic1) (height pic2) +height (FlipH pic) = height pic +height (FlipV pic) = height pic +height (Negative pic) = height pic + +-- +-- Converting pictures to a list of basic images. +-- + +-- A Filter represents which of the actions of flipH, flipV +-- and negative is to be applied to an image in forming a +-- Basic picture. + +data Filter = Filter {fH, fV, neg :: Bool} + deriving (Show) + +newFilter = Filter False False False + +data Basic = Basic Image Point Filter + deriving (Show) + +-- Flatten a picture into a list of Basic pictures. +-- The Point argument gives the origin for the coversion of the +-- argument. + +flatten :: Point -> Picture -> [Basic] + +flatten (x,y) (Img image) = [Basic image (x,y) newFilter] +flatten (x,y) (Above pic1 pic2) = flatten (x,y) pic1 ++ flatten (x, y + height pic1) pic2 +flatten (x,y) (Beside pic1 pic2) = flatten (x,y) pic1 ++ flatten (x + width pic1 , y) pic2 +flatten (x,y) (Over pic1 pic2) = flatten (x,y) pic1 ++ flatten (x,y) pic2 +flatten (x,y) (FlipH pic) = map flipFH $ flatten (x,y) pic +flatten (x,y) (FlipV pic) = map flipFV $ flatten (x,y) pic +flatten (x,y) (Negative pic) = map flipNeg $ flatten (x,y) pic + +-- flip one of the flags for transforms / filter + +flipFH (Basic img (x,y) f@(Filter {fH=boo})) = Basic img (x,y) f{fH = not boo} +flipFV (Basic img (x,y) f@(Filter {fV=boo})) = Basic img (x,y) f{fV = not boo} +flipNeg (Basic img (x,y) f@(Filter {neg=boo})) = Basic img (x,y) f{neg = not boo} + +-- +-- Convert a Basic picture to an SVG image, represented by a String. +-- + +convert :: Basic -> String + +convert (Basic (Image (Name 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 "" + +-- Outputting a picture. +-- The effect of this is to write the SVG code into a file +-- whose path is hardwired into the code. Could easily modify so +-- that it is an argument of the call, and indeed could also call +-- the browser to update on output. + +render :: Picture -> IO () + +render pic + = + let + picList = flatten (0,0) pic + svgString = concat (map convert picList) + newFile = preamble ++ svgString ++ postamble + in + do + outh <- openFile "svgOut.xml" WriteMode + hPutStrLn outh newFile + hClose outh + +-- Preamble and postamble: boilerplate XML code. + +preamble + = "\n" ++ + "\n" ++ + "\n" ++ + "\n" + +postamble + = "\n\n" + +-- +-- Examples +-- + +white = Img $ Image (Name "white.jpg") (50, 50) + +black = Img $ Image (Name "black.jpg") (50, 50) + +red = Img $ Image (Name "red.jpg") (50, 50) + +blue = Img $ Image (Name "blue.jpg") (50, 50) + +horse = Img $ Image (Name "blk_horse_head.jpg") (150, 200) + +test = (horse `beside` (negative (flipV horse))) + `above` + ((negative horse) `beside` (flipV horse)) + +test2 = test `beside` flipV test diff --git a/QCfuns.hs b/QCfuns.hs new file mode 100644 --- /dev/null +++ b/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/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -0,0 +1,36 @@ +README + +Code for Haskell the Craft of Functional Programming, 3rd ed. + +Files for chapter N are in ChapterN.hs except + +Chapter 12 + Chapter12.hs + Index.hs -- Indexing + RPS.hs -- Rock - Paper - Scissors + RegExp.hs -- Regular expressions + +Chapter 14 + Chapter14_1.s + Chapter14_2.s + +Chapter 15 + Folders containing the modules: + Huffman + +Chapter 16 + Folders containing the modules: + AbsTypes + Simulation + +Chapter 19 + Pic.hs + RegExp.hs + QCfuns.hs + QC.hs + +Chapter 20 + Chapter20.hs + PerformanceI.hs + PerformanceIA.hs + PerformanceIS.hs diff --git a/RPS.hs b/RPS.hs new file mode 100644 --- /dev/null +++ b/RPS.hs @@ -0,0 +1,283 @@ +----------------------------------------------------------------------- +-- Haskell: The Craft of Functional Programming +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2010. +-- +-- RPS: Rock - Paper - Scissors +----------------------------------------------------------------------- + +module RPS where + +import Data.Time +import System.Locale +import System.IO.Unsafe +import System.IO +import Test.QuickCheck + +-- +-- Basic types and functions over the type +-- + +-- A type of moves + +data Move = Rock | + Paper | + Scissors + deriving Eq + +-- Showing Moves in an abbreviated form. + +instance Show Move where + show Rock = "r" + show Paper = "p" + show Scissors = "s" + +-- For QuickCheck to work over the Move type. + +instance Arbitrary Move where + arbitrary = elements [Rock, Paper, Scissors] + +-- Convert from 0,1,2 to a Move + +convertToMove :: Integer -> Move + +convertToMove 0 = Rock +convertToMove 1 = Paper +convertToMove 2 = Scissors + +-- Convert a character to the corresponding Move element. + +convertMove :: Char -> Move + +convertMove 'r' = Rock +convertMove 'R' = Rock +convertMove 'p' = Paper +convertMove 'P' = Paper +convertMove 's' = Scissors +convertMove 'S' = Scissors + +-- Outcome of a play +-- +1 for first player wins +-- -1 for second player wins +-- 0 for a draw + +outcome :: Move -> Move -> Integer + +outcome Rock Rock = 0 +outcome Rock Paper = -1 +outcome Rock Scissors = 1 +outcome Paper Rock = 1 +outcome Paper Paper = 0 +outcome Paper Scissors = -1 +outcome Scissors Rock = -1 +outcome Scissors Paper = 1 +outcome Scissors Scissors = 0 + +-- Calculating the Move to beat or lose against the +-- argument Move. + +beat, lose :: Move -> Move + +beat Rock = Paper +beat Paper = Scissors +beat Scissors = Rock + +lose Rock = Scissors +lose Paper = Rock +lose Scissors = Paper + +-- QuickCheck property about the "sanity" of the +-- beat and lose functions. + +prop_WinLose :: Move -> Bool + +prop_WinLose x = + beat x /= lose x && + beat x /= x && + lose x /= x + + +-- +-- Strategies +-- + +type Strategy = [Move] -> Move + +-- Random choice of Move + +random :: Strategy +random _ = convertToMove $ randInt 3 + +-- Constant strategies + +sConst :: Move -> Strategy + +sConst x _ = x + +rock, paper, scissors :: Strategy + +rock = sConst Rock +paper = sConst Paper +scissors = sConst Scissors + +-- Echo the previous move; also have to supply starting Move. + +echo :: Move -> Strategy + +echo start moves + = case moves of + [] -> start + (last:_) -> last + +-- Echo a move taht would have lost the last play; +-- also have to supply starting Move. + +sLostLast start moves + = case moves of + [] -> start + (last:_) -> lose last + +-- Make a random choice of which Strategy to use, +-- each turn. + +sToss :: Strategy -> Strategy -> Strategy + +sToss str1 str2 moves = + case randInt 2 of + 1 -> str1 moves + 0 -> str2 moves + +alternate :: Strategy -> Strategy -> Strategy + +alternate str1 str2 moves = + case length moves `rem` 2 of + 1 -> str1 moves + 0 -> str2 moves + +alternate2 :: Strategy -> Strategy -> Strategy + +alternate2 str1 str2 = + \moves -> + case length moves `rem` 2 of + 1 -> str1 moves + 0 -> str2 moves + +alternate3 :: Strategy -> Strategy -> Strategy + +alternate3 str1 str2 moves = + map ($ moves) [str1,str2] !! (length moves `rem` 2) + +beatStrategy :: Strategy -> Strategy + +beatStrategy opponent moves = + beat (opponent moves) + +-- +-- Random stuff from time +-- + +-- Generate a random integer within the IO monad. + +randomInt :: Integer -> IO Integer + +randomInt n = + do + time <- getCurrentTime + return ( (`rem` n) $ read $ take 6 $ formatTime defaultTimeLocale "%q" time) + +-- Extract the random number from the IO monad, unsafely! + +randInt :: Integer -> Integer + +randInt = unsafePerformIO . randomInt + + +-- +-- Tournaments +-- + +-- The Tournament type. + +type Tournament = ([Move],[Move]) + +-- The result of a Tournament, calculates the outcome of each +-- stage and sums the results. + +result :: Tournament -> Integer + +result = sum . map (uncurry outcome) . uncurry zip + + +-- +-- Play one Strategy against another +-- + +step :: Strategy -> Strategy -> Tournament -> Tournament + +step strategyA strategyB ( movesA, movesB ) + = ( strategyA movesB : movesA , strategyB movesA : movesB ) + +playSvsS :: Strategy -> Strategy -> Integer -> Tournament + +playSvsS strategyA strategyB n + = if n<=0 then ([],[]) else step strategyA strategyB (playSvsS strategyA strategyB (n-1)) + + +-- +-- Playing interactively +-- + +-- Top-level function + +play :: Strategy -> IO () + +play strategy = + playInteractive strategy ([],[]) + +-- The worker function + +playInteractive :: Strategy -> Tournament -> IO () + +playInteractive s t@(mine,yours) = + do + ch <- getChar + if not (ch `elem` "rpsRPS") + then showResults t + else do let next = s yours + putStrLn ("\nI play: " ++ show next ++ " you play: " ++ [ch]) + let yourMove = convertMove ch + playInteractive s (next:mine, yourMove:yours) + + +-- Calculate the winner and report the result. + +showResults :: Tournament -> IO () + +showResults t = + do + let res = result t + putStrLn (case compare res 0 of + GT -> "I won!" + EQ -> "Draw!" + LT -> "You won: well done!") + +-- Play against a randomly chosen strategy + +randomPlay :: IO () + +randomPlay = + do + rand <- randomInt 10 + play (case rand of + 0 -> echo Paper + 1 -> sLostLast Scissors + 2 -> const Rock + 3 -> random + 4 -> sToss random (echo Paper) + 5 -> echo Rock + 6 -> sLostLast Paper + 7 -> sToss (const Rock) (const Scissors) + 8 -> const Paper + 9 -> random) + + diff --git a/Relation.hs b/Relation.hs new file mode 100644 --- /dev/null +++ b/Relation.hs @@ -0,0 +1,210 @@ +------------------------------------------------------------------------- +-- +-- Relation.hs +-- +-- Building Relations and Graphs on top of the Set ADT. +-- +-- (c) Addison-Welsey, 1996-2011. +-- +--------------------------------------------------------------------------- + + +module Relation where + +import Set +import Data.List hiding ( union ) +-- +-- A relation is a set of pairs. + +type Relation a = Set (a,a) +-- + +-- Operations over relations. +-- ^^^^^^^^^^^^^^^^^^^^^^^^^^ +-- +-- The image of an element under a relation. + +image :: Ord a => Relation a -> a -> Set a + +image rel val = mapSet snd (filterSet ((==val).fst) rel) +-- +-- The image of a set of elements under a relation. +-- +setImage :: Ord a => Relation a -> Set a -> Set a + +setImage rel = unionSet . mapSet (image rel) + +-- The union of a set of sets. +-- +unionSet :: Ord a => Set (Set a) -> Set a + +unionSet = foldSet union empty +-- +-- Add to a set its image under a relation. + +addImage :: Ord a => Relation a -> Set a -> Set a + +addImage rel st = st `union` setImage rel st +-- +-- Add the children (under the relation isParent) to a set. +-- +type People = String + +isParent :: Relation People + +isParent = isParent -- dummy definition + -- needs to be replaced + +addChildren :: Set People -> Set People + +addChildren = addImage isParent +-- +-- Compose two relations. +-- +compose :: Ord a => Relation a -> Relation a -> Relation a + +compose rel1 rel2 + = mapSet outer (filterSet equals (setProduct rel1 rel2)) + where + equals ((a,b),(c,d)) = (b==c) + outer ((a,b),(c,d)) = (a,d) + +-- The product of two sets. +-- +setProduct :: (Ord a,Ord b) => Set a -> Set b -> Set (a,b) + +setProduct st1 st2 = unionSet (mapSet (adjoin st1) st2) +-- +-- Add an element to each element of a set, forming a set of pairs. +-- +adjoin :: (Ord a,Ord b) => Set a -> b -> Set (a,b) + +adjoin st el = mapSet (addEl el) st + where + addEl el el' = (el',el) +-- +-- The transitive closure of a relation. + +tClosure :: Ord a => Relation a -> Relation a + +tClosure rel = limit addGen rel + where + addGen rel' = rel' `union` compose rel' rel + +-- Finding a limit of a function. + +limit :: Eq a => (a -> a) -> a -> a +limit f xs + | xs == next = xs + | otherwise = limit f next + where + next = f xs + +-- Graphs +-- ^^^^^^ +-- +-- The connected components of a graph. + +connect :: Ord a => Relation a -> Relation a + +connect rel = clos `inter` solc + where + clos = tClosure rel + solc = inverse clos +-- +-- The inverse of a relation swap all pairs. + +inverse :: Ord a => Relation a -> Relation a + +inverse = mapSet swap + where + swap (x,y) = (y,x) +-- +-- The equivalence classes of a(n equivalence) relation. +-- +classes :: Ord a => Relation a -> Set (Set a) + +classes rel + = limit (addImages rel) start + where + start = mapSet sing (eles rel) + +-- The auxiliary functions used in classes. +-- +eles :: Ord a => Relation a -> Set a + +eles rel = mapSet fst rel `union` mapSet snd rel + +addImages :: Ord a => Relation a -> Set (Set a) -> Set (Set a) + +addImages rel = mapSet (addImage rel) + + +-- Searching in graphs +-- ^^^^^^^^^^^^^^^^^^^ +-- +-- The descendants v under rel which lie outside st. +-- +newDescs :: Ord a => Relation a -> Set a -> a -> Set a +newDescs rel st v = image rel v `diff` st +-- +-- Breaking the abstraction barrier for sets. + +flatten :: Set a -> [a] + +flatten = flatten -- dummy definition + +-- Under the list implementation, we can use +-- flatten = id +-- +-- A list of new descendants. +-- +findDescs :: Ord a => Relation a -> [a] -> a -> [a] +findDescs rel xs v = flatten (newDescs rel (makeSet xs) v) + + +-- +-- Breadth first search. +-- ^^^^^^^^^^^^^^^^^^^^^ + +breadthFirst :: Ord a => Relation a -> a -> [a] + +breadthFirst rel val + = limit step start + where + start = [val] + step xs = xs ++ nub (concat (map (findDescs rel xs) xs)) + +-- +-- Depth first search. +-- ^^^^^^^^^^^^^^^^^^^^^ + +depthFirst :: Ord a => Relation a -> a -> [a] + +depthSearch :: Ord a => Relation a -> a -> [a] -> [a] + +depthFirst rel v = depthSearch rel v [] + +depthSearch rel v used + = v : depthList rel (findDescs rel used' v) used' + where + used' = v:used + +depthList :: Ord a => Relation a -> [a] -> [a] -> [a] + +depthList rel [] used = [] + +depthList rel (val:rest) used + = next ++ depthList rel rest (used++next) + where + next + | elem val used = [] + | otherwise = depthSearch rel val used + +-- +-- From the exercises... +-- +-- distance :: Eq a => Relation a -> a -> a -> Int + + + diff --git a/Set.hs b/Set.hs new file mode 100644 --- /dev/null +++ b/Set.hs @@ -0,0 +1,139 @@ +------------------------------------------------------------------------- +-- +-- Set.hs +-- +-- ADT of sets, implemented as ordered lists without repetitions. +-- +-- (c) Addison-Welsey, 1996-2011. +-- +--------------------------------------------------------------------------- + +module Set ( Set , + empty , -- Set a + sing , -- a -> Set a + memSet , -- Ord a => Set a -> a -> Bool + union,inter,diff , -- Ord a => Set a -> Set a -> Set a + eqSet , -- Eq a => Set a -> Set a -> Bool + subSet , -- Ord a => Set a -> Set a -> Bool + makeSet , -- Ord a => [a] -> Set a + mapSet , -- Ord b => (a -> b) -> Set a -> Set b + 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 + ) where + +import Data.List hiding ( union ) +-- +-- Instance declarations for Eq and Ord + +instance Eq a => Eq (Set a) where + (==) = eqSet + +instance Ord a => Ord (Set a) where + (<=) = leqSet + +-- The implementation. +-- +newtype Set a = Set [a] + +empty :: Set a +empty = Set [] + +sing :: a -> Set a +sing x = Set [x] + +memSet :: Ord a => Set a -> a -> Bool +memSet (Set []) y = False +memSet (Set (x:xs)) y + | x Set a -> Set a -> Set a +union (Set xs) (Set ys) = Set (uni xs ys) + +uni :: Ord a => [a] -> [a] -> [a] +uni [] ys = ys +uni xs [] = xs +uni (x:xs) (y:ys) + | x Set a -> Set a -> Set a +inter (Set xs) (Set ys) = Set (int xs ys) + +int :: Ord a => [a] -> [a] -> [a] +int [] ys = [] +int xs [] = [] +int (x:xs) (y:ys) + | x Set a -> Set a -> Set a +diff (Set xs) (Set ys) = Set (dif xs ys) + +dif :: Ord a => [a] -> [a] -> [a] +dif [] ys = [] +dif xs [] = xs +dif (x:xs) (y:ys) + | x Set a -> Set a -> Bool +subSet (Set xs) (Set ys) = subS xs ys + +subS :: Ord a => [a] -> [a] -> Bool +subS [] ys = True +subS xs [] = False +subS (x:xs) (y:ys) + | xy = subS (x:xs) ys + +eqSet :: Eq a => Set a -> Set a -> Bool +eqSet (Set xs) (Set ys) = (xs == ys) + +leqSet :: Ord a => Set a -> Set a -> Bool +leqSet (Set xs) (Set ys) = (xs <= ys) + +-- +makeSet :: Ord a => [a] -> Set a +makeSet = Set . remDups . sort + where + remDups [] = [] + remDups [x] = [x] + remDups (x:y:xs) + | x < y = x : remDups (y:xs) + | otherwise = remDups (y:xs) + +mapSet :: Ord b => (a -> b) -> Set a -> Set b +mapSet f (Set xs) = makeSet (map f xs) + +filterSet :: (a -> Bool) -> Set a -> Set a +filterSet p (Set xs) = Set (filter p xs) + +foldSet :: (a -> a -> a) -> a -> Set a -> a +foldSet f x (Set xs) = (foldr f x xs) + +showSet :: (a->String) -> Set a -> String +showSet f (Set xs) = concat (map ((++"\n") . f) xs) + +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 + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +module Setup where + +main :: IO () + +main = putStrLn "Welcome to the code package for www.haskellcraft.com." diff --git a/Simulation/Base.hs b/Simulation/Base.hs new file mode 100644 --- /dev/null +++ b/Simulation/Base.hs @@ -0,0 +1,27 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- The basis of the simulation package. +-- +------------------------------------------------------------------------- + +module Base where + + +-- The type of input messages. + +data Inmess = No | Yes Arrival Service + deriving (Eq,Show) + +type Arrival = Int +type Service = Int + +-- The type of output messages. + +data Outmess = None | Discharge Arrival Wait Service + deriving (Eq,Show) + +type Wait = Int diff --git a/Simulation/QueueState.hs b/Simulation/QueueState.hs new file mode 100644 --- /dev/null +++ b/Simulation/QueueState.hs @@ -0,0 +1,65 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- The queue ADT: its signature is given in comments in the module +-- header. +-- +------------------------------------------------------------------------- +module QueueState + + ( QueueState , + addMessage, -- Inmess -> QueueState -> QueueState + queueStep, -- QueueState -> ( QueueState , [Outmess] ) + queueStart, -- QueueState + queueLength, -- QueueState -> Int + queueEmpty -- QueueState -> Bool + ) where + +import Base -- for the base types of the system + +type Time = Int + +-- The implementation of the QueueState, where the first field gives the +-- current time, the second the service time so far for the item currently +-- being processed, + +data QueueState = QS Time Service [Inmess] + deriving (Eq, Show) + +-- To add a message, it is put at the end of the list of messages. + +addMessage :: Inmess -> QueueState -> QueueState + +addMessage im (QS time serv ml) = QS time serv (ml++[im]) + +-- A single step in the queue simulation. + +queueStep :: QueueState -> ( QueueState , [Outmess] ) + +queueStep (QS time servSoFar (Yes arr serv : inRest)) + | servSoFar < serv + = (QS (time+1) (servSoFar+1) (Yes arr serv : inRest) , []) + | otherwise + = (QS (time+1) 0 inRest , [Discharge arr (time-serv-arr) serv]) +-- +queueStep (QS time serv []) = (QS (time+1) serv [] , []) + +-- The starting state + +queueStart :: QueueState +queueStart = QS 0 0 [] + +-- The length of the queue + +queueLength :: QueueState -> Int +queueLength (QS _ _ q) = length q + +-- Is the queue empty? + +queueEmpty :: QueueState -> Bool +queueEmpty (QS _ _ q) = (q==[]) + + diff --git a/Simulation/RandomGen.hs b/Simulation/RandomGen.hs new file mode 100644 --- /dev/null +++ b/Simulation/RandomGen.hs @@ -0,0 +1,69 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- Random number generation. +-- +------------------------------------------------------------------------- + +-- Lazy programming +-- ^^^^^^^^^^^^^^^^ + +module RandomGen where + + +-- Find the next (pseudo-)random number in the sequence. + +nextRand :: Int -> Int +nextRand n = (multiplier*n + increment) `mod` modulus + +-- A (pseudo-)random sequence is given by iterating this function, + +randomSequence :: Int -> [Int] +randomSequence = iterate nextRand + +-- Suitable values for the constants. + +seed, multiplier, increment, modulus :: Int +seed = 17489 +multiplier = 25173 +increment = 13849 +modulus = 65536 + +-- Scaling the numbers to come in the (integer) range a to b (inclusive). + +scaleSequence :: Int -> Int -> [Int] -> [Int] +scaleSequence s t + = map scale + where + scale n = n `div` denom + s + range = t-s+1 + denom = modulus `div` range + +-- Turn a distribution into a function. + +makeFunction :: [(a,Double)] -> (Double -> a) + +makeFunction dist = makeFun dist 0.0 + +makeFun ((ob,p):dist) nLast rand + | nNext >= rand && rand > nLast + = ob + | otherwise + = makeFun dist nNext rand + where + nNext = p*fromIntegral modulus + nLast + +-- Random numbers from 1 to 6 according to the example distribution, dist. + +randomTimes :: [Int] +randomTimes = map (makeFunction dist . fromIntegral) (randomSequence seed) + +-- The distribution in question + + +dist :: [(Int,Double)] +dist = [(1,0.2), (2,0.25), (3,0.25), (4,0.15), (5,0.1), (6,0.05)] + diff --git a/Simulation/ServerState.hs b/Simulation/ServerState.hs new file mode 100644 --- /dev/null +++ b/Simulation/ServerState.hs @@ -0,0 +1,99 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- The server ADT: its signature is given in comments in the module +-- header. +-- +------------------------------------------------------------------------- + +module ServerState + + ( ServerState , + addToQueue, -- Int -> Inmess -> ServerState -> ServerState + serverStep, -- ServerState -> ( ServerState , [Outmess] ) + simulationStep, -- ServerState -> Inmess -> ( ServerState , [Outmess] ) + serverStart, -- ServerState + serverSize, -- ServerState -> Int + shortestQueue -- ServerState -> Int + ) where + +import Base -- for the base types of the system +import QueueState -- for the queue type + +-- The server consists of a collection of queues, accessed by integers from 0. + +newtype ServerState = SS [QueueState] + deriving (Eq, Show) + +-- Adding an element to one of the queues. It uses the function addMessage from the +-- QueueState abstract type. + +addToQueue :: Int -> Inmess -> ServerState -> ServerState +-- +addToQueue n im (SS st) + = SS (take n st ++ [newQueueState] ++ drop (n+1) st) + where + newQueueState = addMessage im (st!!n) + +-- A step of the server is given by making a step in each of the constituent +-- queues, and concatenating together the output messages they produce. + +serverStep :: ServerState -> ( ServerState , [Outmess] ) + +serverStep (SS []) + = (SS [],[]) +serverStep (SS (q:qs)) + = (SS (q':qs') , mess++messes) + where + (q' , mess) = queueStep q + (SS qs' , messes) = serverStep (SS qs) + +-- In making a simulation step, we perform a server step, and then add the +-- incoming message, if it indicates an arrival, to the shortest queue. + +simulationStep + :: ServerState -> Inmess -> ( ServerState , [Outmess] ) + +simulationStep servSt im + = (addNewObject im servSt1 , outmess) + where + (servSt1 , outmess) = serverStep servSt + +-- Adding the message to the shortest queue is done by addNewObject, which +-- is not in the signature. The reason for this is that it can be defined using +-- the operations addToQueue and shortestQueue. + +addNewObject :: Inmess -> ServerState -> ServerState + +addNewObject No servSt = servSt + +addNewObject (Yes arr wait) servSt + = addToQueue (shortestQueue servSt) (Yes arr wait) servSt + +-- The start state of the server. + +serverStart :: ServerState +serverStart = SS (replicate numQueues queueStart) + +-- The size of the server. + +serverSize :: ServerState -> Int +serverSize (SS xs) = length xs + +-- The shortest queue in the server. + +shortestQueue :: ServerState -> Int +shortestQueue (SS [q]) = 0 +shortestQueue (SS (q:qs)) + | (queueLength (qs!!short) <= queueLength q) = short+1 + | otherwise = 0 + where + short = shortestQueue (SS qs) + +-- The number of queues in the simulation + +numQueues :: Int +numQueues = 4 diff --git a/Simulation/TopLevelServe.hs b/Simulation/TopLevelServe.hs new file mode 100644 --- /dev/null +++ b/Simulation/TopLevelServe.hs @@ -0,0 +1,72 @@ +------------------------------------------------------------------------- +-- +-- Haskell: The Craft of Functional Programming, 3e +-- Simon Thompson +-- (c) Addison-Wesley, 1996-2011. +-- +-- The top level of the server simulation. +-- +------------------------------------------------------------------------- + +module TopLevelServe where + +import Base -- for the base types of the system +import QueueState -- for the queue type +import ServerState -- for the server type +import RandomGen -- for the random inputs + + +-- The top-level simulation is a function from a series of input +-- messages to a series of output messages, so + +doSimulation :: ServerState -> [Inmess] -> [Outmess] + +doSimulation servSt (im:messes) + = outmesses ++ doSimulation servStNext messes + where + (servStNext , outmesses) = simulationStep servSt im + +-- How do we generate an input sequence? From RandomGen we have the +-- sequence of times given by randomTimes + +simulationInput :: [Inmess] + +simulationInput = zipWith Yes [1 .. ] randomTimes + +-- The output generated by the sample input. + +simEx :: [Outmess] + +simEx = doSimulation serverStart simulationInput + +-- = [Discharge 1 0 2, Discharge 3 0 1, Discharge 6 0 1, +-- Discharge 2 0 5, Discharge 5 0 3, Discharge 4 0 4, +-- Discharge 7 2 2,... + +-- A `finite' input: infinite list with only a finite number of `interesting' +-- inputs. + +simulationInput2 :: [Inmess] + +simulationInput2 = take 50 simulationInput ++ noes + +noes = No : noes + +-- A finite list of outputs, corresponding to the `finite' list of inputs given by +-- simulationInput2 + +simEx2 :: [Outmess] + +simEx2 = take 50 (doSimulation serverStart simulationInput2) + +-- Total waiting time on all the queues + +totalWait :: [Outmess] -> Int +totalWait = sum . map waitTime + where + waitTime (Discharge _ w _) = w + +-- Total wait in the second example. + +totalWaitEx2 = totalWait simEx2 + diff --git a/UseMonads.hs b/UseMonads.hs new file mode 100644 --- /dev/null +++ b/UseMonads.hs @@ -0,0 +1,25 @@ +module UseMonads where + +import Control.Monad.Identity + +instance Show a => Show (Identity a) where + show (Identity x) = show x + +example1 = do { x <- [1,2]; y<-[3,4]; return (x+y)} + +example2 = do { x <- Just 1; y<- Just 2; return (x+y)} + +example3 = do { x <- Just 1; y<- Nothing; return (x+y)} + +example4 = do { x <- Nothing ; y<- Just 2; return (x+y)} + +example5 = do {x<-return 'c':: Identity Char; y<-return 'd';return [x,y]} + +example6 = do {x<-return 'c':: Maybe Char; y<-return 'd';return [x,y]} + +example7 = do {x<-return 'c':: IO Char; y<-return 'd';return [x,y]} + +example8 = do {x<-return 'c':: [Char]; y<-return 'd';return [x,y]} + + + diff --git a/black.jpg b/black.jpg new file mode 100644 Binary files /dev/null and b/black.jpg 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/blue.jpg b/blue.jpg new file mode 100644 Binary files /dev/null and b/blue.jpg differ diff --git a/red.jpg b/red.jpg new file mode 100644 Binary files /dev/null and b/red.jpg differ diff --git a/refresh.html b/refresh.html new file mode 100644 --- /dev/null +++ b/refresh.html @@ -0,0 +1,18 @@ + + + + + +

SVG Pictures

+

This page will display pictures rendered by the render +function from PicturesSVG, as in +

+render ((horse `beside` (flipV horse)) `above` ((flipV horse) `beside` horse))
+
+The module should be run in the directory containing this html file.

+ + + diff --git a/showPic.html b/showPic.html new file mode 100644 --- /dev/null +++ b/showPic.html @@ -0,0 +1,20 @@ + + + + +

SVG Pictures

+

This page will display pictures rendered by the render +function from PicturesSVG, as in +

+render ((horse `beside` (flipV horse)) `above` ((flipV horse) `beside` horse))
+
+The module should be run in the directory containing this html file.

+ +

+Use you browser's refresh button to refresh the image. +

+ + diff --git a/svgOut.xml b/svgOut.xml new file mode 100644 --- /dev/null +++ b/svgOut.xml @@ -0,0 +1,17 @@ + + + + + + + + + + + + + + + diff --git a/white.jpg b/white.jpg new file mode 100644 Binary files /dev/null and b/white.jpg differ