+1 (315) 557-6473 

Create Functions To Manipulate An Image In Haskell Assignment Solution.


Write a program that allows users to manipulate images in Haskell language.

Requirements and Specifications

In this part of the exercise, you will build a small graphics library. Pictures will be represented as functions from 'Point's to values: -}
type Picture a = Point -> a
{- where a Point is an (x,y) coordinate: -}
type Point = (Double, Double)
{- 'Picture's are parameterised by the type of data that can appear at each coordinate. For example, to represent pictures where we only care whether a pixel is set or not we might use the type:
   Picture Bool
we will use this type as a type of 'masks' for filtering other pictures. We could think of these as pictures that have two colours: True for black and False for white (or the other way round -- until we render them, these pictures are only in our heads). -}
{- For 'real' images, we want every point in the coordinate space to be associated with a colour. We will represent colours as their RGB components, with an Alpha channel for transparency. The type for representing colours with transparency is: -}
data RGBA = MkRGBA { redChannel :: Double
                   , greenChannel :: Double
                   , blueChannel :: Double
                   , alphaChannel :: Double
  deriving Show
{- where I have named the fields for documentation purposes. Each channel is only meant to take values between 0 and 1, and we'l have to be careful to make sure that it stays that way below.
A colour image is now represented as a value of type:
      Picture RGBA
Expanding out the definition of 'Picture', we see that a picture isa function from (x,y) coordinates to RGBA colour values.
   Let's give ourselves some colours: black, white, red, green, and
   blue. Note that all these colours have the alpha channel set to 1
-- they are fully opaque. -}
Screenshots of output
Functions to manipulate an image in Haskell
Functions to manipulate an image in Haskell 1
Functions to manipulate an image in Haskell 2
Source Code
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Ex2 where
import Prelude hiding (foldr)
import Control.Exception (finally)
import Data.ByteString.Builder (Builder, word32LE, word8, word16LE, hPutBuilder)
import Data.Foldable (fold)
import Data.Semigroup (Semigroup ((<>)))
import Data.Word (Word8, Word32)
import System.IO (openFile, IOMode (..), hClose)
{- Please read this file carefully. Questions are numbered 2.X.Y and
   usually consist of unfinished definitions that you will have to
   fill in. The marks available for each question are listed
   underneath the question and answer space. There are four
   independent parts, with 31 questions overall. -}
{- This exercise is focused on programming with "Higher order"
   functions, as introduced in Week 03.
   A higher order function is a function that takes other functions as
   input. The name 'higher order' comes from the following
   classification of entities that one might find in a programming
   - 0th order entities are "data" (basically anything that can be
     printed out)
   - 1st order entities are functions that take "data" to "data"
   - 2nd order entities are functions that take (functions that take
     "data" to "data") to "data"
   - 3rd order entities are functions that take 2nd order entities to
   - .. and so on
   It is rare to see anything above 3rd order, but it can occur.
   Programming with higher order functions is sometimes called
   programming with "first class" functions. This references the idea
   that functions in Haskell are values, just like any other
   value. They can be stored in data structures, returned by
   functions, and passed as arguments to functions. That is, they are
   'first class' elements of the language, instead of being "second
   class" elements with a restricted set of operations.
   In other languages, functions that take other functions as input
   are often said to take a 'callback' function. Examples include
   methods that perform work asynchronously and call the given
   function when the work is done. Another example is the
   'java.util.List.sort' method:
   which takes a 'Comparator' argument, which is (in Java terminology)
   a 'Functional Interface', which is essentially a function. We'll
   see an example of a sorting function that takes a compare as an
   argument later on. -}
{- 2.1.0 Discarding.
   Write filter's evil twin that retains the elements of a list that
   fail the test rather than those that pass.
   Write your function using 'filter'. Do *not* write it as a
   recursive function. -}
discard :: (a -> Bool) -> [a] -> [a]
discard f xs = filter (\x -> not (f x)) xs
{- 1 MARK -}
{- 2.1.1 Summing lengths
   Use 'sum', 'map', and 'length' to compute the sum of the lengths of
   all the lists in a list of lists. For example:
      sumLengths [[], [], []] == 0
      sumLengths [[1,2], [3,4]] == 4
      sumLengths [[1], [2], [3]] == 3
      sumLengths [["no", "matter"],["what"],["is","in","the"],["lists"]] == 7
sumLengths :: [[a]] -> Int
sumLengths xs = sum (map length xs)
{- 2 MARKS -}
{- 2.1.2 Filtering and Counting
   Use 'length', 'filter' and an anonymous function to compute the
   number of elements in a list of pairs of strings and integers where
   the integer part is greater than 10. -}
numGreaterThanTen :: [(String,Int)] -> Int
numGreaterThanTen xs = length (filter gt10 xs)
   where gt10 (ss, n) = n > 10
{- 2 MARKS -}
{- 2.1.3 One-pass Average.
   Here is the 'foldr' function from Week 04. -}
foldr :: (a -> b -> b) -> b -> [a] -> b
foldr f b [] = b
foldr f b (x:xs) = f x (foldr f b xs)
{- As presented in the lecture, it is possible to use 'foldr' to
   implement many other interesting functions on lists. For example
   'sum' and 'len': -}
sumDoubles :: [Double] -> Double
sumDoubles = foldr (\x sum -> x + sum) 0
len :: [a] -> Integer
len = foldr (\_ l -> l + 1) 0
{- Putting these together, we can implement 'avg' to compute the average
   (mean) of a list of numbers: -}
avg :: [Double] -> Double
avg xs = sumDoubles xs / fromInteger (len xs)
{- Neat as this function is, it is not as efficient as it could be. It
   traverses the input list twice: once to compute the sum, and then
   again to compute the length. It would be better if we had a single
   pass that computed the sum and length simultaneously and returned a
   Implement such a function, using foldr: -}
sumAndLen :: [Double] -> (Double, Integer)
sumAndLen = foldr (\x (s, n) -> (s + x, n + 1)) (0, 0)
{- Once you have implemented your 'sumAndLen' function, this alternative
   average function will work: -}
avg' :: [Double] -> Double
avg' xs = total / fromInteger length
  where (total, length) = sumAndLen xs
{- 2 MARKS -}
{- 2.1.4 mapTree from foldTree
   Here is the 'Tree' datatype from the previous Exercise: -}
data Tree a
  = Leaf
  | Node (Tree a) a (Tree a)
  deriving Show
{- As we saw in Week 04, it is possible to write a generic recursor
   pattern for trees, similar to 'foldr': -}
foldTree :: b -> (b -> a -> b -> b) -> Tree a -> b
foldTree l n Leaf = l
foldTree l n (Node lt x rt) = n (foldTree l n lt) x (foldTree l n rt)
{- Implement 'mapTree' in terms of 'foldTree': -}
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f t = foldTree Leaf (\l x r -> (Node l (f x) r)) t
{- Here is the explicitly recursive version of 'mapTree', for
   reference: -}
mapTree0 :: (a -> b) -> Tree a -> Tree b
mapTree0 f Leaf = Leaf
mapTree0 f (Node lt x rt) = Node (mapTree0 f lt) (f x) (mapTree0 f rt)
{- 2 MARKS -}
{- 2.1.5 Flattening trees
   Use 'foldTree' to flatten a tree to list in left-to-right order: -}
flatten :: Tree a -> [a]
flatten t = foldTree [] (\l x r -> l ++ [x] ++ r) t
{- 2 MARKS -}
{- The Haskell standard library predefines a type 'Ordering' for
   describing ordering relationships between values:
      > :info Ordering
      data Ordering = LT | EQ | GT
   This type is used by the 'Ord' type class. We used the 'Ord' type
   class in Lecture 04 to write sorting functions. If a type is a
   member of the Ord type class we can compare values of that
   type. This is what allows us to use '<' and '>='. The Ord type
   class also defines a function 'compare':
      > :info Ord
      class Eq a => Ord a where
        compare :: a -> a -> Ordering
   So 'compare' returns the appropriate result for its two
   arguments. For example:
         > compare 1 2
         > compare 2 1
         > compare 1 1
   Sometimes, the default ordering for a type is not the one we
   want. For example, we might want to sort the list into descending
   order. Below, we will write sorting functions that take the
   ordering to use as an explicit argument.
   To do this, we need to isolate the idea of a thing that compares
   two values of the same type. We will use first class functions to
   do this.
   A 'Comparator' in Haskell is a function that takes two values and
   returns an 'Ordering' (satisfying some properties). Let's make a
   type synonym for Comparators: -}
type Comparator a = a -> a -> Ordering
{- Every type that is a member of the 'Ord' type class has a default
   comparator. We just write 'compare' for this, and Haskell's type
   inference mechanism will work out which one to use. However, the
   default comparator might not be the ordering that we wish to
   use. We'll now see how to build new comparators out of old ones.
   (To be a proper comparator, we ought to also have some properties
    for any comparator 'cmp':
      1. cmp x y == invertOrdering (cmp y x)
      2. if (cmp x y == LT) and (cmp y z == LT) then (cmp x z == LT)
      3. if (cmp x y == EQ) then, for all z, (cmp x z == cmp y z)
    We won't get into worrying about these for this exercise though.) -}
{- 2.2.0 Inverting Comparators.
   We can invert an 'Ordering': -}
invertOrdering :: Ordering -> Ordering
invertOrdering LT = GT
invertOrdering EQ = EQ
invertOrdering GT = LT
{- Write a function that takes as input a comparator and returns a
   comparator that implements the reverse ordering. Use
   'invertOrdering'. -}
invert :: Comparator a -> Comparator a
invert cmp x y = cmp y x
{- For example:
        > invert compare 1 2
        > invert compare 2 1
        > invert compare 1 1
{- 2.2.1 Transforming Comparators.
   If we have a 'Comparator a' and a way of turning 'b's into 'a's, we
   can build a 'Comparator b'. Implement this: -}
on :: Comparator a -> (b -> a) -> Comparator b
on cmp f = (\x y -> cmp (f x) (f y))
{- For example, to compare pairs on their first element, we might write:
       compare `on` fst :: Ord a => Comparator (a,b)
   Or to compare lists by their length:
       compare `on` length :: Comparator [a]
{- 2 MARKS -}
{- 2.2.2 Sorting with a comparator.
   Here is a Haskell implementation of merge sort that is similar to
   the one we saw in the Week 02 tutorial questions. 'mergeSort'
   handles the main recursion described above, 'split' does the
   splitting, and 'merge' does the merging.
   Try the component functions on a few examples to get a feel for how
   they work. Note that 'merge' only works as expected when the inputs
   are already sorted. -}
mergeSort :: Ord a => [a] -> [a]
mergeSort [] = []
mergeSort [x] = [x]
mergeSort xs = merge (mergeSort xs1) (mergeSort xs2)
  where (xs1, xs2) = split xs [] []
split :: [a] -> [a] -> [a] -> ([a],[a])
split [] ys zs = (ys, zs)
split [x] ys zs = (x:ys, zs)
split (y:z:xs) ys zs = split xs (y:ys) (z:zs)
merge :: Ord a => [a] -> [a] -> [a]
merge [] ys = ys
merge xs [] = xs
merge (x:xs) (y:ys) = if x < y then x : merge xs (y:ys) else y : merge (x:xs) ys
{- 'mergeSort' as written above relies on the implementation of 'Ord'
   for the type 'a' to do the comparisons. Rewrite 'mergeSort' so that
   it takes as input a 'Comparator a', instead of relying on the
   default one from the 'Ord' instance. You will need to also write a
   new definition of 'merge', called 'mergeWith'. -}
mergeSortWith :: Comparator a -> [a] -> [a]
mergeSortWith _ [] = []
mergeSortWith _ [x] = [x]
mergeSortWith comp xs = mergeWith comp (mergeSortWith comp xs1) (mergeSortWith comp xs2)
   where (xs1, xs2) = split xs [] []
mergeWith :: Comparator a -> [a] -> [a] -> [a]
mergeWith _ [] ys = ys
mergeWith _ xs [] = xs
mergeWith comp (x:xs) (y:ys) = if (comp x y) == LT then
                                    x : mergeWith comp xs (y:ys)
                                    y : mergeWith comp (x:xs) ys
{- Make sure you don't accidentally call 'mergeSort' in the recursive
   It should be the case that 'mergeSortWith compare' always gives the
   same answer as 'mergeSort'. For example:
      > mergeSortWith compare [5,2,3,4,1]
      > mergeSortWith compare ["c", "aaa", "bb"]
   But when we use the functions above, we get different orderings:
      > mergeSortWith (invert compare) [5,2,3,4,1]
      > mergeSortWith (compare `on` length) ["c", "aaa", "bb"]
{- 5 MARKS -}
{- 2.2.3 Dictionary ordering
   Write a function that takes two comparators, one that compares 'a's
   and one hat compares 'b's and makes a comparator for pairs '(a,b)',
   such that for any two pairs (a1,b1), (a2, b2):
     - if a1 < a2 then (a1,b1) < (a2,b2)
     - if a1 > a2 then (a1,b1) > (a2,b2)
     - if a1 = a2 then (a1,b1) and (a2,b2) are ordered however b1, b2 are
   (this is called "lexicographic ordering", or "dictionary ordering")
   For example:
        > (pair compare compare) (1,2) (1,3)
        > (pair compare compare) (2,2) (1,3)
        > (pair (invert compare) compare) (1,2) (1,3)
        > (pair (invert compare) compare) (2,2) (1,3)
   Hint: use a 'case'. -}
pair :: Comparator a -> Comparator b -> Comparator (a,b)
pair comp1 comp2 = compPair
      compPair (a, b) (x, y) = case comp1 a x of
         EQ -> comp2 b y
         o -> o
{- 3 MARKS -}
{- 2.2.4 Using 'mergeSortWith' and the functions above, write a function
   that sorts lists of '(Int,String)' in reverse order on the length
   of the second element of each pair.
   You should use the 'on' function, don't write the comparison by
   hand. You will also find the 'length', 'snd', and 'compare'
   functions useful. -}
sortOnReverseSndLength :: [(Int,String)] -> [(Int,String)]
sortOnReverseSndLength xs = mergeSortWith compareSndLen xs
      compareSndLen x y = (invert (compare `on` length)) (snd x) (snd y)
{- Example:
     > sortOnReverseSndLength [(1,"one"), (2,"two"), (3,"three"), (4,"four"), (5, "five"), (6, "six")]
{- 2 MARKS -}
{- In this part of the exercise, you will build a small graphics
   library. Pictures will be represented as functions from 'Point's to
   values: -}
type Picture a = Point -> a
{- where a Point is an (x,y) coordinate: -}
type Point = (Double, Double)
{- 'Picture's are parameterised by the type of data that can appear at
   each coordinate. For example, to represent pictures where we only
   care whether a pixel is set or not we might use the type:
      Picture Bool
   we will use this type as a type of 'masks' for filtering other
   pictures. We could think of these as pictures that have two
   colours: True for black and False for white (or the other way round
   -- until we render them, these pictures are only in our heads). -}
{- For 'real' images, we want every point in the coordinate space to be
   associated with a colour. We will represent colours as their RGB
   components, with an Alpha channel for transparency. The type for
   representing colours with transparency is: -}
data RGBA = MkRGBA { redChannel :: Double
                   , greenChannel :: Double
                   , blueChannel :: Double
                   , alphaChannel :: Double
  deriving Show
{- where I have named the fields for documentation purposes. Each
   channel is only meant to take values between 0 and 1, and we'll
   have to be careful to make sure that it stays that way below.
   A colour image is now represented as a value of type:
      Picture RGBA
   Expanding out the definition of 'Picture', we see that a picture is
   a function from (x,y) coordinates to RGBA colour values.
   Let's give ourselves some colours: black, white, red, green, and
   blue. Note that all these colours have the alpha channel set to 1
   -- they are fully opaque. -}
black :: RGBA
black = MkRGBA 0 0 0 1
white :: RGBA
white = MkRGBA 1 1 1 1
red :: RGBA
red = MkRGBA 1 0 0 1
green :: RGBA
green = MkRGBA 0 1 0 1
blue :: RGBA
blue = MkRGBA 0 0 1 1
{- And the lack of colour (the alphaChannel is set to 0). -}
clear :: RGBA
clear = MkRGBA 0 0 0 0
{- And a way of modifying a colour's opacity: 'opacity f c' makes the
   colour 'c' transparent by a factor of 'f' (which should be between
   0 and 1). -}
opacity :: Double -> RGBA -> RGBA
opacity factor (MkRGBA r g b a) = MkRGBA r g b (a * factor)
{- So 'opacity 0.5 red' is half transparent red. -}
{- The first picture we'll make is one that 'green' everywhere: -}
greenEverywhere :: Picture RGBA
greenEverywhere (x,y) = green
{- See? 'greenEverywhere' is a function representing a picture that
   takes a coordinate (x,y) and always returns the colour 'green', no
   matter what the coordinate is. A slightly more complex picture is
   one that is blue when the x coordinate is less than 0, and green
   when it is greater or equal 0: -}
blueAndGreen :: Picture RGBA
blueAndGreen (x,y) = if x < 0 then blue else green
{- Making pictures like this and thinking about them is all very well,
   but it is much easier to see what is going on if we can look at the
   pictures we are creating. At the bottom of this file, I have
   defined a function 'writeBMP' that takes a filename and a 'Picture
   RGBA' and writes it to a file in the BMP format. Most image viewers
   will then be able to read this format and display it on screen.
   For example (in GHCi):
       *Ex2> writeBMP "test.bmp" blueAndGreen
   will write a file called "test.bmp" in the same directory as you
   started GHCi in. Opening this file in an image viewer will let you
   see the image. Values of type 'Picture RGBA' can represent very
   large images (up to the limits of the 'Double' type), so 'writeBMP'
   only takes the coordinates in the range (-100,99) in the x and y
   directions. The origin (0,0) is at the centre of the image. -}
{- Constructing pictures directly by writing a function from coordinates
   to colours is possible but difficult. It is much more fun to build
   pictures up by combining them together. -}
{- 2.3.0 Everywhere.
   Let's start by generalising the 'greenEverywhere' picture from
   above. Write a function that takes a value and returns that value
   at all coordinates. -}
everywhere :: a -> Picture a
everywhere c = \(x,y) -> c
{- Test your function with 'writeBMP'. 'everywhere red' should generate
   a completely red image, for instance. -}
{- 1 MARK -}
{- 2.3.1 Shapes.
   To draw shapes, we won't do them using colours directly. Instead,
   we will create 'masks' that we will use to 'cut' shapes out of
   other pictures. As mentioned above, a mask is a 'Picture Bool'. We
   will describe some basic shapes using masks. For example, here is a
   function that generates a circular mask of a given radius: -}
circle :: Double -> Picture Bool
circle r = \(x, y) -> x*x + y*y <= r*r
{- So 'circle r' assigns 'True' to all points within distance 'r' of the
   origin, and 'False' otherwise. -}
{- Define a function rectangle that takes a width 'w' and a height 'h'
   and returns a picture assigning 'True' to all coordinates within
   the rectangle of width 'w' and height 'h' centred on the origin,
   and 'False' outside the rectangle. Note that the maximum distance
   along the x-axis from the origin is *half* the width, and similar
   for the height. -}
rectangle :: Double -> Double -> Picture Bool
rectangle w h = \(x, y) -> (x >= -w/2 && x < w/2) && (y >= -h/2 && y < h/2)
{- SCHEME: 1 mark for a correct definition. Half a mark off for making
   the rectangle twice as large as it ought to be. -}
{- 1 MARK -}
{- 2.3.2 Boolean operations on Pictures.
   Define the function 'pictureAND' that generates a new picture of
   'Bool's, where the boolean for a point is the "and" (&&) of the
   booleans at the same point in the two input pictures. Similarly,
   define 'pictureOR' and 'pictureNOT'. -}
pictureAND :: Picture Bool -> Picture Bool -> Picture Bool
pictureAND p q = \(x, y) -> p (x, y) && q (x, y)
pictureOR :: Picture Bool -> Picture Bool -> Picture Bool
pictureOR p q = \(x, y) -> p (x, y) || q (x, y)
pictureNOT :: Picture Bool -> Picture Bool
pictureNOT p = \(x, y) -> not (p (x, y))
{- 2 MARKS -}
{- 2.3.3 Drawing a Doughnut.
   Use the boolean operations you defined in the previous question to
   define a 'ring' shape: a circle of radius 100 with a circle of
   radius 50 cut out from the middle. -}
doughnut :: Picture Bool
doughnut = pictureAND (circle 100) (pictureNOT (circle 50))
{- 1 MARK -}
{- 2.3.4 Colouring in.
   The shape functions don't return 'Picture's with RGBA colours, so
   we can't use 'writeBMP' to look at them directly. We have to
   translate 'Bool's to actual colours.
   Write a function that takes a 'Bitmap Bool' and two colours and
   produces a 'Bitmap RGBA' that uses the first colour when the mask
   is 'True' and the second when it is 'False': -}
colourIn :: Picture Bool -> RGBA -> RGBA -> Picture RGBA
colourIn p c1 c2 = \(x, y) -> if p (x, y) then c1 else c2
{- For example,
     *Ex2> writeBMP "test.bmp" (colourIn (circle 100) green black)
   should give a green circle on a black background when you load the
   file "test.bmp" into an image viewer.
     *Ex2> writeBMP "doughnut.bmp" (colourIn doughnut blue black)
   should give a blue doughnut on a black background in the file
   "doughnut.bmp". -}
{- 1 MARK -}
{- 2.3.5 Transforming images, point-by-point.
   'colourIn' is an example of a function that transforms a picture in
   a fixed way at every point. This is a pattern that happens over and
   over, so it is worth making a higher order function that captures
   the essence of this pattern.
   Define 'mapPicture' that takes a function 'f' from 'a's to 'b's and
   a Picture of 'a's and produces a Picture of 'b's by applying the
   function 'f' at every point. -}
mapPicture :: (a -> b) -> Picture a -> Picture b
mapPicture f p = \(x, y) -> f (p (x, y))
{- It should be the case that:
      mapPicture (\b -> if b then green else black) (circle 100)
   produces the same image as
      colourIn (circle 100) green black
   Test this with 'writeBMP'. -}
{- 2 MARKS -}
{- 2.3.6 Transforming two images, point-by-point.
   'mapPicture' is useful, but sometimes we want to be able to apply a
   two argument function to two pictures simultaneously. Define a
   function 'mapPicture2' that for each point 'pt' uses the given
   function to combine the values of the two given pictures at 'pt': -}
mapPicture2 :: (a -> b -> c) -> Picture a -> Picture b -> Picture c
mapPicture2 f pa pb = \(x, y) -> f (pa (x, y)) (pb (x, y))
{- 1 MARK -}
{- 2.3.7 Varying the function, point-by-point.
   We could now go on and define mapPicture3, mapPicture4 and so on
   for combining more and more pictures.
   Instead of doing that, we can define a single function that can be
   used repeatedly. If we allow the function being used to transform
   the image to vary, as well as the argument, then we have a much
   more flexible arrangement. Define a function that takes a picture
   of /functions/ and a picture of /arguments/ and applies the
   functions to the arguments at each point. -}
pictureApply :: Picture (a -> b) -> Picture a -> Picture b
pictureApply pab pa = \(x, y) -> (pab (x, y)) (pa (x, y))
{- 2 MARKS -}
{- Now we can implement 'mapPicture' using 'everywhere' and
      mapPicture f pic = everywhere f `pictureApply` pic
   The 'everywhere f' makes a bitmap that has the function 'f' at
   every point, and 'pictureApply' applies that function to the value
   of 'pic' at every point. Try writing out the definition of
   'pictureApply' and 'everywhere' as they are used in this definition
   of 'mapPicture' to see how it works. -}
{- 2.3.8 Re-implementing mapPicture2.
    Re-implement 'mapPicture2' using **only** 'everywhere' and
    'pictureApply'. You should not need to mention points anywhere.
    HINT: follow the types! remember that giving a function that takes
    two arguments one argument returns a function expecting the other
    argument. -}
mapPicture2' :: (a -> b -> c) -> Picture a -> Picture b -> Picture c
mapPicture2' f pa pb = (everywhere f `pictureApply` pa) `pictureApply` pb
{- 1 MARK -}
{- Blending. Since we are representing colours with alpha channels for
   transparency, we can overlay one picture on top of another, letting
   the background picture show through the transparent bits of the
   foreground picture. We represent this as the ability to blend RGBA
   colours together. RGBA colours with alpha blending form a monoid
   (Week 05): we have the completely clear colour 'RGBA 0 0 0 0' and
   the monoid operation is alpha blending. The exact details of alpha
   blending are not important here. See the following blog post for a
   derivation of the definition from first principles:
   Since we have an associative operation on RGBA colours, we are
   justified in declaring RGBA an instance of the Semigroup typeclass
   (Week 05), allowing us to combine colours: -}
instance Semigroup RGBA where
  (MkRGBA r1 g1 b1 0) <> (MkRGBA r2 g2 b2 0) = mempty
  (MkRGBA r1 g1 b1 a1) <> (MkRGBA r2 g2 b2 a2) = MkRGBA r g b a
      a = a1 + a2 - a1*a2
      r = (a1*r1 + (1-a1)*a2*r2) / a
      g = (a1*g1 + (1-a1)*a2*g2) / a
      b = (a1*b1 + (1-a1)*a2*b2) / a
{- We can now write 'colour1 <> colour2' to blend colour1 and
   colour2. For example, blending 'red' and 'green' gives us just red:
       *Ex2> red <> green
       MkRGBA {redChannel = 1.0, greenChannel = 0.0, blueChannel = 0.0, alphaChannel = 1.0}
   because the "top" colour red is fully opaque. If we lower its
   opacity, then we get a mixture of red and green:
       *Ex2> opacity 0.5 red <> green
       MkRGBA {redChannel = 0.5, greenChannel = 0.5, blueChannel = 0.0, alphaChannel = 1.0}
   A Monoid is a Semigroup with a "zero" element. The "zero" for
   colours is the completely transparent colour: -}
instance Monoid RGBA where
  mempty = MkRGBA 0 0 0 0
  {- By default, mappend = (<>) -}
{- 2.3.9 Blending pictures.
   Use the '<>' function on any Semigroup and 'mapPicture2' to write a
   function that combines two images. We call this function 'over'
   because it is used to place one picture over another, letting the
   background picture show through the transparent parts of the
   foreground picture. -}
over :: Semigroup a => Picture a -> Picture a -> Picture a
over pa pb = mapPicture2 (<>) pa pb
{- 1 MARK -}
{- 2.3.10 Cutting out pictures.
   A more useful variant of the 'colourIn' function is one that takes
   a mask (a 'Bitmap Bool') and a image (a 'Bitmap a') and wherever
   the mask is 'True' uses the image, and wherever the mask is 'False'
   uses the 'mempty' of the monoid. When we use the Monoid structure
   on RGBA, this will correspond to leaving the cut-out parts
   transparent. We can then set a background by putting the resulting
   picture 'over' a background.
   Define the 'cut' function, using 'mapPicture2': -}
cut :: Monoid a => Picture Bool -> Picture a -> Picture a
cut pb pa = mapPicture2' cutPic pb pa
   where cutPic x y = if x then y else mempty
{- For example,
      circle 50 `cut` everywhere red
   will produce a red circle of radius 50 on a transparent background.
      (circle 50 `cut` everywhere red) `over` everywhere blue
   will produce a red circle of radius 50 on a blue background. -}
{- 1 MARK -}
{- 2.3.11 Space Transformations.
   All the functions so far have concentrated on transforming pixel
   values individually. Another class of transformations is to adjust
   the coordinates. This allows for rotates, scaling, shearing,
   flipping of images and so on.
   We can represent an arbitrary coordinate transformation as a
   function of type 'Point -> Point'. Here are some point
   transformation functions that perform translation and rotation: -}
translatePoint :: (Double,Double) -> Point -> Point
translatePoint (vx,vy) (x,y) = (x-vx, y-vy)
-- angle in radians
rotatePoint :: Double -> Point -> Point
rotatePoint angle (x,y) = ( x * cos angle - y * sin angle
                          , x * sin angle + y * cos angle)
scalePoint :: Double -> Point -> Point
scalePoint f (x,y) = (x/f, y/f)
{- Write a function that transforms a picture by the given
   transformation: -}
transform :: (Point -> Point) -> Picture a -> Picture a
transform t p = \(x, y) -> p (t (x, y))
{- For example, 'transform (rotate pi/2) (rectangle 100 200)' will
   generate a picture (of booleans) that is a rectangle rotated by
   'pi/4' radians (45 degrees). -}
{- 1 MARK -}
{- 2.3.13 Flipping Pictures
   Write functions that flip a 'Picture'. The first function should
   flip top to bottom (and bottom to top). The second should flip left
   to right (and right to left). Use 'transform' to write your
   functions. -}
flipTopBottom :: Picture a -> Picture a
flipTopBottom = transform (\(x, y) -> (x, -y))
flipLeftRight :: Picture a -> Picture a
flipLeftRight = transform (\(x, y) -> (-x, y))
{- 2 MARKS -}
{- With some point transformation functions, we can now create some
   "interesting" pictures, such as this spiral: -}
-- Three convenient functions for building
fade :: Picture RGBA -> Double -> Picture RGBA
fade pic f = mapPicture (opacity (1-f)) pic
at :: Picture a -> Point -> Picture a
at pic p = transform (translatePoint p) pic
scale :: Picture a -> Double -> Picture a
scale pic f = transform (scalePoint f) pic
picture :: Picture RGBA
picture =
  spiral 50 (purpleCircle `scale` 0.5)
  everywhere black
    spiral radius pic =
      mconcat [ pic `fade` fadeFactor `at` (dist * sin angle, dist * cos angle)
              | step <- [0..30]
              , let angle = (step / 10) * 2 * pi
                    dist = (step / 12.5) * radius
                    fadeFactor = step / 30
    purpleCircle = circle 50 `cut` redBlueGradient
    redBlueGradient (x, y) = opacity d red <> blue
      where d = (x+100) / 200
{- See also 'Ex2Main' for another picture. You can run this by doing:
     stack build
     stack exec Ex2
   If you have filled in the functions above, you will get a
   'face.bmp' file to look at. -}
{- This part of the exercise generalises the communicating processes
   from Exercise 1 to allow processes that send and recieve data of
   any type, not just booleans. These processes are also a kind of
   tree, except that now the choices after an input are represented by
   a function, instead of a branch for 'True' and a branch for
   'False'. These processes can also return a final value.
   I'll set things up, then it'll be your turn.
   'Process x a' is the type of processes that send and recieve values
   of type 'x' and terminate with a value of type 'a'.
   For example, we could think of simplified Unix processes that can
   only talk to Standard Input and Standard Output as values of type
   'Process Word8 Int'. They send and recieve 8-bit bytes
   (i.e. 'char's) and terminate with an int-value exit status. -}
data Process x a
  = End a -- marks the end of a process, returning a value of type
          -- 'a'.
  | Input (x -> Process x a) -- (Input k) requests input of a value
                             -- 'v' of type 'x', and chooses a
                             -- continuation process (k v) based on
                             -- that value.
  | Output x (Process x a) -- (Output v k) outputs a value 'v' of type
                           -- 'x' and continues as the process 'k'.
{- Let's have some example processes. First, the notGate example from
   Exercise 1, rewritten to be a member of the more general 'Process'
   type: -}
notGate :: Process Bool ()
notGate = Input (\b -> Output (not b) (End ()))
{- See how this is the same as the 'notGate' example in Exercise 1, only
   here instead of explicitly giving the two different options for the
   two possible inputs, we give a function that decides what to do
   instead. In this case, it outputs the 'not' of whatever the input
   is. Using functions instead of explicitly enumerating the cases
   leads to significantly smaller descriptions of processes in most
   cases. -}
{- Let's have another example process: this process inputs any value,
   and then outputs that same value. Note that this process is
   polymorphic in the type 'x' of values it inputs and outputs. -}
echo :: Process x ()
echo = Input (\v -> Output v (End ()))
{- We make processes 'go' in the same way as we did before. We interpret
   them, feeding the 'Input's from a list of inputs, and placing the
   'Output's into a list. There are two main differences with
   'process' from Exercise 1: we need to return the extra value
   attached to 'End', and we explicitly signal lack of input by using
   a 'Maybe' type. -}
process :: Process x a -> [x] -> (Maybe a,[x])
process (End a) inputs = (Just a, [])
process (Input k) [] = (Nothing, [])
process (Input k) (v:inputs) = process (k v) inputs
process (Output v k) inputs = (a,v:outputs)
  where (a,outputs) = process k inputs
{- For example,
      process echo ["Hello"] == (Just (),["Hello"])
{- If we have a process that communicates using 'String's, then we can
   make it actually interact with the user using 'runIO'. This
   function translates process descriptions into I/O commands. This
   function uses Haskell's basic facilites for doing real I/O. We will
   come back to this later in the course. -}
runIO :: Process String a -> IO a
runIO (End a) = return a
runIO (Input k) = do { s <- getLine; runIO (k s) }
runIO (Output x k) = do { putStrLn x; runIO k }
{- Here's an example of using 'runIO'. The '>' is the haskell prompt.
        > runIO echo
        hello -- typed by the user
   where the first 'hello' is typed by the user, and the second is
   printed by the computer. You can use runIO to test your processes
   below, interactively. -}
{- Let's make some basic processes that we can use to build larger
   processes. Your job is to write these from their specifications. -}
{- 2.4.0 'input'.
   'input' is the process that inputs a single value and then ends
   with that value. Write it.
      > runIO input
      foop -- typed by the user
input :: Process x x
input = Input (\v -> End v)
{- 1 MARK -}
{- 2.4.1 'output'.
   'output x' is the process that outputs the value x, and then ends
   with the value ().
      > runIO (output "Hello!")
output :: x -> Process x ()
output x = Output x (End ())
{- 1 MARK -}
{- 2.4.2 Upgrading of Binary Processes.
   Here is the 'Process' type from Exercise 1, renamed to prevent a
   clash with our new more general 'Process' type. -}
data BProcess
  = BEnd
  | BOutput Bool BProcess
  | BInput BProcess BProcess
  deriving Show
{- Write a function that translates a 'BProcess' into a 'Process Bool
   ()'. Whenever the 'BProcess' ends, the 'Process Bool ()' process
   should end; whenever the 'BProcess' outputs a bit 'b', the 'Process
   Bool ()' process should output 'b'; and whenever the 'BProcess'
   inputs, the 'Process Bool ()' process should input, and do whatever
   the BProcess did.
   In the other direction, write a function that translates a 'Process
   Bool ()' to a 'BProcess'. -}
bprocessToProcess :: BProcess -> Process Bool ()
bprocessToProcess BEnd = End ()
bprocessToProcess (BOutput b p) = Output b (bprocessToProcess p)
bprocessToProcess (BInput t f) = Input (\x -> if x then (bprocessToProcess t) else (bprocessToProcess f))
processToBProcess :: Process Bool () -> BProcess
processToBProcess (End _) = BEnd
processToBProcess (Output x p) = BOutput x (processToBProcess p)
processToBProcess (Input f) = BInput (processToBProcess (f True)) (processToBProcess (f False))
{- 4 MARKS -}
{- 2.4.3 Sequential composition of processes.
   In the previous exercise, sequential composition of processes had
   type 'Process -> Process -> Process'. Here, processes terminate
   with a value, which is passed on to subsequent processes. Define
   the rest of this function to complete the definition of sequential
   composition of processes.
   Here are some examples of its use:
       > runIO (input `sequ` \x -> output x)
       > runIO (input `sequ` \x -> End ())
   Note that using the the backtick notation to write 'sequ' between
   its arguments allows us to read 'p1 `sequ` \x -> p2' as "do 'p1',
   call the result 'x' and then do 'p2'". -}
sequ :: Process x a -> (a -> Process x b) -> Process x b
sequ (End x) f = f x
sequ (Input k) f = Input (\x -> sequ (k x) f)
sequ (Output x p) f = Output x (sequ p f)
{- 3 MARKS -}
{- 2.4.4 Define a process that does the same thing as 'echo' above but
   only using 'input', 'output' and 'sequ'. -}
echoFromSequ :: Process x ()
echoFromSequ = input `sequ` output
{- 1 MARK -}
{- 2.4.5 A chat bot
   Write a value of type 'Process String ()' that when run through
   'runIO' produces the following interaction:
      > runIO chatBot
      Hello! What is your name? <-- this is output
      Haskell <-- this is what the user types
      Hello Haskell! <-- this is output
   If the user enters a different name, then the final line should use
   that name instead of 'Haskell'.
   It is possible to write 'chatBot' directly using 'Output' and
   'Input', but there is a tidier approach using 'sequ' as an infix
   function between its arguments.
   To construct your response message, remember that Haskell 'String's
   are lists and you can concatenate them using '++'. -}
chatBot :: Process String ()
chatBot = output "Hello! What is your name?" `sequ` (\x -> input) `sequ` (\s -> output ("Hello " ++ s ++ "!"))
{- 4 MARKS -}
{- 3.4.8 Testing Equality of Processes.
   Let's say that we want to write a function that tests two processes
   for equality -- that is they do the same input and output
   operations, and end with the same values, for all possible
   inputs. We want to write a function of type:
      eqProcess :: Process x () -> Process x () -> Bool
   Such a function would be very helpful for debugging processes. For
   example, we could discover that there is more than one way of
   writing the same process:
      eqProcess echo (input `sequ` output) == True
   Unfortunately, it is not possible in general to write such a
   function that compares for equality. Roughly speaking, this is
   because if the type of inputs 'x' has infinitely many possible
   values, there is no way to test that both processes handle all
   infinitely many values in the same way.
   However, if we restrict the possible values that are input and
   output by the process to be a type with only finitely many values,
   for example 'Bool' only has the values 'True' and 'False', then we
   can decide equivalence between two processes.
   Complete the missing cases (the bits that are 'undefined') in the
   following function definition to write a function that decides
   equality of two processes. -}
eqProcess :: Process Bool () -> Process Bool () -> Bool
eqProcess (End ()) (End ()) =
  True -- are these processes equal?
eqProcess (Output b1 k1) (Output b2 k2) =
  (b1 == b2) && (eqProcess k1 k2)
  -- do they output the same thing, and do they
  -- do the same thing after that?
eqProcess (Input k1) (Input k2) =
  (eqProcess (k1 True) (k2 True)) && (eqProcess (k1 False) (k2 False))
  -- what are the possible input values of type Bool?
eqProcess _ _ =
  -- if they don't agree on 'End'ing, 'Input'ing or
  -- 'Output'ing, then they aren't equal
{- Try it on the 'echo' process. The following example is one that
   should return 'False':
       eqProcess echo (input `sequ` (\_ -> End ())) == False
   While the rewrite of 'echo' ought to return 'True':
       eqProcess echo (input `sequ` output) == True
{- 5 MARKS -}
{- Below are the functions implementing BMP file output. These are used
   by Part 3 of the exercise above. -}
{- 'writeBMP filename bitmap' samples 'bitmap' for the pixels in the
   range ((-100,99),(-100,99)) and outputs them as a BMP file with the
   given filename. It uses the 'buildBMP' function defined below to
   construct a 'ByteString Builder' object that describes the stream
   of bytes to write to the file. -}
writeBMP :: FilePath -> Picture RGBA -> IO ()
writeBMP filename bitmap = do
  h <- openFile filename WriteMode
  hPutBuilder h (buildBMP 200 200 bitmap)
    `finally` hClose h
{- 'buildBMP width height bitmap' returns a ByteString Builder
   containing the pixels sampled from 'bitmap' around the origin in
   the Windows BMP file format in 8 bits per channel with an 8 bit
   alpha channel. The file format details were taken from here:
   The file format is relatively simple: there is a header describing
   the image (size, resolution, colour layout), followed by the pixel
   data. We are not using any compression. Most of the header is '0'
   because we are just relying on the defaults for colour space
   correction and gamma.
   The 'LE' suffixes on all the word16/32 calls signify that BMP is a
   'little endian' format, as would be expected from its origins on
   Intel x86 systems.
   The sampling and quantization of the bitmap are quite naive. Taking
   the average of surrounding pixels would probably produce "more
   correct" images. -}
buildBMP :: Word32 -> Word32 -> Picture RGBA -> Builder
buildBMP width height bitmap = header <> pixelData
    headerSize = 122
    pixelDataSize = height * width * 4
    fileSize = headerSize + pixelDataSize
    header =
      fold [ word8 0x42, word8 0x4d -- "BM"
           , word32LE fileSize
           , word16LE 0 -- application specific
           , word16LE 0 -- application specific
           , word32LE headerSize -- offset to the pixel data
           , word32LE 108 -- DIB header size
           , word32LE width
           , word32LE height
           , word16LE 1 -- 1 colour plane
           , word16LE 32 -- 32 bits per pixel
           , word32LE 3 -- "BI_BITFIELDS" format, no compression
           , word32LE pixelDataSize
           , word32LE 2835 -- horizontal resolution: 2835 ppm (72 DPI)
           , word32LE 2835 -- vertical resolution: 2835 ppm (72 DPI)
           , word32LE 0 -- 0 colours in the palette (not using one)
           , word32LE 0 -- 0 "important" colours
           , word32LE 0x00ff0000 -- red channel bitmask
           , word32LE 0x0000ff00 -- green channel bitmask
           , word32LE 0x000000ff -- blue channel bitmask
           , word32LE 0xff000000 -- alpha channel bitmask
           , word32LE 0x57696e20 -- "Win " for LCS_WINDOWS_COLOR_SPACE
           , fold (replicate 0x24 (word8 0)) -- CIE colour space endpoints (unused)
           , word32LE 0 -- red gamma (unused)
           , word32LE 0 -- green gamma (unused)
           , word32LE 0 -- blue gamme (unused)
    pixelData =
      fold [ encode (bitmap (pixelToBitmap x y))
           | y <- [0..height-1]
           , x <- [0..width-1]
    -- coordinate space transformations
    pixelToBitmap x y =
      ( fromIntegral x - (fromIntegral width / 2)
      , fromIntegral y - (fromIntegral height / 2))
    -- pixel encoding, little endian
    encode (MkRGBA r g b a) = foldMap quantize [ b, g, r, a ]
    quantize v = word8 (round (255 * v))