--------------------------------------------------------------------
--
--  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,NTree(..))
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 :: Pairs Int
pair1 = Int -> Int -> Pairs Int
forall a. a -> a -> Pairs a
Pr Int
2 Int
3    :: Pairs Int
pair2 :: Pairs [Int]
pair2 = [Int] -> [Int] -> Pairs [Int]
forall a. a -> a -> Pairs a
Pr [] [Int
3] :: Pairs [Int]
pair3 :: Pairs [a]
pair3 = [a] -> [a] -> Pairs [a]
forall a. a -> a -> Pairs a
Pr [] []  :: Pairs [a]

-- Are the two halves equal?

equalPair :: Eq a => Pairs a -> Bool
equalPair :: forall a. Eq a => Pairs a -> Bool
equalPair (Pr a
x a
y) = (a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
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 (List a -> List a -> Bool
(List a -> List a -> Bool)
-> (List a -> List a -> Bool) -> Eq (List a)
forall a. Eq a => List a -> List a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => List a -> List a -> Bool
== :: List a -> List a -> Bool
$c/= :: forall a. Eq a => List a -> List a -> Bool
/= :: List a -> List a -> Bool
Eq,Eq (List a)
Eq (List a) =>
(List a -> List a -> Ordering)
-> (List a -> List a -> Bool)
-> (List a -> List a -> Bool)
-> (List a -> List a -> Bool)
-> (List a -> List a -> Bool)
-> (List a -> List a -> List a)
-> (List a -> List a -> List a)
-> Ord (List a)
List a -> List a -> Bool
List a -> List a -> Ordering
List a -> List a -> List a
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
forall a. Ord a => Eq (List a)
forall a. Ord a => List a -> List a -> Bool
forall a. Ord a => List a -> List a -> Ordering
forall a. Ord a => List a -> List a -> List a
$ccompare :: forall a. Ord a => List a -> List a -> Ordering
compare :: List a -> List a -> Ordering
$c< :: forall a. Ord a => List a -> List a -> Bool
< :: List a -> List a -> Bool
$c<= :: forall a. Ord a => List a -> List a -> Bool
<= :: List a -> List a -> Bool
$c> :: forall a. Ord a => List a -> List a -> Bool
> :: List a -> List a -> Bool
$c>= :: forall a. Ord a => List a -> List a -> Bool
>= :: List a -> List a -> Bool
$cmax :: forall a. Ord a => List a -> List a -> List a
max :: List a -> List a -> List a
$cmin :: forall a. Ord a => List a -> List a -> List a
min :: List a -> List a -> List a
Ord,Int -> List a -> ShowS
[List a] -> ShowS
List a -> String
(Int -> List a -> ShowS)
-> (List a -> String) -> ([List a] -> ShowS) -> Show (List a)
forall a. Show a => Int -> List a -> ShowS
forall a. Show a => [List a] -> ShowS
forall a. Show a => List a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> List a -> ShowS
showsPrec :: Int -> List a -> ShowS
$cshow :: forall a. Show a => List a -> String
show :: List a -> String
$cshowList :: forall a. Show a => [List a] -> ShowS
showList :: [List a] -> ShowS
Show,ReadPrec [List a]
ReadPrec (List a)
Int -> ReadS (List a)
ReadS [List a]
(Int -> ReadS (List a))
-> ReadS [List a]
-> ReadPrec (List a)
-> ReadPrec [List a]
-> Read (List a)
forall a. Read a => ReadPrec [List a]
forall a. Read a => ReadPrec (List a)
forall a. Read a => Int -> ReadS (List a)
forall a. Read a => ReadS [List a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (List a)
readsPrec :: Int -> ReadS (List a)
$creadList :: forall a. Read a => ReadS [List a]
readList :: ReadS [List a]
$creadPrec :: forall a. Read a => ReadPrec (List a)
readPrec :: ReadPrec (List a)
$creadListPrec :: forall a. Read a => ReadPrec [List a]
readListPrec :: ReadPrec [List a]
Read)

-- Binary trees
-- ^^^^^^^^^^^^


-- Binary trees carrying elements of an arbitrary type.

data Tree a = Nil | Node a (Tree a) (Tree a)
              deriving (Tree a -> Tree a -> Bool
(Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool) -> Eq (Tree a)
forall a. Eq a => Tree a -> Tree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Tree a -> Tree a -> Bool
== :: Tree a -> Tree a -> Bool
$c/= :: forall a. Eq a => Tree a -> Tree a -> Bool
/= :: Tree a -> Tree a -> Bool
Eq,Eq (Tree a)
Eq (Tree a) =>
(Tree a -> Tree a -> Ordering)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Tree a)
-> (Tree a -> Tree a -> Tree a)
-> Ord (Tree a)
Tree a -> Tree a -> Bool
Tree a -> Tree a -> Ordering
Tree a -> Tree a -> Tree a
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
forall a. Ord a => Eq (Tree a)
forall a. Ord a => Tree a -> Tree a -> Bool
forall a. Ord a => Tree a -> Tree a -> Ordering
forall a. Ord a => Tree a -> Tree a -> Tree a
$ccompare :: forall a. Ord a => Tree a -> Tree a -> Ordering
compare :: Tree a -> Tree a -> Ordering
$c< :: forall a. Ord a => Tree a -> Tree a -> Bool
< :: Tree a -> Tree a -> Bool
$c<= :: forall a. Ord a => Tree a -> Tree a -> Bool
<= :: Tree a -> Tree a -> Bool
$c> :: forall a. Ord a => Tree a -> Tree a -> Bool
> :: Tree a -> Tree a -> Bool
$c>= :: forall a. Ord a => Tree a -> Tree a -> Bool
>= :: Tree a -> Tree a -> Bool
$cmax :: forall a. Ord a => Tree a -> Tree a -> Tree a
max :: Tree a -> Tree a -> Tree a
$cmin :: forall a. Ord a => Tree a -> Tree a -> Tree a
min :: Tree a -> Tree a -> Tree a
Ord,Int -> Tree a -> ShowS
[Tree a] -> ShowS
Tree a -> String
(Int -> Tree a -> ShowS)
-> (Tree a -> String) -> ([Tree a] -> ShowS) -> Show (Tree a)
forall a. Show a => Int -> Tree a -> ShowS
forall a. Show a => [Tree a] -> ShowS
forall a. Show a => Tree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Tree a -> ShowS
showsPrec :: Int -> Tree a -> ShowS
$cshow :: forall a. Show a => Tree a -> String
show :: Tree a -> String
$cshowList :: forall a. Show a => [Tree a] -> ShowS
showList :: [Tree a] -> ShowS
Show,ReadPrec [Tree a]
ReadPrec (Tree a)
Int -> ReadS (Tree a)
ReadS [Tree a]
(Int -> ReadS (Tree a))
-> ReadS [Tree a]
-> ReadPrec (Tree a)
-> ReadPrec [Tree a]
-> Read (Tree a)
forall a. Read a => ReadPrec [Tree a]
forall a. Read a => ReadPrec (Tree a)
forall a. Read a => Int -> ReadS (Tree a)
forall a. Read a => ReadS [Tree a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Tree a)
readsPrec :: Int -> ReadS (Tree a)
$creadList :: forall a. Read a => ReadS [Tree a]
readList :: ReadS [Tree a]
$creadPrec :: forall a. Read a => ReadPrec (Tree a)
readPrec :: ReadPrec (Tree a)
$creadListPrec :: forall a. Read a => ReadPrec [Tree a]
readListPrec :: ReadPrec [Tree a]
Read)

-- The depth of a binary tree.

depthT :: Tree a -> Integer
depthT :: forall a. Tree a -> Integer
depthT Tree a
Nil            = Integer
0
depthT (Node a
n Tree a
t1 Tree a
t2) = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (Tree a -> Integer
forall a. Tree a -> Integer
depthT Tree a
t1) (Tree a -> Integer
forall a. Tree a -> Integer
depthT Tree a
t2)

-- Turning a tree into a list.

collapse :: Tree a -> [a]
collapse :: forall a. Tree a -> [a]
collapse Tree a
Nil = []
collapse (Node a
x Tree a
t1 Tree a
t2)
  = Tree a -> [a]
forall a. Tree a -> [a]
collapse Tree a
t1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Tree a -> [a]
forall a. Tree a -> [a]
collapse Tree a
t2
--  
-- For example,
--  

collapseEG :: [Integer]
collapseEG 
 = Tree Integer -> [Integer]
forall a. Tree a -> [a]
collapse (Integer -> Tree Integer -> Tree Integer -> Tree Integer
forall a. a -> Tree a -> Tree a -> Tree a
Node Integer
12 
               (Integer -> Tree Integer -> Tree Integer -> Tree Integer
forall a. a -> Tree a -> Tree a -> Tree a
Node Integer
34 Tree Integer
forall a. Tree a
Nil Tree Integer
forall a. Tree a
Nil) 
               (Integer -> Tree Integer -> Tree Integer -> Tree Integer
forall a. a -> Tree a -> Tree a -> Tree a
Node Integer
3 (Integer -> Tree Integer -> Tree Integer -> Tree Integer
forall a. a -> Tree a -> Tree a -> Tree a
Node Integer
17 Tree Integer
forall a. Tree a
Nil Tree Integer
forall a. Tree a
Nil) Tree Integer
forall a. Tree a
Nil))

-- Mapping a function over all elements in a tree, preserving the
-- structure.

mapTree :: (a -> b) -> Tree a -> Tree b
mapTree :: forall a b. (a -> b) -> Tree a -> Tree b
mapTree a -> b
f Tree a
Nil = Tree b
forall a. Tree a
Nil
mapTree a -> b
f (Node a
x Tree a
t1 Tree a
t2)
  = b -> Tree b -> Tree b -> Tree b
forall a. a -> Tree a -> Tree a -> Tree a
Node (a -> b
f a
x) ((a -> b) -> Tree a -> Tree b
forall a b. (a -> b) -> Tree a -> Tree b
mapTree a -> b
f Tree a
t1) ((a -> b) -> Tree a -> Tree b
forall a b. (a -> b) -> Tree a -> Tree b
mapTree a -> b
f Tree a
t2)


-- The union type, Either
-- ^^^^^^^^^^^^^^^^^^^^^^

-- A union type -- defined in the Prelude.

data Either a b = Left a | Right b
                  deriving (Either a b -> Either a b -> Bool
(Either a b -> Either a b -> Bool)
-> (Either a b -> Either a b -> Bool) -> Eq (Either a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => Either a b -> Either a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => Either a b -> Either a b -> Bool
== :: Either a b -> Either a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => Either a b -> Either a b -> Bool
/= :: Either a b -> Either a b -> Bool
Eq,Eq (Either a b)
Eq (Either a b) =>
(Either a b -> Either a b -> Ordering)
-> (Either a b -> Either a b -> Bool)
-> (Either a b -> Either a b -> Bool)
-> (Either a b -> Either a b -> Bool)
-> (Either a b -> Either a b -> Bool)
-> (Either a b -> Either a b -> Either a b)
-> (Either a b -> Either a b -> Either a b)
-> Ord (Either a b)
Either a b -> Either a b -> Bool
Either a b -> Either a b -> Ordering
Either a b -> Either a b -> Either a b
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
forall a b. (Ord a, Ord b) => Eq (Either a b)
forall a b. (Ord a, Ord b) => Either a b -> Either a b -> Bool
forall a b. (Ord a, Ord b) => Either a b -> Either a b -> Ordering
forall a b.
(Ord a, Ord b) =>
Either a b -> Either a b -> Either a b
$ccompare :: forall a b. (Ord a, Ord b) => Either a b -> Either a b -> Ordering
compare :: Either a b -> Either a b -> Ordering
$c< :: forall a b. (Ord a, Ord b) => Either a b -> Either a b -> Bool
< :: Either a b -> Either a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => Either a b -> Either a b -> Bool
<= :: Either a b -> Either a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => Either a b -> Either a b -> Bool
> :: Either a b -> Either a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => Either a b -> Either a b -> Bool
>= :: Either a b -> Either a b -> Bool
$cmax :: forall a b.
(Ord a, Ord b) =>
Either a b -> Either a b -> Either a b
max :: Either a b -> Either a b -> Either a b
$cmin :: forall a b.
(Ord a, Ord b) =>
Either a b -> Either a b -> Either a b
min :: Either a b -> Either a b -> Either a b
Ord,ReadPrec [Either a b]
ReadPrec (Either a b)
Int -> ReadS (Either a b)
ReadS [Either a b]
(Int -> ReadS (Either a b))
-> ReadS [Either a b]
-> ReadPrec (Either a b)
-> ReadPrec [Either a b]
-> Read (Either a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [Either a b]
forall a b. (Read a, Read b) => ReadPrec (Either a b)
forall a b. (Read a, Read b) => Int -> ReadS (Either a b)
forall a b. (Read a, Read b) => ReadS [Either a b]
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (Either a b)
readsPrec :: Int -> ReadS (Either a b)
$creadList :: forall a b. (Read a, Read b) => ReadS [Either a b]
readList :: ReadS [Either a b]
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (Either a b)
readPrec :: ReadPrec (Either a b)
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [Either a b]
readListPrec :: ReadPrec [Either a b]
Read,Int -> Either a b -> ShowS
[Either a b] -> ShowS
Either a b -> String
(Int -> Either a b -> ShowS)
-> (Either a b -> String)
-> ([Either a b] -> ShowS)
-> Show (Either a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Either a b -> ShowS
forall a b. (Show a, Show b) => [Either a b] -> ShowS
forall a b. (Show a, Show b) => Either a b -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Either a b -> ShowS
showsPrec :: Int -> Either a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => Either a b -> String
show :: Either a b -> String
$cshowList :: forall a b. (Show a, Show b) => [Either a b] -> ShowS
showList :: [Either a b] -> ShowS
Show)

-- Examples

eitherEG1 :: Either String Int
eitherEG1 = String -> Either String Int
forall a b. a -> Either a b
Left String
"Duke of Prunes" :: Either String Int
eitherEG2 :: Either String Int
eitherEG2 = Int -> Either String Int
forall a b. b -> Either a b
Right Int
33312           :: Either String Int

-- In the left or the right?

isLeft :: Either a b -> Bool
isLeft :: forall a b. Either a b -> Bool
isLeft (Left a
_)  = Bool
True
isLeft (Right b
_) = Bool
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 :: forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> c
f b -> c
g (Left a
x)  = a -> c
f a
x
either a -> c
f b -> c
g (Right b
y) = b -> c
g b
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 :: forall a c b. (a -> c) -> Either a b -> c
applyLeft a -> c
f (Left a
x)  = a -> c
f a
x
applyLeft a -> c
f (Right b
_) = String -> c
forall a. HasCallStack => String -> a
error String
"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 :: forall a. [a] -> [a]
tl (a
_:[a]
xs) = [a]
xs
tl []     = []

-- Zero returned when division by zero,

divide :: Integer -> Integer -> Integer
divide :: Integer -> Integer -> Integer
divide Integer
n Integer
m 
  | (Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)    = Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
m
  | Bool
otherwise   = Integer
0

-- Head redefined to give a dummy value on the empty list; the value has
-- to be a parameter.

hd :: a -> [a] -> a
hd :: forall a. a -> [a] -> a
hd a
y (a
x:[a]
_) = a
x
hd a
y []    = a
y

-- Error types
-- ^^^^^^^^^^^

-- The Maybe type, as defined in the Prelude.lhs,

data Maybe a = Nothing | Just a
               deriving (Maybe a -> Maybe a -> Bool
(Maybe a -> Maybe a -> Bool)
-> (Maybe a -> Maybe a -> Bool) -> Eq (Maybe a)
forall a. Eq a => Maybe a -> Maybe a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Maybe a -> Maybe a -> Bool
== :: Maybe a -> Maybe a -> Bool
$c/= :: forall a. Eq a => Maybe a -> Maybe a -> Bool
/= :: Maybe a -> Maybe a -> Bool
Eq,Eq (Maybe a)
Eq (Maybe a) =>
(Maybe a -> Maybe a -> Ordering)
-> (Maybe a -> Maybe a -> Bool)
-> (Maybe a -> Maybe a -> Bool)
-> (Maybe a -> Maybe a -> Bool)
-> (Maybe a -> Maybe a -> Bool)
-> (Maybe a -> Maybe a -> Maybe a)
-> (Maybe a -> Maybe a -> Maybe a)
-> Ord (Maybe a)
Maybe a -> Maybe a -> Bool
Maybe a -> Maybe a -> Ordering
Maybe a -> Maybe a -> Maybe a
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
forall a. Ord a => Eq (Maybe a)
forall a. Ord a => Maybe a -> Maybe a -> Bool
forall a. Ord a => Maybe a -> Maybe a -> Ordering
forall a. Ord a => Maybe a -> Maybe a -> Maybe a
$ccompare :: forall a. Ord a => Maybe a -> Maybe a -> Ordering
compare :: Maybe a -> Maybe a -> Ordering
$c< :: forall a. Ord a => Maybe a -> Maybe a -> Bool
< :: Maybe a -> Maybe a -> Bool
$c<= :: forall a. Ord a => Maybe a -> Maybe a -> Bool
<= :: Maybe a -> Maybe a -> Bool
$c> :: forall a. Ord a => Maybe a -> Maybe a -> Bool
> :: Maybe a -> Maybe a -> Bool
$c>= :: forall a. Ord a => Maybe a -> Maybe a -> Bool
>= :: Maybe a -> Maybe a -> Bool
$cmax :: forall a. Ord a => Maybe a -> Maybe a -> Maybe a
max :: Maybe a -> Maybe a -> Maybe a
$cmin :: forall a. Ord a => Maybe a -> Maybe a -> Maybe a
min :: Maybe a -> Maybe a -> Maybe a
Ord,ReadPrec [Maybe a]
ReadPrec (Maybe a)
Int -> ReadS (Maybe a)
ReadS [Maybe a]
(Int -> ReadS (Maybe a))
-> ReadS [Maybe a]
-> ReadPrec (Maybe a)
-> ReadPrec [Maybe a]
-> Read (Maybe a)
forall a. Read a => ReadPrec [Maybe a]
forall a. Read a => ReadPrec (Maybe a)
forall a. Read a => Int -> ReadS (Maybe a)
forall a. Read a => ReadS [Maybe a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (Maybe a)
readsPrec :: Int -> ReadS (Maybe a)
$creadList :: forall a. Read a => ReadS [Maybe a]
readList :: ReadS [Maybe a]
$creadPrec :: forall a. Read a => ReadPrec (Maybe a)
readPrec :: ReadPrec (Maybe a)
$creadListPrec :: forall a. Read a => ReadPrec [Maybe a]
readListPrec :: ReadPrec [Maybe a]
Read,Int -> Maybe a -> ShowS
[Maybe a] -> ShowS
Maybe a -> String
(Int -> Maybe a -> ShowS)
-> (Maybe a -> String) -> ([Maybe a] -> ShowS) -> Show (Maybe a)
forall a. Show a => Int -> Maybe a -> ShowS
forall a. Show a => [Maybe a] -> ShowS
forall a. Show a => Maybe a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Maybe a -> ShowS
showsPrec :: Int -> Maybe a -> ShowS
$cshow :: forall a. Show a => Maybe a -> String
show :: Maybe a -> String
$cshowList :: forall a. Show a => [Maybe a] -> ShowS
showList :: [Maybe a] -> ShowS
Show)

-- An error-raising division function

errDiv :: Integer -> Integer -> Maybe Integer
errDiv :: Integer -> Integer -> Maybe Integer
errDiv Integer
n Integer
m 
  | (Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)    = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
m)
  | Bool
otherwise   = Maybe Integer
forall a. Maybe a
Nothing 

-- The function mapMaybe transmits an error value though the application of
-- the function g. 

mapMaybe :: (a -> b) -> Maybe a -> Maybe b

mapMaybe :: forall a b. (a -> b) -> Maybe a -> Maybe b
mapMaybe a -> b
g Maybe a
Nothing  = Maybe b
forall a. Maybe a
Nothing
mapMaybe a -> b
g (Just a
x) = b -> Maybe b
forall a. a -> Maybe a
Just (a -> b
g a
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 :: forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
n a -> b
f Maybe a
Nothing  = b
n
maybe b
n a -> b
f (Just a
x) = a -> b
f a
x

-- Examples

handle1, handle2 :: Integer
handle1 :: Integer
handle1 = Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
56 (Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+) ((Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall a b. (a -> b) -> Maybe a -> Maybe b
mapMaybe (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
3) (Integer -> Integer -> Maybe Integer
errDiv Integer
9 Integer
0)) 
handle2 :: Integer
handle2 = Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
56 (Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+) ((Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall a b. (a -> b) -> Maybe a -> Maybe b
mapMaybe (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
3) (Integer -> Integer -> Maybe Integer
errDiv Integer
9 Integer
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 (Edit -> Edit -> Bool
(Edit -> Edit -> Bool) -> (Edit -> Edit -> Bool) -> Eq Edit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Edit -> Edit -> Bool
== :: Edit -> Edit -> Bool
$c/= :: Edit -> Edit -> Bool
/= :: Edit -> Edit -> Bool
Eq,Int -> Edit -> ShowS
[Edit] -> ShowS
Edit -> String
(Int -> Edit -> ShowS)
-> (Edit -> String) -> ([Edit] -> ShowS) -> Show Edit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Edit -> ShowS
showsPrec :: Int -> Edit -> ShowS
$cshow :: Edit -> String
show :: Edit -> String
$cshowList :: [Edit] -> ShowS
showList :: [Edit] -> ShowS
Show)

-- Transforming one string into another, optimally,

transform :: String -> String -> [Edit]

transform :: String -> String -> [Edit]
transform [] [] = []
transform String
xs [] = [Edit
Kill]
transform [] String
ys = (Char -> Edit) -> String -> [Edit]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Edit
Insert String
ys
transform (Char
x:String
xs) (Char
y:String
ys)
  | Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
y        = Edit
Copy Edit -> [Edit] -> [Edit]
forall a. a -> [a] -> [a]
: String -> String -> [Edit]
transform String
xs String
ys
  | Bool
otherwise   = [[Edit]] -> [Edit]
best [ Edit
Delete   Edit -> [Edit] -> [Edit]
forall a. a -> [a] -> [a]
: String -> String -> [Edit]
transform String
xs (Char
yChar -> ShowS
forall a. a -> [a] -> [a]
:String
ys) ,
                         Char -> Edit
Insert Char
y Edit -> [Edit] -> [Edit]
forall a. a -> [a] -> [a]
: String -> String -> [Edit]
transform (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
xs) String
ys ,
                         Char -> Edit
Change Char
y Edit -> [Edit] -> [Edit]
forall a. a -> [a] -> [a]
: String -> String -> [Edit]
transform String
xs String
ys ]
--  
-- How do we choose the best sequence? We choose the one with the lowest
-- cost.

best :: [[Edit]] -> [Edit]

best :: [[Edit]] -> [Edit]
best [[Edit]
x]   = [Edit]
x
best ([Edit]
x:[[Edit]]
xs) 
  | [Edit] -> Int
cost [Edit]
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Edit] -> Int
cost [Edit]
b    = [Edit]
x
  | Bool
otherwise           = [Edit]
b
      where 
      b :: [Edit]
b = [[Edit]] -> [Edit]
best [[Edit]]
xs

-- The cost is given by charging one for every operation except copy,
-- which is equivalent to `leave unchanged'.

cost :: [Edit] -> Int

cost :: [Edit] -> Int
cost = [Edit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Edit] -> Int) -> ([Edit] -> [Edit]) -> [Edit] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Edit -> Bool) -> [Edit] -> [Edit]
forall a. (a -> Bool) -> [a] -> [a]
filter (Edit -> Edit -> Bool
forall a. Eq a => a -> a -> Bool
/=Edit
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 :: [Edit] -> ShowS
edit [] String
string = String
string
edit (Edit
e:[Edit]
es) [] = 
    case Edit
e of 
      Insert Char
ch -> Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: [Edit] -> ShowS
edit [Edit]
es []
      Edit
Kill -> []

edit (Edit
e:[Edit]
es) string :: String
string@(Char
x:String
xs) =
    case Edit
e of 
      Change Char
ch -> Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: [Edit] -> ShowS
edit [Edit]
es String
xs
      Edit
Copy -> Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: [Edit] -> ShowS
edit [Edit]
es String
xs
      Edit
Delete -> [Edit] -> ShowS
edit [Edit]
es String
xs
      Insert Char
ch -> Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: [Edit] -> ShowS
edit [Edit]
es String
string
      Edit
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 = a -> a
forall a. Movable a => a -> a
reflectX (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. Movable a => a -> a
reflectY

data Point = Point Float Float 
             deriving Int -> Point -> ShowS
[Point] -> ShowS
Point -> String
(Int -> Point -> ShowS)
-> (Point -> String) -> ([Point] -> ShowS) -> Show Point
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Point -> ShowS
showsPrec :: Int -> Point -> ShowS
$cshow :: Point -> String
show :: Point -> String
$cshowList :: [Point] -> ShowS
showList :: [Point] -> ShowS
Show

instance Movable Point where
  move :: Vector -> Point -> Point
move (Vec Float
v1 Float
v2) (Point Float
c1 Float
c2) = Float -> Float -> Point
Point (Float
c1Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
v1) (Float
c2Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
v2)
  reflectX :: Point -> Point
reflectX (Point Float
c1 Float
c2)  = Float -> Float -> Point
Point Float
c1 (-Float
c2)
  reflectY :: Point -> Point
reflectY (Point Float
c1 Float
c2)  = Float -> Float -> Point
Point (-Float
c1) Float
c2
  rotate180 :: Point -> Point
rotate180 (Point Float
c1 Float
c2) = Float -> Float -> Point
Point (-Float
c1) (-Float
c2)

data Figure = Line Point Point |
              Circle Point Float 
              deriving Int -> Figure -> ShowS
[Figure] -> ShowS
Figure -> String
(Int -> Figure -> ShowS)
-> (Figure -> String) -> ([Figure] -> ShowS) -> Show Figure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Figure -> ShowS
showsPrec :: Int -> Figure -> ShowS
$cshow :: Figure -> String
show :: Figure -> String
$cshowList :: [Figure] -> ShowS
showList :: [Figure] -> ShowS
Show

instance Movable Figure where
  move :: Vector -> Figure -> Figure
move Vector
v (Line Point
p1 Point
p2) = Point -> Point -> Figure
Line (Vector -> Point -> Point
forall a. Movable a => Vector -> a -> a
move Vector
v Point
p1) (Vector -> Point -> Point
forall a. Movable a => Vector -> a -> a
move Vector
v Point
p2)
  move Vector
v (Circle Point
p Float
r) = Point -> Float -> Figure
Circle (Vector -> Point -> Point
forall a. Movable a => Vector -> a -> a
move Vector
v Point
p) Float
r

  reflectX :: Figure -> Figure
reflectX (Line Point
p1 Point
p2) = Point -> Point -> Figure
Line (Point -> Point
forall a. Movable a => a -> a
reflectX Point
p1) (Point -> Point
forall a. Movable a => a -> a
reflectX Point
p2)
  reflectX (Circle Point
p Float
r) = Point -> Float -> Figure
Circle (Point -> Point
forall a. Movable a => a -> a
reflectX Point
p) Float
r

  reflectY :: Figure -> Figure
reflectY (Line Point
p1 Point
p2) = Point -> Point -> Figure
Line (Point -> Point
forall a. Movable a => a -> a
reflectY Point
p1) (Point -> Point
forall a. Movable a => a -> a
reflectY Point
p2)
  reflectY (Circle Point
p Float
r) = Point -> Float -> Figure
Circle (Point -> Point
forall a. Movable a => a -> a
reflectY Point
p) Float
r

instance Movable a => Movable [a] where
  move :: Vector -> [a] -> [a]
move Vector
v   = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Vector -> a -> a
forall a. Movable a => Vector -> a -> a
move Vector
v)
  reflectX :: [a] -> [a]
reflectX = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
forall a. Movable a => a -> a
reflectX
  reflectY :: [a] -> [a]
reflectY = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
forall a. Movable a => a -> a
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 :: Name a -> String
lookName (Pair a
obj String
nm) = String
nm
  giveName :: String -> Name a -> Name a
giveName String
nm (Pair a
obj String
_) = (a -> String -> Name a
forall a. a -> String -> Name a
Pair a
obj String
nm)

-- Putting together classes
-- ^^^^^^^^^^^^^^^^^^^^^^^^

-- See the text for details of what is going on here.

mapName :: (a -> b) -> Name a -> Name b

mapName :: forall a b. (a -> b) -> Name a -> Name b
mapName a -> b
f (Pair a
obj String
nm) = b -> String -> Name b
forall a. a -> String -> Name a
Pair (a -> b
f a
obj) String
nm

instance Movable a => Movable (Name a) where
  move :: Vector -> Name a -> Name a
move Vector
v   = (a -> a) -> Name a -> Name a
forall a b. (a -> b) -> Name a -> Name b
mapName (Vector -> a -> a
forall a. Movable a => Vector -> a -> a
move Vector
v)
  reflectX :: Name a -> Name a
reflectX = (a -> a) -> Name a -> Name a
forall a b. (a -> b) -> Name a -> Name b
mapName a -> a
forall a. Movable a => a -> a
reflectX
  reflectY :: Name a -> Name a
reflectY = (a -> a) -> Name a -> Name a
forall a b. (a -> b) -> Name a -> Name b
mapName a -> a
forall a. Movable a => a -> a
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 :: Gen (Tree a)
arbitrary = (Int -> Gen (Tree a)) -> Gen (Tree a)
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen (Tree a)
forall a. Arbitrary a => Int -> Gen (Tree a)
arbTree

arbTree :: Arbitrary a => Int -> Gen (Tree a)

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

-- collapse, map and mapTree

prop_collapse :: Eq b => (a -> b) -> Tree a -> Bool

prop_collapse :: forall b a. Eq b => (a -> b) -> Tree a -> Bool
prop_collapse a -> b
f =
    \Tree a
t -> (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f (Tree a -> [a]
forall a. Tree a -> [a]
collapse Tree a
t) [b] -> [b] -> Bool
forall a. Eq a => a -> a -> Bool
== Tree b -> [b]
forall a. Tree a -> [a]
collapse ((a -> b) -> Tree a -> Tree b
forall a b. (a -> b) -> Tree a -> Tree b
mapTree a -> b
f Tree a
t)

-- two different ways of measuring the size of a tree

prop_sizeT :: Tree a -> Bool

prop_sizeT :: forall a. Tree a -> Bool
prop_sizeT Tree a
t =
    Tree a -> Int
forall a. Tree a -> Int
sizeT Tree a
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Tree a -> Int
forall a. Tree a -> Int
leavesT Tree a
t) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tree a -> [a]
forall a. Tree a -> [a]
collapse Tree a
t)

-- functions used above: count the number of leaves
-- and the overall size of the tree ...

leavesT :: Tree a -> Int

leavesT :: forall a. Tree a -> Int
leavesT Tree a
Nil = Int
1
leavesT (Node a
_ Tree a
t1 Tree a
t2) = Tree a -> Int
forall a. Tree a -> Int
leavesT Tree a
t1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Tree a -> Int
forall a. Tree a -> Int
leavesT Tree a
t2

sizeT :: Tree a -> Int

sizeT :: forall a. Tree a -> Int
sizeT Tree a
Nil = Int
1
sizeT (Node a
_ Tree a
t1 Tree a
t2) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Tree a -> Int
forall a. Tree a -> Int
sizeT Tree a
t1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Tree a -> Int
forall a. Tree a -> Int
sizeT Tree a
t2

-- edit distance

-- does the transform actually do the right transformation?

prop_transform :: String -> String -> Property

prop_transform :: String -> String -> Property
prop_transform String
xs String
ys =
     String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String
xsString -> ShowS
forall a. [a] -> [a] -> [a]
++String
ys) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
15 Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> [Edit] -> ShowS
edit (String -> String -> [Edit]
transform String
xs String
ys) String
xs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ys

-- is it short enough?

prop_transformLength :: String -> String -> Property

prop_transformLength :: String -> String -> Property
prop_transformLength String
xs String
ys =
    String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String
xsString -> ShowS
forall a. [a] -> [a] -> [a]
++String
ys) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
15 Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> [Edit] -> Int
cost (String -> String -> [Edit]
transform String
xs String
ys) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ys Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1