-----------------------------------------------------------------------
--
--  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
              deriving (Int -> Temp -> ShowS
[Temp] -> ShowS
Temp -> String
(Int -> Temp -> ShowS)
-> (Temp -> String) -> ([Temp] -> ShowS) -> Show Temp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Temp -> ShowS
showsPrec :: Int -> Temp -> ShowS
$cshow :: Temp -> String
show :: Temp -> String
$cshowList :: [Temp] -> ShowS
showList :: [Temp] -> ShowS
Show)

data Season = Spring | Summer | Autumn | Winter
              deriving (Int -> Season -> ShowS
[Season] -> ShowS
Season -> String
(Int -> Season -> ShowS)
-> (Season -> String) -> ([Season] -> ShowS) -> Show Season
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Season -> ShowS
showsPrec :: Int -> Season -> ShowS
$cshow :: Season -> String
show :: Season -> String
$cshowList :: [Season] -> ShowS
showList :: [Season] -> ShowS
Show,Season -> Season -> Bool
(Season -> Season -> Bool)
-> (Season -> Season -> Bool) -> Eq Season
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Season -> Season -> Bool
== :: Season -> Season -> Bool
$c/= :: Season -> Season -> Bool
/= :: Season -> Season -> Bool
Eq,Int -> Season
Season -> Int
Season -> [Season]
Season -> Season
Season -> Season -> [Season]
Season -> Season -> Season -> [Season]
(Season -> Season)
-> (Season -> Season)
-> (Int -> Season)
-> (Season -> Int)
-> (Season -> [Season])
-> (Season -> Season -> [Season])
-> (Season -> Season -> [Season])
-> (Season -> Season -> Season -> [Season])
-> Enum Season
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Season -> Season
succ :: Season -> Season
$cpred :: Season -> Season
pred :: Season -> Season
$ctoEnum :: Int -> Season
toEnum :: Int -> Season
$cfromEnum :: Season -> Int
fromEnum :: Season -> Int
$cenumFrom :: Season -> [Season]
enumFrom :: Season -> [Season]
$cenumFromThen :: Season -> Season -> [Season]
enumFromThen :: Season -> Season -> [Season]
$cenumFromTo :: Season -> Season -> [Season]
enumFromTo :: Season -> Season -> [Season]
$cenumFromThenTo :: Season -> Season -> Season -> [Season]
enumFromThenTo :: Season -> Season -> Season -> [Season]
Enum)

-- A function over Season, defined using pattern matching.

weather :: Season -> Temp

weather :: Season -> Temp
weather Season
Summer = Temp
Hot
weather Season
_      = Temp
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
  Temp
Cold == :: Temp -> Temp -> Bool
== Temp
Cold  = Bool
True
  Temp
Hot  == Temp
Hot   = Bool
True
  Temp
_    == Temp
_     = Bool
False



-- Recursive algebraic types
-- ^^^^^^^^^^^^^^^^^^^^^^^^^

-- Expressions
-- ^^^^^^^^^^^

-- Representing an integer expression.

data Expr = Lit Integer |
            Add Expr Expr |
            Sub Expr Expr
                deriving (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expr -> ShowS
showsPrec :: Int -> Expr -> ShowS
$cshow :: Expr -> String
show :: Expr -> String
$cshowList :: [Expr] -> ShowS
showList :: [Expr] -> ShowS
Show,Expr -> Expr -> Bool
(Expr -> Expr -> Bool) -> (Expr -> Expr -> Bool) -> Eq Expr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
/= :: Expr -> Expr -> Bool
Eq)

-- Three examples from Expr.

expr1 :: Expr
expr1 = Integer -> Expr
Lit Integer
2
expr2 :: Expr
expr2 = Expr -> Expr -> Expr
Add (Integer -> Expr
Lit Integer
2) (Integer -> Expr
Lit Integer
3)
expr3 :: Expr
expr3 = Expr -> Expr -> Expr
Add (Expr -> Expr -> Expr
Sub (Integer -> Expr
Lit Integer
3) (Integer -> Expr
Lit Integer
1)) (Integer -> Expr
Lit Integer
3)  

-- Evaluating an expression.

eval :: Expr -> Integer

eval :: Expr -> Integer
eval (Lit Integer
n)     = Integer
n
eval (Add Expr
e1 Expr
e2) = (Expr -> Integer
eval Expr
e1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Expr -> Integer
eval Expr
e2)
eval (Sub Expr
e1 Expr
e2) = (Expr -> Integer
eval Expr
e1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Expr -> Integer
eval Expr
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 |
             Node Integer NTree NTree
                   deriving (Int -> NTree -> ShowS
[NTree] -> ShowS
NTree -> String
(Int -> NTree -> ShowS)
-> (NTree -> String) -> ([NTree] -> ShowS) -> Show NTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NTree -> ShowS
showsPrec :: Int -> NTree -> ShowS
$cshow :: NTree -> String
show :: NTree -> String
$cshowList :: [NTree] -> ShowS
showList :: [NTree] -> ShowS
Show,NTree -> NTree -> Bool
(NTree -> NTree -> Bool) -> (NTree -> NTree -> Bool) -> Eq NTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NTree -> NTree -> Bool
== :: NTree -> NTree -> Bool
$c/= :: NTree -> NTree -> Bool
/= :: NTree -> NTree -> Bool
Eq,ReadPrec [NTree]
ReadPrec NTree
Int -> ReadS NTree
ReadS [NTree]
(Int -> ReadS NTree)
-> ReadS [NTree]
-> ReadPrec NTree
-> ReadPrec [NTree]
-> Read NTree
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS NTree
readsPrec :: Int -> ReadS NTree
$creadList :: ReadS [NTree]
readList :: ReadS [NTree]
$creadPrec :: ReadPrec NTree
readPrec :: ReadPrec NTree
$creadListPrec :: ReadPrec [NTree]
readListPrec :: ReadPrec [NTree]
Read,Eq NTree
Eq NTree =>
(NTree -> NTree -> Ordering)
-> (NTree -> NTree -> Bool)
-> (NTree -> NTree -> Bool)
-> (NTree -> NTree -> Bool)
-> (NTree -> NTree -> Bool)
-> (NTree -> NTree -> NTree)
-> (NTree -> NTree -> NTree)
-> Ord NTree
NTree -> NTree -> Bool
NTree -> NTree -> Ordering
NTree -> NTree -> NTree
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 :: NTree -> NTree -> Ordering
compare :: NTree -> NTree -> Ordering
$c< :: NTree -> NTree -> Bool
< :: NTree -> NTree -> Bool
$c<= :: NTree -> NTree -> Bool
<= :: NTree -> NTree -> Bool
$c> :: NTree -> NTree -> Bool
> :: NTree -> NTree -> Bool
$c>= :: NTree -> NTree -> Bool
>= :: NTree -> NTree -> Bool
$cmax :: NTree -> NTree -> NTree
max :: NTree -> NTree -> NTree
$cmin :: NTree -> NTree -> NTree
min :: NTree -> NTree -> NTree
Ord)
-- Example trees

treeEx1 :: NTree
treeEx1 = Integer -> NTree -> NTree -> NTree
Node Integer
10 NTree
NilT NTree
NilT
treeEx2 :: NTree
treeEx2 = Integer -> NTree -> NTree -> NTree
Node Integer
17 (Integer -> NTree -> NTree -> NTree
Node Integer
14 NTree
NilT NTree
NilT) (Integer -> NTree -> NTree -> NTree
Node Integer
20 NTree
NilT NTree
NilT)

-- Definitions of many functions are primitive recursive. For instance,

sumTree,depth :: NTree -> Integer

sumTree :: NTree -> Integer
sumTree NTree
NilT            = Integer
0
sumTree (Node Integer
n NTree
t1 NTree
t2) = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ NTree -> Integer
sumTree NTree
t1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ NTree -> Integer
sumTree NTree
t2

depth :: NTree -> Integer
depth NTree
NilT             = Integer
0
depth (Node Integer
n NTree
t1 NTree
t2)  = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (NTree -> Integer
depth NTree
t1) (NTree -> Integer
depth NTree
t2)

-- How many times does an integer occur in a tree?

occurs :: NTree -> Integer -> Integer

occurs :: NTree -> Integer -> Integer
occurs NTree
NilT Integer
p = Integer
0
occurs (Node Integer
n NTree
t1 NTree
t2) Integer
p
  | Integer
nInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
p        = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ NTree -> Integer -> Integer
occurs NTree
t1 Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ NTree -> Integer -> Integer
occurs NTree
t2 Integer
p
  | Bool
otherwise   =     NTree -> Integer -> Integer
occurs NTree
t1 Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ NTree -> Integer -> Integer
occurs NTree
t2 Integer
p


-- Rearranging expressions
-- ^^^^^^^^^^^^^^^^^^^^^^^

-- Right-associating additions in expressions.

assoc :: Expr -> Expr

assoc :: Expr -> Expr
assoc (Add (Add Expr
e1 Expr
e2) Expr
e3)
  = Expr -> Expr
assoc (Expr -> Expr -> Expr
Add Expr
e1 (Expr -> Expr -> Expr
Add Expr
e2 Expr
e3)) 
assoc (Add Expr
e1 Expr
e2) 
  = Expr -> Expr -> Expr
Add (Expr -> Expr
assoc Expr
e1) (Expr -> Expr
assoc Expr
e2) 
assoc (Sub Expr
e1 Expr
e2) 
  = Expr -> Expr -> Expr
Sub (Expr -> Expr
assoc Expr
e1) (Expr -> Expr
assoc Expr
e2)
assoc (Lit Integer
n) 
  = Integer -> Expr
Lit Integer
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 :: Person -> String
showPerson (Adult String
nm Address
ad Biog
bio) 
  = ShowS
forall a. Show a => a -> String
show String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ Address -> String
forall a. Show a => a -> String
show Address
ad String -> ShowS
forall a. [a] -> [a] -> [a]
++ Biog -> String
showBiog Biog
bio
showBiog :: Biog -> String
showBiog (Parent String
st [Person]
perList)
  = String
st String -> ShowS
forall a. [a] -> [a] -> [a]
++ Address -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Person -> String) -> [Person] -> Address
forall a b. (a -> b) -> [a] -> [b]
map Person -> String
showPerson [Person]
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 :: Gen NTree
arbitrary = (Int -> Gen NTree) -> Gen NTree
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen NTree
arbNTree

arbNTree :: Int -> Gen NTree

arbNTree :: Int -> Gen NTree
arbNTree Int
0 = NTree -> Gen NTree
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return NTree
NilT
arbNTree Int
n
    | Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0
        = [(Int, Gen NTree)] -> Gen NTree
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency[(Int
1, NTree -> Gen NTree
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return NTree
NilT),
                    (Int
3, (Integer -> NTree -> NTree -> NTree)
-> Gen Integer -> Gen NTree -> Gen NTree -> Gen NTree
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 Integer -> NTree -> NTree -> NTree
Node Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen NTree
bush Gen NTree
bush)]
          where
            bush :: Gen NTree
bush = Int -> Gen NTree
arbNTree (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2)

instance Arbitrary Expr where
  arbitrary :: Gen Expr
arbitrary = (Int -> Gen Expr) -> Gen Expr
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen Expr
arbExpr

arbExpr :: Int -> Gen Expr

arbExpr :: Int -> Gen Expr
arbExpr Int
0 = (Integer -> Expr) -> Gen Integer -> Gen Expr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Integer -> Expr
Lit Gen Integer
forall a. Arbitrary a => Gen a
arbitrary
arbExpr Int
n
    | Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0
        = [(Int, Gen Expr)] -> Gen Expr
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency[(Int
1, (Integer -> Expr) -> Gen Integer -> Gen Expr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Integer -> Expr
Lit Gen Integer
forall a. Arbitrary a => Gen a
arbitrary),
                    (Int
2, (Expr -> Expr -> Expr) -> Gen Expr -> Gen Expr -> Gen Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Expr -> Expr -> Expr
Add Gen Expr
bush Gen Expr
bush),
                    (Int
2, (Expr -> Expr -> Expr) -> Gen Expr -> Gen Expr -> Gen Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Expr -> Expr -> Expr
Sub Gen Expr
bush Gen Expr
bush)]
          where
            bush :: Gen Expr
bush = Int -> Gen Expr
arbExpr (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2)

prop_assoc :: Expr -> Bool

prop_assoc :: Expr -> Bool
prop_assoc Expr
expr = 
    Expr -> Integer
eval Expr
expr Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> Integer
eval (Expr -> Expr
assoc Expr
expr)

prop_depth :: NTree -> Bool

prop_depth :: NTree -> Bool
prop_depth NTree
t =
    NTree -> Integer
size NTree
t Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(NTree -> Integer
depth NTree
t)

size :: NTree -> Integer

size :: NTree -> Integer
size NTree
NilT             = Integer
0
size (Node Integer
n NTree
t1 NTree
t2)  = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (NTree -> Integer
size NTree
t1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (NTree -> Integer
depth NTree
t2)