-----------------------------------------------------------------------
--  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 :: Picture
horse = [[Char]
".......##...",
         [Char]
".....##..#..",
         [Char]
"...##.....#.",
         [Char]
"..#.......#.",
         [Char]
"..#...#...#.",
         [Char]
"..#...###.#.",
         [Char]
".#....#..##.",
         [Char]
"..#...#.....",
         [Char]
"...#...#....",
         [Char]
"....#..#....",
         [Char]
".....#.#....",
         [Char]
"......##...."]

-- Completely white and black pictures.

white :: Picture

white :: Picture
white = [[Char]
"......",
         [Char]
"......",
         [Char]
"......",
         [Char]
"......",
         [Char]
"......",
         [Char]
"......"]

black :: Picture
black = [[Char]
"######",
         [Char]
"######",
         [Char]
"######",
         [Char]
"######",
         [Char]
"######",
         [Char]
"######"]

-- Getting a picture onto the screen.

printPicture :: Picture -> IO ()

printPicture :: Picture -> IO ()
printPicture = [Char] -> IO ()
putStr ([Char] -> IO ()) -> (Picture -> [Char]) -> Picture -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Picture -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Picture -> [Char]) -> (Picture -> Picture) -> Picture -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> Picture -> Picture
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n")


-- Transformations of pictures.
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^

-- Reflection in a vertical mirror.

flipV :: Picture -> Picture

flipV :: Picture -> Picture
flipV = ([Char] -> [Char]) -> Picture -> Picture
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
forall a. [a] -> [a]
reverse

-- Reflection in a horizontal mirror.

flipH :: Picture -> Picture

flipH :: Picture -> Picture
flipH = Picture -> Picture
forall a. [a] -> [a]
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 :: Picture -> Picture
rotate = Picture -> Picture
flipH (Picture -> Picture) -> (Picture -> Picture) -> Picture -> Picture
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Picture -> Picture
flipV

-- One picture above another. To maintain the rectangular property,
-- the pictures need to have the same width.

above :: Picture -> Picture -> Picture

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

-- One picture next to another. To maintain the rectangular property,
-- the pictures need to have the same height.

beside :: Picture -> Picture -> Picture

beside :: Picture -> Picture -> Picture
beside = ([Char] -> [Char] -> [Char]) -> Picture -> Picture -> Picture
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++)

-- 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 :: Picture -> Picture -> Picture
superimpose = ([Char] -> [Char] -> [Char]) -> Picture -> Picture -> Picture
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Char -> Char -> Char) -> [Char] -> [Char] -> [Char]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Char
combine)

-- For the result to be '.' both components have to the '.'; otherwise
-- get the '#' character.

combine :: Char -> Char -> Char

combine :: Char -> Char -> Char
combine Char
topCh Char
bottomCh
  = if (Char
topCh Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
&& Char
bottomCh Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') 
    then Char
'.'
    else Char
'#'

-- Inverting the colours in a picture; done pointwise by invert...

invertColour :: Picture -> Picture

invertColour :: Picture -> Picture
invertColour = ([Char] -> [Char]) -> Picture -> Picture
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
invert)

-- ... which works by making the result '.' unless the input is '.'.

invert :: Char -> Char

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


-- Property

prop_rotate, prop_flipV, prop_flipH :: Picture -> Bool

prop_rotate :: Picture -> Bool
prop_rotate Picture
pic = Picture -> Picture
flipV (Picture -> Picture
flipH Picture
pic) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== Picture -> Picture
flipH (Picture -> Picture
flipV Picture
pic)

prop_flipV :: Picture -> Bool
prop_flipV Picture
pic = Picture -> Picture
flipV (Picture -> Picture
flipV Picture
pic) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== Picture
pic

prop_flipH :: Picture -> Bool
prop_flipH Picture
pic = Picture -> Picture
flipH (Picture -> Picture
flipV Picture
pic) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== Picture
pic

test_rotate, test_flipV, test_flipH :: Bool
 
test_rotate :: Bool
test_rotate = Picture -> Picture
flipV (Picture -> Picture
flipH Picture
horse) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== Picture -> Picture
flipH (Picture -> Picture
flipV Picture
horse)

test_flipV :: Bool
test_flipV = Picture -> Picture
flipV (Picture -> Picture
flipV Picture
horse) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== Picture
horse

test_flipH :: Bool
test_flipH = Picture -> Picture
flipH (Picture -> Picture
flipV Picture
horse) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== Picture
horse

-- More properties

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
pic2) Picture -> Picture -> Picture
`above` (Picture -> Picture
flipH Picture
pic1)

propAboveBeside1 :: Picture -> Picture -> Picture -> Picture -> Bool
propAboveBeside1 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) 

propAboveBeside2 :: Picture -> Picture -> Bool
propAboveBeside2 Picture
n Picture
s =
  (Picture
n Picture -> Picture -> Picture
`beside` Picture
n) Picture -> Picture -> Picture
`above` (Picture
s Picture -> Picture -> Picture
`beside` Picture
s) Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== (Picture
n Picture -> Picture -> Picture
`above` Picture
s) Picture -> Picture -> Picture
`beside` (Picture
n Picture -> Picture -> Picture
`above` Picture
s) 

propAboveBeside3 :: Picture -> Picture -> Bool
propAboveBeside3 Picture
w Picture
e =
  (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) 

propAboveBeside3Correct :: Picture -> Picture -> Property
propAboveBeside3Correct Picture
w Picture
e =
  (Picture -> Bool
forall {t :: * -> *} {a}. (Eq (t a), Foldable t) => [t a] -> Bool
rectangular Picture
w Bool -> Bool -> Bool
&& Picture -> Bool
forall {t :: * -> *} {a}. (Eq (t a), Foldable t) => [t a] -> 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) 

-- auxiliary properties and functions

notEmpty :: [a] -> Bool
notEmpty [a]
pic = [a]
pic [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= []

rectangular :: [t a] -> Bool
rectangular [t a]
pic =
  [t a] -> Bool
forall {a}. Eq a => [a] -> Bool
notEmpty [t a]
pic Bool -> Bool -> Bool
&&
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
first Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
l | t a
l <-[t a]
rest ]
  where
    (t a
first:[t a]
rest) = [t a]
pic

height, width :: Picture -> Int

height :: Picture -> Int
height = Picture -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
width :: Picture -> Int
width = [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> (Picture -> [Char]) -> Picture -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Picture -> [Char]
forall a. HasCallStack => [a] -> a
head

size :: Picture -> (Int,Int)

size :: Picture -> (Int, Int)
size Picture
pic = (Picture -> Int
width Picture
pic, Picture -> Int
height Picture
pic)

propAboveBesideFull :: Picture -> Picture -> Picture -> Picture -> Property
propAboveBesideFull Picture
nw Picture
ne Picture
sw Picture
se =
  (Picture -> Bool
forall {t :: * -> *} {a}. (Eq (t a), Foldable t) => [t a] -> Bool
rectangular Picture
nw Bool -> Bool -> Bool
&& Picture -> Bool
forall {t :: * -> *} {a}. (Eq (t a), Foldable t) => [t a] -> Bool
rectangular Picture
ne Bool -> Bool -> Bool
&& Picture -> Bool
forall {t :: * -> *} {a}. (Eq (t a), Foldable t) => [t a] -> Bool
rectangular Picture
sw Bool -> Bool -> Bool
&& Picture -> Bool
forall {t :: * -> *} {a}. (Eq (t a), Foldable t) => [t a] -> Bool
rectangular Picture
se Bool -> Bool -> Bool
&&
   Picture -> (Int, Int)
size Picture
nw (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== Picture -> (Int, Int)
size Picture
ne Bool -> Bool -> Bool
&& Picture -> (Int, Int)
size Picture
ne (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== Picture -> (Int, Int)
size Picture
se Bool -> Bool -> Bool
&& Picture -> (Int, Int)
size Picture
se (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== Picture -> (Int, Int)
size Picture
sw) Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
  (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) 

-- Using explicit generators ...


prop_1 :: Property
prop_1 = Gen Int -> (Int -> Bool) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
10)) ((Int -> Bool) -> Property) -> (Int -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
x -> Int
xInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+(Int
x::Int)

prop_2 :: Property
prop_2 = Gen Int -> (Int -> Bool) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
10)) ((Int -> Bool) -> Property) -> (Int -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
x -> Int
xInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=(Int
x::Int)

-- Generators suited to Pictures

-- chose either '.' or '#'

genChar :: Gen Char

genChar :: Gen Char
genChar = [Gen Char] -> Gen Char
forall a. HasCallStack => [Gen a] -> Gen a
oneof [Char -> Gen Char
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'.', Char -> Gen Char
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'#']

-- generate a list of length n each element from generator g.

genList :: Int -> Gen a -> Gen [a]

genList :: forall a. Int -> Gen a -> Gen [a]
genList Int
n Gen a
g = [Gen a] -> Gen [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Gen a
g | Int
i<-[Int
1..Int
n] ]

-- generate a picture of given size using '.' and '#'

genSizedPicture :: Int -> Int -> Gen [String]

genSizedPicture :: Int -> Int -> Gen Picture
genSizedPicture Int
height Int
width =
      [Gen [Char]] -> Gen Picture
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Int -> Gen Char -> Gen [Char]
forall a. Int -> Gen a -> Gen [a]
genList Int
width Gen Char
genChar | Int
i<-[Int
1::Int .. Int
height] ]

-- generate a picture of random size using '.' and '#'

genPicture :: Gen [String]

genPicture :: Gen Picture
genPicture =
    do
      Int
height <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
10)
      Int
width  <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
10)
      Int -> Int -> Gen Picture
genSizedPicture Int
height Int
width

-- generate four pictures of the *same* random size using '.' and '#'

genFourPictures :: Gen ([String],[String],[String],[String])

genFourPictures :: Gen (Picture, Picture, Picture, Picture)
genFourPictures =
    do
      Int
height <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
10)
      Int
width  <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
10)
      Picture
nw <- Int -> Int -> Gen Picture
genSizedPicture Int
height Int
width
      Picture
ne <- Int -> Int -> Gen Picture
genSizedPicture Int
height Int
width
      Picture
sw <- Int -> Int -> Gen Picture
genSizedPicture Int
height Int
width
      Picture
se <- Int -> Int -> Gen Picture
genSizedPicture Int
height Int
width
      (Picture, Picture, Picture, Picture)
-> Gen (Picture, Picture, Picture, Picture)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Picture
nw,Picture
ne,Picture
sw,Picture
se)

-- test that above and besides commute when used with four pictures
-- of the same size

prop_AboveBeside :: Property
prop_AboveBeside =
    Gen (Picture, Picture, Picture, Picture)
-> ((Picture, Picture, Picture, Picture) -> Bool) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Picture, Picture, Picture, Picture)
genFourPictures (((Picture, Picture, Picture, Picture) -> Bool) -> Property)
-> ((Picture, Picture, Picture, Picture) -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \(Picture
nw,Picture
ne,Picture
sw,Picture
se) -> Picture -> Picture -> Picture -> Picture -> Bool
propAboveBeside1 Picture
nw Picture
ne Picture
sw Picture
se