--------------------------------------------------------------------------
--
--  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 :: forall a. a -> a
id a
x = a
x

-- Extracting the first element of a pair.

fst :: (a,b) -> a

fst :: forall a b. (a, b) -> a
fst (a
x,b
y) = a
x

-- A "mystery" function

mystery :: (Bool,a) -> Char
mystery :: forall a. (Bool, a) -> Char
mystery (Bool
x,a
y) = if Bool
x then Char
'c' else Char
'd'


-- The Picture example, revisited.
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

-- The type of pictures.

type Picture = [[Char]]

-- To flip a
-- picture in a horizontal mirror, 

flipH :: Picture -> Picture
flipH :: Picture -> Picture
flipH = Picture -> Picture
forall a. [a] -> [a]
reverse

-- and to place one picture above another it is sufficient to join the two lists of
-- lines together.

above :: Picture -> Picture -> Picture
above :: Picture -> Picture -> Picture
above = Picture -> Picture -> Picture
forall a. [a] -> [a] -> [a]
(++)

-- To flip a picture in a vertical mirror.

flipV :: Picture -> Picture
flipV :: Picture -> Picture
flipV Picture
pic 
  = [ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
line | [Char]
line <- Picture
pic ]

-- To place two pictures side by side. 

beside :: Picture -> Picture -> Picture
beside :: Picture -> Picture -> Picture
beside Picture
picL Picture
picR
  = [ [Char]
lineL [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lineR | ([Char]
lineL,[Char]
lineR) <- Picture -> Picture -> [([Char], [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip Picture
picL Picture
picR ]

-- To invert the colour of a single character ...

invertChar :: Char -> Char
invertChar :: Char -> Char
invertChar Char
ch 
  = if Char
chChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.' then Char
'#' else Char
'.'

-- a line ...

invertLine :: [Char] -> [Char]
invertLine :: [Char] -> [Char]
invertLine [Char]
line 
  = [ Char -> Char
invertChar Char
ch | Char
ch <- [Char]
line ]

-- and a picture.

invertColour :: Picture -> Picture
invertColour :: Picture -> Picture
invertColour Picture
pic 
  = [ [Char] -> [Char]
invertLine [Char]
line | [Char]
line <- Picture
pic ]

-- Alternative definition of invertColour:

invertColour' :: Picture -> Picture
invertColour' :: Picture -> Picture
invertColour' Picture
pic 
  = [ [ Char -> Char
invertChar Char
ch | Char
ch <- [Char]
line ] | [Char]
line <- Picture
pic ]

-- Properties for Pictures
-- ^^^^^^^^^^^^^^^^^^^^^^^

prop_AboveFlipV, prop_AboveFlipH :: Picture -> Picture -> Bool

prop_AboveFlipV :: Picture -> Picture -> Bool
prop_AboveFlipV Picture
pic1 Picture
pic2 = 
    Picture -> Picture
flipV (Picture
pic1 Picture -> Picture -> Picture
`above` Picture
pic2) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== (Picture -> Picture
flipV Picture
pic1) Picture -> Picture -> Picture
`above` (Picture -> Picture
flipV Picture
pic2) 

prop_AboveFlipH :: Picture -> Picture -> Bool
prop_AboveFlipH Picture
pic1 Picture
pic2 = 
    Picture -> Picture
flipH (Picture
pic1 Picture -> Picture -> Picture
`above` Picture
pic2) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== (Picture -> Picture
flipH Picture
pic1) Picture -> Picture -> Picture
`above` (Picture -> Picture
flipH Picture
pic2) 

propAboveBeside :: Picture -> Picture ->  Picture -> Picture -> Bool

propAboveBeside :: Picture -> Picture -> Picture -> Picture -> Bool
propAboveBeside Picture
nw Picture
ne Picture
sw Picture
se =
  (Picture
nw Picture -> Picture -> Picture
`beside` Picture
ne) Picture -> Picture -> Picture
`above` (Picture
sw Picture -> Picture -> Picture
`beside` Picture
se) 
  Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== 
  (Picture
nw Picture -> Picture -> Picture
`above` Picture
sw) Picture -> Picture -> Picture
`beside` (Picture
ne Picture -> Picture -> Picture
`above` Picture
se) 

propAboveBeside3Correct :: Picture -> Picture -> Property

propAboveBeside3Correct :: Picture -> Picture -> Property
propAboveBeside3Correct Picture
w Picture
e =
  (Picture -> Bool
rectangular Picture
w Bool -> Bool -> Bool
&& Picture -> Bool
rectangular Picture
e Bool -> Bool -> Bool
&& Picture -> Int
height Picture
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Picture -> Int
height Picture
e) 
  Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
     (Picture
w Picture -> Picture -> Picture
`beside` Picture
e) Picture -> Picture -> Picture
`above` (Picture
w Picture -> Picture -> Picture
`beside` Picture
e) 
         Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== 
     (Picture
w Picture -> Picture -> Picture
`above` Picture
w) Picture -> Picture -> Picture
`beside` (Picture
e Picture -> Picture -> Picture
`above` Picture
e) 

rectangular :: Picture -> Bool

rectangular :: Picture -> Bool
rectangular = [Char] -> Picture -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"for you to define"

height :: Picture -> Int

height :: Picture -> Int
height = [Char] -> Picture -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: Integer -> Integer -> Integer
sumSquares Integer
n Integer
m 
  = Integer
sqN Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
sqM
    where
    sqN :: Integer
sqN = Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
n
    sqM :: Integer
sqM = Integer
mInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
m

-- Add corresponding elements in two lists; lists truncated to the length of the
-- shorter one.

addPairwise :: [Integer] -> [Integer] -> [Integer]
addPairwise :: [Integer] -> [Integer] -> [Integer]
addPairwise [Integer]
intList1 [Integer]
intList2
  = [ Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n | (Integer
m,Integer
n) <- [Integer] -> [Integer] -> [(Integer, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer]
intList1 [Integer]
intList2 ]

-- A variant of addPairwise which doesn't truncate; see book for details of how
-- it works.

addPairwise' :: [Integer] -> [Integer] -> [Integer]

addPairwise' :: [Integer] -> [Integer] -> [Integer]
addPairwise' [Integer]
intList1 [Integer]
intList2
  = [Integer]
front [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer]
rear
    where
    minLength :: Int
minLength = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
intList1) ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
intList2)
    front :: [Integer]
front     = [Integer] -> [Integer] -> [Integer]
addPairwise (Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take Int
minLength [Integer]
intList1) 
                            (Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take Int
minLength [Integer]
intList2)
    rear :: [Integer]
rear      = Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
drop Int
minLength [Integer]
intList1 [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
drop Int
minLength [Integer]
intList2

-- and a variant of this ...

addPairwise'' :: [Integer] -> [Integer] -> [Integer]

addPairwise'' :: [Integer] -> [Integer] -> [Integer]
addPairwise'' [Integer]
intList1 [Integer]
intList2
  = [Integer]
front [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer]
rear
    where
    minLength :: Int
minLength      = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
intList1) ([Integer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
intList2)
    front :: [Integer]
front          = [Integer] -> [Integer] -> [Integer]
addPairwise [Integer]
front1 [Integer]
front2
    rear :: [Integer]
rear           = [Integer]
rear1 [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer]
rear2
    ([Integer]
front1,[Integer]
rear1) = Int -> [Integer] -> ([Integer], [Integer])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
minLength [Integer]
intList1
    ([Integer]
front2,[Integer]
rear2) = Int -> [Integer] -> ([Integer], [Integer])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
minLength [Integer]
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 :: Database
codeIndex = [ (Int
4719, [Char]
"Fish Fingers" , Int
121),
              (Int
5643, [Char]
"Nappies" , Int
1010),
              (Int
3814, [Char]
"Orange Jelly", Int
56),
              (Int
1111, [Char]
"Hula Hoops", Int
21),
              (Int
1112, [Char]
"Hula Hoops (Giant)", Int
133),
              (Int
1234, [Char]
"Dry Sherry, 1lt", Int
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 :: Int
lineLength = Int
30