packages feed

Craft3e (empty) → 0.1.0.2

raw patch · 81 files changed

+8750/−0 lines, 81 filesdep +HUnitdep +QuickCheckdep +basesetup-changedbinary-added

Dependencies added: HUnit, QuickCheck, base, mtl, old-locale, time

Files

+ Calculator/CalcEval.hs view
@@ -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+
+ Calculator/CalcParse.hs view
@@ -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
+ Calculator/CalcParseLib.hs view
@@ -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 ])
+ Calculator/CalcStore.hs view
@@ -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)+
+ Calculator/CalcToplevel.hs view
@@ -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+++
+ Calculator/CalcTypes.hs view
@@ -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)+++
+ Chapter1.hs view
@@ -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
+ Chapter10.hs view
@@ -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+
+ Chapter11.hs view
@@ -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
+ Chapter12.hs view
@@ -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]++
+ Chapter13.hs view
@@ -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<y         = x : merge xs (y:ys)+  | x==y        = x : merge xs ys+  | otherwise   = y : merge (x:xs) ys+merge (x:xs) []    = (x:xs)+merge []    (y:ys) = (y:ys)+merge []    []     = []
+ Chapter14_1.hs view
@@ -0,0 +1,237 @@+-----------------------------------------------------------------------+--+-- 	Haskell: The Craft of Functional Programming, 3e+-- 	Simon Thompson+-- 	(c) Addison-Wesley, 1996-2011.+-- +-- 	Chapter 14, part 1+--      Also covers the properties in Section 14.7+--+-----------------------------------------------------------------------++module Chapter14_1 where++import Prelude hiding (Either(..),either,Maybe(..),maybe)+import Test.QuickCheck+import Control.Monad++-- Algebraic types+-- ^^^^^^^^^^^^^^^++-- Introducing algebraic types+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- We give a sequence of examples of increasing complexity ...++-- Enumerated types+-- ^^^^^^^^^^^^^^^^+-- Two enumerated types++data Temp   = Cold | Hot+data Season = Spring | Summer | Autumn | Winter++-- A function over Season, defined using pattern matching.++weather :: Season -> 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)
+ Chapter14_2.hs view
@@ -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
+ Chapter15/Ant.hs view
@@ -0,0 +1,9 @@+module Ant where++type Ants = Int++anteater :: Int -> Int++anteater x = x+1++aardvark = anteater
+ Chapter15/Bee.hs view
@@ -0,0 +1,9 @@+module Bee where ++import Ant hiding ( anteater )+import qualified Ant ++honeyEater = Ant.anteater++beekeeper y = honeyEater y + 1+
+ Chapter15/CodeTable.hs view
@@ -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"
+ Chapter15/Coding.hs view
@@ -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 [] = []
+ Chapter15/Cow.hs view
@@ -0,0 +1,5 @@+module Cow where++import Bee++fish = honeyEater
+ Chapter15/Doe.hs view
@@ -0,0 +1,7 @@+module Doe where++    maxD x y +        | x>y = x++    maxD x y +        = y
+ Chapter15/Frequency.hs view
@@ -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<q) 	= (p,n) : alphaMerge xs ((q,m):ys)	+  | otherwise 	= (q,m) : alphaMerge ((p,n):xs) ys	++-- Lexicographic ordering, second field more significant.+-- 		+freqMerge :: [(Char,Int)] -> [(Char,Int)] -> [(Char,Int)]	++freqMerge xs [] = xs+freqMerge [] ys = ys+freqMerge ((p,n):xs) ((q,m):ys)+  | (n<m || (n==m && p<q)) +    = (p,n) : freqMerge xs ((q,m):ys)	+  | otherwise +    = (q,m) : freqMerge ((p,n):xs) ys	++-- QuickCheck property++prop_mergeSort :: [Int] -> 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
+ Chapter15/Main.hs view
@@ -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
+ Chapter15/MakeCode.hs view
@@ -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+
+ Chapter15/MakeTree.hs view
@@ -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) +
+ Chapter15/Test.hs view
@@ -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+
+ Chapter15/Types.hs view
@@ -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) ]+
+ Chapter16/QCStoreTest.hs view
@@ -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
+ Chapter16/Queues1.hs view
@@ -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"+
+ Chapter16/Queues2.hs view
@@ -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"+
+ Chapter16/Queues3.hs view
@@ -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"+
+ Chapter16/Store.hs view
@@ -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)+
+ Chapter16/StoreFun.hs view
@@ -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)+
+ Chapter16/StoreTest.hs view
@@ -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)+
+ Chapter16/Tree.hs view
@@ -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
+ Chapter16/UseStore.hs view
@@ -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'
+ Chapter16/UseStoreFun.hs view
@@ -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'
+ Chapter16/UseTree.hs view
@@ -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+
+ Chapter17.hs view
@@ -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<n         = memberOrd xs n+  | x==n        = True+  | otherwise   = False+++-- Example: Generating random numbers+-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++-- 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 = 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
+ Chapter18.hs view
@@ -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))+
+ Chapter19/QC.hs view
@@ -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+
+ Chapter19/RegExp.hs view
@@ -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
+ Chapter2.hs view
@@ -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)
+ Chapter20/Chapter20.hs view
@@ -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))++
+ Chapter20/PerformanceI.hs view
@@ -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)
+ Chapter20/PerformanceIA.hs view
@@ -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)
+ Chapter20/PerformanceIS.hs view
@@ -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)
+ Chapter3.hs view
@@ -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
+ Chapter4.hs view
@@ -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<n         = m+  | otherwise   = remainder (m-n) n++divide    :: Integer -> Integer -> Integer+divide m n+  | m<n         = 0+  | otherwise   = 1 + divide (m-n) n++-- Testing+-- ^^^^^^^++-- Does this function calculate the maximum of three numbers?++mysteryMax :: Integer -> 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"
+ Chapter5.hs view
@@ -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<n ]++-- Return only the digits in a String.++digits :: String -> 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++
+ Chapter6.hs view
@@ -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++
+ Chapter7.hs view
@@ -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
+ Chapter8.hs view
@@ -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)+
+ Chapter9.hs view
@@ -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
+ Craft3e.cabal view
@@ -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 <s.j.thompson@kent.ac.uk>+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-<version>@+  .+  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+
+ FirstScript.hs view
@@ -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))+
+ Index.hs view
@@ -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
+ LICENSE view
@@ -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.
+ ParseLib.hs view
@@ -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
+ ParsingBasics.hs view
@@ -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]
+ Pic.hs view
@@ -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)) +
+ Pictures.hs view
@@ -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
+ PicturesSVG.hs view
@@ -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  <image x=\"" ++ show x ++ "\" y=\"" ++ show y ++ "\" width=\"" ++ show width ++ "\" height=\"" +++    show height ++ "\" xlink:href=\"" ++ name ++ "\"" ++ flipPart ++ negPart ++ "/>\n"+        where+          flipPart +              = if      fH && not fV +                then " transform=\"translate(0," ++ show (2*y + height) ++ ") scale(1,-1)\" " +                else if fV && not fH +                then " transform=\"translate(" ++ show (2*x + width) ++ ",0) scale(-1,1)\" " +                else if fV && fH +                then " transform=\"translate(" ++ show (2*x + width) ++ "," ++ show (2*y + height) ++ ") scale(-1,-1)\" " +                else ""+          negPart +              = if neg +                then " filter=\"url(#negative)\"" +                else "" ++-- 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+ = "<svg width=\"100%\" height=\"100%\" version=\"1.1\"\n" +++   "xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\">\n" +++   "<filter id=\"negative\">\n" +++   "<feColorMatrix type=\"matrix\"\n"+++   "values=\"-1 0  0  0  0  0 -1  0  0  0  0  0 -1  0  0  1  1  1  0  0\" />\n" +++   "</filter>\n"++postamble+ = "\n</svg>\n"++--+-- 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
+ QCfuns.hs view
@@ -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
+ README.txt view
@@ -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
+ RPS.hs view
@@ -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)+            +
+ Relation.hs view
@@ -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+++
+ Set.hs view
@@ -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<y		= memSet (Set xs) y+  | x==y 	= True+  | otherwise 	= False++union :: Ord a => 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<y 	= x : uni xs (y:ys)+  | x==y 	= x : uni xs ys+  | otherwise 	= y : uni (x:xs) ys++inter :: Ord a => 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<y 	= int xs (y:ys)+  | x==y 	= x : int xs ys+  | otherwise 	= int (x:xs) ys++diff :: Ord a => 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<y 	= x : dif xs (y:ys)+  | x==y 	= dif xs ys+  | otherwise 	= dif (x:xs) ys++subSet :: Ord a => 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) +  | x<y 	= False+  | x==y 	= subS xs ys+  | x>y 	= 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++
+ Setup.hs view
@@ -0,0 +1,5 @@+module Setup where++main :: IO ()++main = putStrLn "Welcome to the code package for www.haskellcraft.com."
+ Simulation/Base.hs view
@@ -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
+ Simulation/QueueState.hs view
@@ -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==[])++
+ Simulation/RandomGen.hs view
@@ -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)]+
+ Simulation/ServerState.hs view
@@ -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
+ Simulation/TopLevelServe.hs view
@@ -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+
+ UseMonads.hs view
@@ -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]}+++
+ black.jpg view

binary file changed (absent → 833 bytes)

+ blk_horse_head.jpg view

binary file changed (absent → 155729 bytes)

+ blue.jpg view

binary file changed (absent → 873 bytes)

+ red.jpg view

binary file changed (absent → 837 bytes)

+ refresh.html view
@@ -0,0 +1,18 @@+<html>+<head>+<meta http-equiv="refresh" content=2>+</head>+<body>+<h1>SVG Pictures</h1>+<p>This page will display pictures rendered by the <code>render</code>+function from <code>PicturesSVG</code>, as in+<pre>+render ((horse `beside` (flipV horse)) `above` ((flipV horse) `beside` horse))+</pre>+The module should be run in the directory containing this html file.</p>+<iframe src="svgOut.xml" width="600" height="400">+++</iframe>+</body>+</html>
+ showPic.html view
@@ -0,0 +1,20 @@+<html>+<head>+</head>+<body>+<h1>SVG Pictures</h1>+<p>This page will display pictures rendered by the <code>render</code>+function from <code>PicturesSVG</code>, as in+<pre>+render ((horse `beside` (flipV horse)) `above` ((flipV horse) `beside` horse))+</pre>+The module should be run in the directory containing this html file.</p>+<iframe src="svgOut.xml" width="600" height="400">+++</iframe>+<p>+Use you browser's refresh button to refresh the image.+</p>+</body>+</html>
+ svgOut.xml view
@@ -0,0 +1,17 @@+<svg width="100%" height="100%" version="1.1"+xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+<filter id="negative">+<feColorMatrix type="matrix"+values="-1 0  0  0  0  0 -1  0  0  0  0  0 -1  0  0  1  1  1  0  0" />+</filter>++  <image x="0" y="0" width="150" height="200" xlink:href="blk_horse_head.jpg"/>++  <image x="150" y="0" width="150" height="200" xlink:href="blk_horse_head.jpg" transform="translate(450,0) scale(-1,1)" />++  <image x="0" y="200" width="150" height="200" xlink:href="blk_horse_head.jpg" transform="translate(150,0) scale(-1,1)" />++  <image x="150" y="200" width="150" height="200" xlink:href="blk_horse_head.jpg"/>++</svg>+
+ white.jpg view

binary file changed (absent → 833 bytes)