-------------------------------------------------------------------------
--
--  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 :: Basket
basket1 = [ (Person
"Salt: 1kg",Age
139) , (Person
"Plain crisps",Age
25) , (Person
"Gin: 1lt",Age
1099) ]

basket2 :: Basket
basket2 :: Basket
basket2 = []

basket3 :: Basket
basket3 :: Basket
basket3 = [ (Person
"Salt: 1kg",Age
139) , (Person
"Plain crisps",Age
25) , (Person
"Plain crisps",Age
25) ]


-- Tuple types
-- ^^^^^^^^^^^

-- Minimum and maximum of two integers.

minAndMax :: Integer -> Integer -> (Integer,Integer)
minAndMax :: Integer -> Integer -> (Integer, Integer)
minAndMax Integer
x Integer
y
  | Integer
xInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>=Integer
y        = (Integer
y,Integer
x)
  | Bool
otherwise   = (Integer
x,Integer
y)

-- Adding a pair of intgers.

addPair :: (Integer,Integer) -> Integer
addPair :: (Integer, Integer) -> Integer
addPair (Integer
x,Integer
y) = Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y

-- Shifting around the structure of an ((Int,Int),Int).

shift :: ((Integer,Integer),Integer) -> (Integer,(Integer,Integer))
shift :: ((Integer, Integer), Integer) -> (Integer, (Integer, Integer))
shift ((Integer
x,Integer
y),Integer
z) = (Integer
x,(Integer
y,Integer
z))

-- Selecting parts of a tuple

name  :: ShopItem -> String
price :: ShopItem -> Int

name :: ShopItem -> Person
name  (Person
n,Age
p) = Person
n
price :: ShopItem -> Age
price (Person
n,Age
p) = Age
p

-- Adding a pair using the built-in selectors, fst and snd.

addPair' :: (Integer,Integer) -> Integer
addPair' :: (Integer, Integer) -> Integer
addPair' (Integer, Integer)
p = (Integer, Integer) -> Integer
forall a b. (a, b) -> a
fst (Integer, Integer)
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer, Integer) -> Integer
forall a b. (a, b) -> b
snd (Integer, Integer)
p

-- Fibonacci numbers: an efficient function, fastFib.

fibStep :: (Integer,Integer) -> (Integer,Integer)
fibStep :: (Integer, Integer) -> (Integer, Integer)
fibStep (Integer
u,Integer
v) = (Integer
v,Integer
uInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
v)

fibPair :: Integer -> (Integer,Integer)
fibPair :: Integer -> (Integer, Integer)
fibPair Integer
n
  | Integer
nInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0        = (Integer
0,Integer
1)
  | Bool
otherwise   = (Integer, Integer) -> (Integer, Integer)
fibStep (Integer -> (Integer, Integer)
fibPair (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1))

fastFib :: Integer -> Integer
fastFib :: Integer -> Integer
fastFib = (Integer, Integer) -> Integer
forall a b. (a, b) -> a
fst ((Integer, Integer) -> Integer)
-> (Integer -> (Integer, Integer)) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> (Integer, Integer)
fibPair

fibTwoStep :: Integer -> Integer -> (Integer,Integer)
fibTwoStep :: Integer -> Integer -> (Integer, Integer)
fibTwoStep Integer
x Integer
y = (Integer
y,Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
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 :: People
jemima = Person -> Age -> People
Person Person
"Electric Aunt Jemima" Age
77
ronnie :: People
ronnie = Person -> Age -> People
Person Person
"Ronnie" Age
14

-- Turning a person into a string.

showPerson :: People -> String
showPerson :: People -> Person
showPerson (Person Person
st Age
n) = Person
st Person -> Person -> Person
forall a. [a] -> [a] -> [a]
++ Person
" -- " Person -> Person -> Person
forall a. [a] -> [a] -> [a]
++ Age -> Person
forall a. Show a => a -> Person
show Age
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 (Shape -> Shape -> Bool
(Shape -> Shape -> Bool) -> (Shape -> Shape -> Bool) -> Eq Shape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Shape -> Shape -> Bool
== :: Shape -> Shape -> Bool
$c/= :: Shape -> Shape -> Bool
/= :: Shape -> Shape -> Bool
Eq,Eq Shape
Eq Shape =>
(Shape -> Shape -> Ordering)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Shape)
-> (Shape -> Shape -> Shape)
-> Ord Shape
Shape -> Shape -> Bool
Shape -> Shape -> Ordering
Shape -> Shape -> Shape
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Shape -> Shape -> Ordering
compare :: Shape -> Shape -> Ordering
$c< :: Shape -> Shape -> Bool
< :: Shape -> Shape -> Bool
$c<= :: Shape -> Shape -> Bool
<= :: Shape -> Shape -> Bool
$c> :: Shape -> Shape -> Bool
> :: Shape -> Shape -> Bool
$c>= :: Shape -> Shape -> Bool
>= :: Shape -> Shape -> Bool
$cmax :: Shape -> Shape -> Shape
max :: Shape -> Shape -> Shape
$cmin :: Shape -> Shape -> Shape
min :: Shape -> Shape -> Shape
Ord,Age -> Shape -> Person -> Person
[Shape] -> Person -> Person
Shape -> Person
(Age -> Shape -> Person -> Person)
-> (Shape -> Person) -> ([Shape] -> Person -> Person) -> Show Shape
forall a.
(Age -> a -> Person -> Person)
-> (a -> Person) -> ([a] -> Person -> Person) -> Show a
$cshowsPrec :: Age -> Shape -> Person -> Person
showsPrec :: Age -> Shape -> Person -> Person
$cshow :: Shape -> Person
show :: Shape -> Person
$cshowList :: [Shape] -> Person -> Person
showList :: [Shape] -> Person -> Person
Show,ReadPrec [Shape]
ReadPrec Shape
Age -> ReadS Shape
ReadS [Shape]
(Age -> ReadS Shape)
-> ReadS [Shape]
-> ReadPrec Shape
-> ReadPrec [Shape]
-> Read Shape
forall a.
(Age -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Age -> ReadS Shape
readsPrec :: Age -> ReadS Shape
$creadList :: ReadS [Shape]
readList :: ReadS [Shape]
$creadPrec :: ReadPrec Shape
readPrec :: ReadPrec Shape
$creadListPrec :: ReadPrec [Shape]
readListPrec :: ReadPrec [Shape]
Read)

shape1 :: Shape
shape1 = Float -> Shape
Circle Float
3.0
shape2 :: Shape
shape2 = Float -> Float -> Shape
Rectangle Float
45.9 Float
87.6

-- Pattern matching allows us to define functions by cases, as in,

isRound :: Shape -> Bool
isRound :: Shape -> Bool
isRound (Circle Float
_)      = Bool
True
isRound (Rectangle Float
_ Float
_) = Bool
False

-- and also lets us use the components of the elements:

area :: Shape -> Float
area :: Shape -> Float
area (Circle Float
r)      = Float
forall a. Floating a => a
piFloat -> Float -> Float
forall a. Num a => a -> a -> a
*Float
rFloat -> Float -> Float
forall a. Num a => a -> a -> a
*Float
r
area (Rectangle Float
h Float
w) = Float
hFloat -> Float -> Float
forall a. Num a => a -> a -> a
*Float
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 :: [Integer]
list1 = [Integer
1,Integer
2,Integer
3,Integer
4,Integer
1,Integer
4]

list2 :: [Bool]
list2 :: [Bool]
list2 = [Bool
True]

list3 :: String
list3 :: Person
list3 = [Char
'a',Char
'a',Char
'b']

list4 :: String
list4 :: Person
list4 = Person
"aab"

list5 :: [ Integer -> Integer ]
list5 :: [Integer -> Integer]
list5 = [Integer -> Integer
fastFib,Integer -> Integer
fastFib]

list6  :: [ [Integer] ]
list6 :: [[Integer]]
list6 = [[Integer
12,Integer
2],[Integer
2,Integer
12],[]]

list7 :: [Integer]
list7 :: [Integer]
list7 = [Integer
2 .. Integer
7]

list8 :: [Float]
list8 :: [Float]
list8 = [Float
3.1 .. Float
7.0]

list9 :: String
list9 :: Person
list9 = [Char
'a' .. Char
'm']

list10 :: [Integer]
list10 :: [Integer]
list10 = [Integer
7,Integer
6 .. Integer
3]

list11 :: [Float]
list11 :: [Float]
list11 = [Float
0.0,Float
0.3 .. Float
1.0]

list12 :: String
list12 :: Person
list12 = [Char
'a',Char
'c' .. Char
'n']


-- List comprehensions
-- ^^^^^^^^^^^^^^^^^^^
-- Examples of list comprehensions

ex :: [Integer]
ex :: [Integer]
ex = [Integer
2,Integer
4,Integer
7]

comp1 :: [Integer]
comp1 :: [Integer]
comp1 = [ Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
n | Integer
n<-[Integer]
ex]

comp2 :: [Bool]
comp2 :: [Bool]
comp2 = [ Integer -> Bool
isEven Integer
n | Integer
n<-[Integer]
ex ]

isEven :: Integer -> Bool
isEven :: Integer -> Bool
isEven Integer
n = (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
2 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0)

comp3 :: [Integer]
comp3 :: [Integer]
comp3 = [ Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
n | Integer
n <- [Integer]
ex , Integer -> Bool
isEven Integer
n , Integer
nInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
3 ]

-- Add all the pairs in a list of pairs.

addPairs :: [(Integer,Integer)] -> [Integer] 
addPairs :: [(Integer, Integer)] -> [Integer]
addPairs [(Integer, Integer)]
pairList = [ Integer
mInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
n | (Integer
m,Integer
n) <- [(Integer, Integer)]
pairList ]

-- Return only the sums of pairs which are increasing.

addOrdPairs :: [(Integer,Integer)] -> [Integer]
addOrdPairs :: [(Integer, Integer)] -> [Integer]
addOrdPairs [(Integer, Integer)]
pairList = [ Integer
mInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
n | (Integer
m,Integer
n) <- [(Integer, Integer)]
pairList , Integer
mInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<Integer
n ]

-- Return only the digits in a String.

digits :: String -> String
digits :: Person -> Person
digits Person
st = [ Char
ch | Char
ch<-Person
st , Char -> Bool
isDigit Char
ch ] 

-- Are all the integers in a list even? or odd?

allEven, allOdd :: [Integer] -> Bool
allEven :: [Integer] -> Bool
allEven [Integer]
xs = ([Integer]
xs [Integer] -> [Integer] -> Bool
forall a. Eq a => a -> a -> Bool
== [Integer
x | Integer
x<-[Integer]
xs, Integer -> Bool
isEven Integer
x])
allOdd :: [Integer] -> Bool
allOdd [Integer]
xs  = ([] [Integer] -> [Integer] -> Bool
forall a. Eq a => a -> a -> Bool
== [Integer
x | Integer
x<-[Integer]
xs, Integer -> Bool
isEven Integer
x])

-- Summing the radii of the circles in a list, ignores the other shapes

totalRadii :: [Shape] -> Float
totalRadii :: [Shape] -> Float
totalRadii [Shape]
shapes = [Float] -> Float
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Float
r | Circle Float
r <- [Shape]
shapes]

-- Extracting all the singletons in a list of integer lists, 
-- ignoring the other lists.

sings :: [[Integer]] -> [Integer]
sings :: [[Integer]] -> [Integer]
sings [[Integer]]
xss = [Integer
x | [Integer
x] <-[[Integer]]
xss ]


-- A library database
-- ^^^^^^^^^^^^^^^^^^

-- Types

type Person = String
type Book   = String

type Database = [ (Person , Book) ]

-- An example database.

exampleBase :: Database
exampleBase :: Database
exampleBase 
  = [ (Person
"Alice" , Person
"Tintin")  , (Person
"Anna" , Person
"Little Women") ,
      (Person
"Alice" , Person
"Asterix") , (Person
"Rory" , Person
"Tintin") ]

-- The books borrowed by a particular person in the given database.

books       :: Database -> Person -> [Book]
books :: Database -> Person -> [Person]
books Database
dBase Person
findPerson
  = [ Person
book | (Person
person,Person
book) <- Database
dBase , Person
personPerson -> Person -> Bool
forall a. Eq a => a -> a -> Bool
==Person
findPerson ]

-- Making a loan is done by adding a pair to the database.

makeLoan   :: Database -> Person -> Book -> Database
makeLoan :: Database -> Person -> Person -> Database
makeLoan Database
dBase Person
pers Person
bk = [ (Person
pers,Person
bk) ] Database -> Database -> Database
forall a. [a] -> [a] -> [a]
++ Database
dBase

-- To return a loan.

returnLoan   :: Database -> Person -> Book -> Database
returnLoan :: Database -> Person -> Person -> Database
returnLoan Database
dBase Person
pers Person
bk
  = [ (Person, Person)
pair | (Person, Person)
pair <- Database
dBase , (Person, Person)
pair (Person, Person) -> (Person, Person) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Person
pers,Person
bk) ]

-- Testing the database.

-- Commented out because borrowed is not defined here.

-- test1 :: Bool
-- test1 = borrowed exampleBase "Asterix"

test2 :: Database
test2 :: Database
test2 = Database -> Person -> Person -> Database
makeLoan Database
exampleBase Person
"Alice" Person
"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 :: Database -> Person -> Person -> Bool
prop_db1 Database
dBase Person
pers Person
bk =
    Person -> [Person] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Person
bk [Person]
loanedAfterLoan Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
         where
           afterLoan :: Database
afterLoan = Database -> Person -> Person -> Database
makeLoan Database
dBase Person
pers Person
bk
           loanedAfterLoan :: [Person]
loanedAfterLoan = Database -> Person -> [Person]
books Database
afterLoan Person
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 :: Database -> Person -> Person -> Bool
prop_db2 Database
dBase Person
pers Person
bk =
    Person -> [Person] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Person
bk [Person]
loanedAfterReturn Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False
         where
           afterReturn :: Database
afterReturn = Database -> Person -> Person -> Database
returnLoan Database
dBase Person
pers Person
bk
           loanedAfterReturn :: [Person]
loanedAfterReturn = Database -> Person -> [Person]
books Database
afterReturn Person
pers