Real World Haskell Chapter 6 – Haskell

Only 2 exercises in this chapter so no code to write as such – just typing the JSON type classes in.

I had to read parts of this chapter a couple of times though such as the explanation of overlapping types which wasn’t very clear to me. Plus a couple of things that were just wrong – the example of the two types that derived show that won’t compile. Well, they definitely do compile – I spent a couple of minutes scratching my head over this until I realised the authors had made a mistake; the code given in the text is the corrected version of the problem.

The other mistake was the overlapping types given in the BrokenClass example the error I get in ghci suggests to use the pragma for FlexibleInstances, not OverlappingInstances. I think this is due to a change in the compiler from when the book was written.

Exercises

Since these didn’t involve writing any code I’ll just explain how I went about solving them.
The first exercise gave me a bit of a surprise after firing up ghci:

Prelude> :m Control.Arrow
Prelude Control.Arrow> :i Arrow
class (Control.Category.Category a) => Arrow a where
  arr :: (b -> c) -> a b c
  first :: a b c -> a (b, d) (c, d)
  second :: a b c -> a (d, b) (d, c)
  (***) :: a b c -> a b' c' -> a (b, b') (c, c')
  (&&&) :: a b c -> a b c' -> a b (c, c')
  	-- Defined in Control.Arrow
instance Arrow (->) -- Defined in Control.Arrow
instance (Monad m) => Arrow (Kleisli m) -- Defined in Control.Arrow

Well, well, our old friend -> – hence the name of the module and types I guess. So looking at the signatures, second :: a b c -> a (d, b) (d, c) . Hmmm, we haven’t covered such types before except when we looked at the type of readFile back in chapter 2 which was glossed over.
So second takes an argument of type a b c and produces a result of type a (d,b) (d,c). Pretty opaque given our current knowledge – time to check Hoogle for the Arrow class.
So (->) is an instance of Arrow and second is a mirror image of first. first sends the first component of the input through the argument arrow, and copies the rest unchanged to the output.
Great! It doesn’t help me to know that part of the arrow class is explained by already understanding what an arrow is and what it does. Time to check the source code.

-- Ordinary functions are arrows.

Now this is very interesting and it was alluded to earlier in the book, we’re finally getting somewhere.

instance Arrow (->) where
        arr f = f
        first f = f *** id
        second f = id *** f
--      (f *** g) ~(x,y) = (f x, g y)
--      sorry, although the above defn is fully H'98, nhc98 can't parse it.
        (***) f g ~(x,y) = (f x, g y)

As an aside I looked up ~ which I hadn’t seen before and found it mentioned in the Haskell98 report, ~ is as an irrefutable pattern (which therefore always succeeds). In the (->) instance, second takes a function argument, f, and returns id *** f.
*** takes 2 functions, f and g, and a tuple (x, y) and creates another tuple from f x and g y.
So second results in a function which when applied to a tuple creates a new tuple with its first item unchanged – hence the name second. The remaining tuple value is the result of applying the argument of second to the second tuple value. Now here’s something we can finally test in ghci:

Prelude Control.Arrow> second Data.Char.isUpper ("Yes", 'A')
("Yes",True)

A bit more head scratching using pseudo-code to show my thought process

second :: a b c -> a (d,b) (d,c)
second isUpper

isUpper :: Char -> Bool
isUpper :: (->) Char Bool

second :: (->) Char Bool -> (->) (d, Char) (d, Bool)

second :: (Char -> Bool) -> ((d, Char) -> (d, Bool)

Clarity at last. We kind of knew this intuitively when we saw the definition of toJValue in the JSON (JObj a) instance:

instance (JSON a) => JSON (JObj a) where
    toJValue = JObject . JObj . map (second toJValue) . fromJObj

I'm a bit bothered that I only seem to be able to think in concrete terms - (second toJValue) :: (String, a) -> (String, toJValue a). Still it's all new and I haven't studied any maths since university. From background reading I understand arrows, monads and category theory are all manifest in the design of Haskell and its libraries. I expect it's going to be more of a struggle though without the theory behind the execution.

It seems nearly every chapter results in some kind of head exploding insight or revelation. In this case we've come to see concretely that the arrows we've been using in our function type declarations are instances of the general Arrow typeclass and are therefore type constructors that create functions. This leads me to wonder what other Arrow instances are used for. I feel like Columbo.

Just one more thing, class Category a => Arrow a where... I guess we'll get to categories later.

Again from ghci

:t (,)
(,) :: a -> b -> (a, b)

:t (,,)
(,,) :: a -> b -> c -> (a, b, c)

So (,) is a constructor of tuples with 2 items and (,,) is a is a constructor of tuples with 3 items.

And finally for a bit of light relief

:t (,,,,,,,,,,)
(,,,,,,,,,,)
  :: a
     -> b
     -> c
     -> d
     -> e
     -> f
     -> g
     -> h
     -> i
     -> j
     -> k
     -> (a, b, c, d, e, f, g, h, i, j, k)

I wonder how deep that hole goes? They make their compilers pretty smart these days.

Real World Haskell Chapter 5 – Scheme

For the chapter 5 JSON exercises I needed to update the prelude scheme library to add intercalate. I also wrote the following scheme files which are just ported versions of the haskell equivalents.

• prettify.ss
• simple-json.ss
• pretty-json.ss
• put-json.ss

Data types – JValue

The main headache attacking these exercises was the data type declarations. I took a very simple approach using PLT’s define-structure. This involved writing a whole lot of boilerplate code for contructors and type predicates. I think in the long run it would be a good idea to write some syntax extensions to deal with data declarations – something that allows you to write something like (data jvalue (jnumber number?) (jnull jnull?) ...) which generates the structure definition, constructors and type predicates for you. I’m too lazy to bother for now, but I’ll probably add it to the prelude later.

The first step was to define the jvalue types – as I said I used define-structure for jvalue type. The simple constructors for jstring, jnull, jbool and jnumber are not too interesting but jobject and jarray need a little extra effort. I thought about using an assoc list but I plumped for a hash-table as the underlying storage for jobjects. As scheme isn’t statically typed, the type predicate jarray ought to be defensive and check that it’s elements are all jvalue types. Luckily define-structure automatically generates type predicates which help, so internally a jarray is a simple list of jvalue elements.

(define-struct jvalue (type data))

(define (jtype-eq? value jtype)
  (and (jvalue? value)
       (eq? jtype (jvalue-type value))))

(define (jobject? value)
  (and (jtype-eq? value 'jobject)
       (andmap (hash-map (λ (k v)
                           (and (string? k) (jvalue? v)))
                         (jvalue-data value)))))

(define (jobject value)
  (if (hash? value)
      (make-jvalue 'jobject value)
      (error "jobject expects type hash : " value)))

(define (jarray? x)
  (and (jtype-eq? x 'jarray)
       (andmap jvalue? (jvalue-data x))))

(define (jarray value)
  (if (list? value)
      (make-jvalue 'jarray value)
      (error "jobject expects type array : " value)))

The Doc data type and values

I took an identical approach to creating the doc data type – with the added need to deconstruct Union and Concat values with simple accessor procedures.

(define (concat? value) (doc-type=? value 'concat))
(define (concat l r) (make-doc 'concat (cons l r)))
(define (concat-l c) (car (doc-data c)))
(define (concat-r c) (cdr (doc-data c)))

(define (union? value) (doc-type=? value 'union))
(define (union l r) (make-doc 'union (cons l r)))
(define (union-l c) (car (doc-data c)))
(define (union-r c) (cdr (doc-data c)))

There wasn’t much else of interest writing nest or fill in the general pretty-printing exercises – just a straightforward port of the haskell versions.

Pretty printing JSON unicode characters

The other points worth noting were dealing with the pretty-printing of json values. The full unicode spec is a bit over my head as are the various implementations and encodings – especially as the haskell functions introduce writing astral characters – I had to look those up.

The first thing I needed to do was to find the correct way of representing the various simple escape character literals. I couldn’t find them searching the PLT scheme documentation. Still it was easy enough for example to find the character using (string-ref “\f” 0) and so I eventually constructed an alist which I’m posting here for posterity and my own future reference.

(define simple-escapes
  '((#\backspace . "\\b")
    (#\newline   . "\\n")
    (#\page      . "\\f")
    (#\return    . "\\r")
    (#\tab       . "\\t")
    (#\\         . "\\\\")
    (#\"         . "\\\"")
    (#\/         . "\\/")))

A couple of nice things I discovered were (at least in mzscheme) support for unicode hex literal characters and formatting #\uFF is the character literal for the ascii 255 character.

(format "~c" #\page)  => "\f"
(format "~c" #\uFF)   => "ÿ"
(format "~c" #\uFFFF) => "\uFFFF"

Unfortunately there seems to be disagreement about formatting astral characters – in PLT scheme they use the literal form of #\un where n looks to be a 64 bit value.
I’ve no idea why the haskell astral values are represented the way they are:

\uA a\uB :
A = upper 10 bits + 0xd800
B = lower 10 bits + 0xdc00

Presumably it’s all there in the unicode spec. somewhere. So I decided to follow the haskell version but I’m not sure which is better or correct for JSON values. I guess it’s all there in the JSON spec too.

Real World Haskell Chapter 5 – Haskell

There are only 2 exercises in Chapter 5 which both live in the Prettify.hs file.
I’ve uploaded all of the files I created developing the JSON library for completeness and to be able to actually compile and use it.
Chapter 5 JSON library exercise solutions:

• Prettify.hs
• SimpleJSON.hs
• PrettyJSON.hs
• Main.hs
• PutJSON.hs

The files I wrote to create the libraries cabal package:

• Setup.hs
• pretty.cabal

All in all I found this chapter a bit confusing which I think is because the ideas behind it are obviously based on the built in Haskell pretty printing library which isn’t introduces until the end of the chapter. There was no real clear explanation of the structure and purpose of the different parts of the library which made reading and following some of the ideas very dry. Plus not much clarity about the placing of some of the definitions, stubs and functions.

Having said that the overall structure for writing the exercise solutions are given in the pretty and compact functions so both exercises were just a matter of adapting them to the job at hand.

Exercise 1

Keep a note of the current column (in the same way pretty does) and whenever a Line is encountered append spaces at the end of the current line to pad it out to the required width. The rest of the tree structure of the Document is maintained ‘as is’.

fill :: Int -> Doc -> Doc
fill width d = scanLines 0 [d]
    where scanLines col (d:ds) =
              case d of
                Empty        -> Empty  scanLines col ds
                Char c       -> d  scanLines (col + 1) ds
                Text s       -> d  scanLines (col + length s) ds
                Line         -> (padLine col  Line)  scanLines 0 ds
                a `Concat` b -> scanLines col (a:b:ds)
                a `Union` b  -> scanLines col (a:ds) `Union`  scanLines col (b:ds)
          scanLines _ _ = Empty
          padLine pos = text $ replicate (width - pos) ' '

Exercise 2

This works in the same way that fill does except the current line’s nesting position is maintained rather than the current item’s character position in the current line.
When an open brace or bracket is found the nesting is increased and when closing braces or brackets are found the nesting is decreased. After a new Line spaces are added to the beginning of the line according to the current nesting value. In the renderJValue function braces are implemented using only Char Doc values
- initially I also checked inside Text Doc values as well but realized that it isn’t necessary.

nest :: Int -> Doc -> Doc
nest indent d = scanLines 0 [d]
    where scanLines col (d:ds) =
              case d of
                Empty        -> d  scanLines col ds
                Char c       -> d  scanLines (col + offset c) ds
                Text s       -> d  scanLines col ds
                Line         -> d  indentLine col  scanLines col ds
                a `Concat` b -> scanLines col (a:b:ds)
                a `Union` b  -> scanLines col (a:ds) `Union`  scanLines col (b:ds)
          scanLines _ _        = Empty

          indentLine pos    = text $ replicate pos ' '
          offset c | c `elem` "{[" = indent
                   | c `elem` "}]" = negate indent
                   | otherwise     = 0

Real World Haskell Chapter 4 – Scheme

Before I could tackle the exercises in chapter 4 I think it would be useful to have some of the nice functions from Haskell’s prelude, so I wrote a prelude library to help. I’ll be updating it as I work my way through the book.
Scheme prelude and the lazy version
Interact with text file framework
First words program
Transpose text program
Chapter 4 exercise solutions

The start of chapter 4 gives a framework for transforming text files which I needed to convert into Scheme.
The only complex part is being able to invoke a scheme text file as a script, but the PLT documentation gives the answer. I’m not sure how this would work under windows, but there must be an equivalent. I’m posting the magic part here for posterity and so I can find it more easily in the future.
Their script uses exec mzscheme -cu "$0" ${1+"$@"}.
The -c switch disables loading compiled files (which I think causes some/a;; of the library functions used to be loaded and compiled when the script runs but I got tired of the extra delay caused so I’m using:

#! /bin/sh
#|
exec mzscheme -u "$0" ${1+"$@"}
|#
#lang scheme/base

I realise I have no idea how the Haskell code schedules and performs the reading and writing of the files.
I began to wonder about efficiency though or more precisely the lazy nature of Haskell and how reading in a text file line by line and processing it actually works. According to the documentation readFile the file is read in lazily line by line as required so I expect it depends on how function uses the list of strings it is passed.

interactWith function inputFile outputFile = do
  input <- readFile inputFile
  writeFile outputFile (function input)

I tried 2 different approaches in Scheme:

1. Reading in the whole file into a list of strings, then performing the transformation on each line in the list.
2. Reading and writing the file a line at a time, performing the transformation and writing it as it is read.

I went with the second option initially and so the framework code for transforming a file:

(define (main)
  (define arguments (current-command-line-arguments))
  (if (= (vector-length arguments) 2)
      (let ([in  (vector-ref arguments 0)]
            [out (vector-ref arguments 1)])
        (interact-with my-function in out))
      (error "interact-with expects exactly 2 arguments  : interact-with in-file-path out-file-path\n\tProvided : " arguments)))

The procedure that applies the line by line transformation

(define (interact-with f in out)
  (with-output-to-file out #:mode 'text #:exists 'replace
    (λ ()
      (with-input-from-file in
        (λ ()
          (let next-line ([line (read-line)])
            (cond [(eof-object? line) (void)]
                  [else (write-string (f line))
                        (newline)
                        (next-line (read-line))])))
            #:mode 'text))))

I thought of using call-with-input-file and call-with-input-file but I couldn’t find a neat way of capturing the procedure to transform each line without writing a nested procedure, but it doesn’t seem any more elegant.

I didn’t convert the FixLines to Scheme as mzscheme seems to cope with both Unix and Windows line separators (at least in the Ubuntu version.)

Exercise 1

I can see I’m going to get in a lot of trouble later on in the book coping with Haskell’s type system under Scheme but here goes with Maybe. I think there must be a way of using macros to cope with types like Maybe, but I’ll leave that as an exercise for myself. I have enough new concepts in Haskell to take on-board currently.

(define-struct maybe (value))
(define Just make-maybe)
(define Nothing (make-maybe 'Nothing))
(define (nothing? o) (equal? o Nothing))

(define (safe-head o) (if (null? o) Nothing (Just (first o))))
(define (safe-tail o) (if (null? o) Nothing (Just (rest o))))
(define (safe-last o) (if (null? o) Nothing (Just (last o))))
(define (safe-init o) (if (null? o) Nothing (Just (init o))))

The init and last procedures are in the Scheme Prelude library I wrote.

Exercise 2

I’m using values and let-values to implement an analogue of tuples for example in defining and using span and break but I ran into a problem with that which I’ll explain later. The split-with that preserves all list members:

(define (split-with+ p xs)
  (cond [(null? xs) null]
        [else (let-values ([(head) (first xs)]
                           [(pre suf) (span p (rest xs))])
                (cons (cons head pre)
                      (split-with+ p suf)))]))

The non-preserving version:

(define (split-with p xs)
  (define (split-suffix suf) (split-with p (drop-while (combine not p) suf)))
  (if (null? xs)
      null
      (let-values ([(pre suf) (span p xs)])
        (if (null? pre)
            (split-suffix suf)
            (cons pre (split-suffix suf))))))

Exercise 3

Once again it’s a little messier dealing with strings – using a higher order functional approach to deal with strings requires converting strings into lists of characters and back again. Still at least Scheme has procedures for that.

(define char-nonspace? (compose not char-whitespace?))
(define (first-word line)
  (list->string
   (take-while char-nonspace?
               (drop-while char-whitespace? (string->list line)))))

Exercise 4

The transpose procedure needs all the lines of text before it can work and so I had to switch back to my first approach for dealing with text files, namely to read the whole file into a list of strings, then apply the transformation, then write out the result.

(define (interact-with f in out) (write-lines out (f (read-lines in))))
(define (read-lines in)
  (with-input-from-file in
    (λ ()
      (let next-line ([line (read-line)])
        (if (eof-object? line)
            null
            (cons line (next-line (read-line))))))
    #:mode 'text))
(define (write-lines out ls)
  (with-output-to-file out #:mode 'text #:exists 'replace
    (λ () (for-each (λ (line) (write-string line) (newline)) ls))))

Picking the first letter of each line and and the rest of the letters from each line is a little more fiddly in Scheme but for the Haskell version I also had to write extra functions to mimic head and tail to be able to use map safely on different length lines.
I’m still not entirely happy that it doesn’t pad spaces in front of transposed lines as you’d expect but it works for lines of the same length and so that’s goods enough for now.

(define (transpose-lines lines)
  (let ([heads (apply string-append (map safe-string-first lines))]
        [tails (map safe-string-rest lines)])
    (if (string-empty? heads)
        null
        (cons heads (transpose-lines tails)))))

(define empty-string "")
(define (string-empty? s) (string=? s empty-string))
(define (safe-string-first s) (if (string-empty? s) empty-string (substring s 0 1)))
(define (safe-string-rest s)  (if (string-empty? s) empty-string (substring s 1)))

Folds Exercise 1

Basically the same as the Haskell version except for once again using string based functions instead of list based ones.

(define (as-int-fold ds)
  (cond [(string=? ds "") 0]
        [(char=? (string-ref ds 0) #\-) (- (as-int-fold (substring ds 1)))]
        [else (foldl shift-right-and-add
                     0
                     (string->list ds))]))

(define (shift-right-and-add d acc)
  (+ (* 10 acc)
     (char->digit d)))

Then for fun I decided to try using a right fold but I ran into a problem. Let’s say our string has 4 digits d1 d2 d3 d4 and the intermediate result after processing d4 and d3 is res so d1 * 1000 + (d2 * 100 + (d3 * 10 + (d4 * 1)))
At each iteration 3 values are needed – the current result, the current digit and the factor needs to be multiplied by 10 to give
So I wrote:

(define (shift-right-and-add+ d acc)
  (let-values ([(res factor) acc])
    (+ (* 10 acc)
        (char->digit d)))

But calling it with (foldr shift-right-and-add+ (values 0 1) (string->list ds)) -> error: context expected 1 value, received 2 values: 0 1
Considering I’d finished the exercise with a left fold I checked out the comments for the exercise on the Real World Haskell web site and found the delightful:

asInt_fold:: String -> Int
asInt_fold ('-':rest) = -asInt_fold (filter isDigit rest)
asInt_fold str = foldr step 0 (reverse str)
where step i acc = acc * 10 + digitToInt i

I really wish I’d had the insight to think of that. Thank you Marcus Edwards.
This means the same step function can be used as with the left fold version and gives the much more elegant:

(define (as-int-foldr ds)
  (cond [(string=? ds "") 0]
        [(char=? (string-ref ds 0) #\-) (- (as-int-foldr (substring ds 1)))]
        [else (foldr shift-right-and-add
                     0
                     (reverse (string->list ds)))]))

I won’t comment on the other solutions as they are pretty much just conversion from Haskell into the appropriate Scheme.
Except for the cycle exercise. The only way I could think of doing this in Scheme is to use delay, force and promise but that would mean re-writing all list handling functions but luckily PLT has a lazy scheme language which can be used almost interchangeably with regular scheme. I’m considering using this for future exercises, but for now this is a stand-alone exercise using the PLT lazy scheme language.

#lang lazy
(define (integers-from n) (cons n (integers-from (add1 n))))
(define (ba-cycle xs)
  (define (cycle-step x acc) (cons xs acc))
  (foldr cycle-step null (integers-from 0)))

Real World Haskell Chapter 4 – Haskell

Whew! after a long hiatus I’ve managed to return to studying Real World Haskell. Straight down to it then.
Chapter 4 exercise solutions.
FirstWords program.
Transpose words program.

Exercise 1

safeHead, safeTail, safeInit, safeLast each require a simple guard pattern to return Nothing if an empty list is passed as an argument.

safeHead :: [a] -> Maybe a
safeHead [] = Nothing
safeHead xs = Just (head xs)

safeTail :: [a] -> Maybe [a]
safeTail [] = Nothing
safeTail xs = Just (tail xs)

safeLast :: [a] -> Maybe a
safeLast [] = Nothing
safeLast xs = Just (last xs)

safeInit :: [a] -> Maybe [a]
safeInit [] = Nothing
safeInit xs = Just (init xs)

Exercise 2

The definition of splitWith isn’t very well defined so I decided to take 2 approaches

• Preserve all list members and break the list at the point the predicate returns False,
• Discard all list members where the predicate is False.

I spent much too long on this because I was convinced there would be a nice elegant way of using the pattern let (pre,suf) = span p xs in introduced earlier when writing splitLines that could be used generically in both versions but I couldn’t really find it.

Preserving version:

splitWith :: (a -> Bool) -> [a] -> [[a]]
splitWith _ []     = []
splitWith p (x:xs) = (x : pre) : splitWith p suf
    where (pre,suf) = span p xs

Discarding version:

splitWith' :: (a-> Bool) -> [a] -> [[a]]
splitWith' _ [] = []
splitWith' p xs = case pre of
                    [] -> splitSuffix
                    _  -> pre : splitSuffix
    where
      (pre,suf)    = span p xs
      splitSuffix  = splitWith' p (dropWhile (not . p) suf)

Exercise 3

I won’t post the whole program because the only relevant things are firstWord and firstWords

firstWords :: String -> String
firstWords input = unlines (map firstWord (splitLines input))

firstWord :: String -> String
firstWord ws = takeWhile nonSpace $ dropWhile isSpace ws

nonSpace :: Char -> Bool
nonSpace = not . isSpace

I could have written takeWhile (not . isSpace) $ dropWhile isSpace ws but I thought that takeWhile nonSpace is clearer to read.

Exercise 4

There is already a function in the Prelude to transpose lists but it only works on lists of equal length. I could have written
transposeFile input = unlines $ transpose $ splitLines input but it’s unlikely that the number of words per line in a text file will be constant so I decided to cope with lists of different length so that:

ABC       A137
1 2       B 48
3456  =>  C259
789       6

Although this doesn’t preserve position for columns with no entries above them – so the 6 appears as the first character on the last transformed line.

transposeLines :: [String] -> [String]
transposeLines xs = if null heads
                    then []
                    else heads : transposeLines tails
                         where heads = concat $ map safeFirst xs
                               tails = map safeRest xs

safeFirst :: [a] -> [a]
safeFirst []     = []
safeFirst (x:xs) = [x]

safeRest :: [a] -> [a]
safeRest []     = []
safeRest (x:[]) = []
safeRest (_:xs) = xs

Folds – Exercise 1

The trick of coping with negative numbers is simply to write a guard that recursively calls asInt_fold – for some reason this reminded me of writing overloaded constructors in OO languages.
To find the overall value of a string of digits d1 d2 d3 d4

a) d1 = d1
b) d1 d2 = 10 d1 + d2 = 10 a + d2
c) d1 d2 d3 = 100 d1 + 10 d2 + d3 = 10 b + d3
d) d1 d2 d3 d4 = 1000 d1 + 100 d2 + 10 d3 + d4 = 10 c + d4

Applying a function to digits from left to right implies a left fold.

asInt_fold :: String -> Int
asInt_fold ('-':xs) = - asInt_fold xs
asInt_fold xs       = foldl shiftRightAndAdd 0 xs
    where
      -- shiftRightAndAdd :: Int -> Char -> Int
      shiftRightAndAdd acc x = 10 * acc + digitToInt x

I didn’t have to extend the function to add error handling as charToInt already takes care of the cases mentioned.

Exercise 2

One thing I’m enjoying about the book is the attitude of throwing in extra parts of the language or libraries and encouraging us to go off and read about it ourselves for example introducing the Either data type and related Left and Right constructors. Having said that I couldn’t find a way of using Either without writing verbose (and ugly) code as I have to de-construct and reconstruct values throughout. It also seems like it will a maintenance headache as changing something minor in its use will require a lot of careful fiddly changes to the code. I hope late I’ll find a more elegant or robust way of using it but I’m already wary.

type ErrorMessage = String

asInt_either :: String -> Either ErrorMessage Int
asInt_either ('-':[]) = Left "No digits supplied"
asInt_either ('-':xs) = case asInt_either xs of
                          Left mess -> Left mess
                          Right val -> Right (negate val)
asInt_either xs       = foldl radixAdd (Right 0) xs
    where
      -- radixAdd :: Either ErrorMessage Int -> Char -> Either ErrorMessage Int
      radixAdd acc x =
          case acc of
            Left mess -> Left mess
            Right acc -> digitToInt' x
                where -- digitToInt' :: Char -> Either ErrorMessage Int
                      digitToInt' x = if isDigit x
                                      then Right (10 * acc + digitToInt x)
                                      else Left ("non digit '" ++ x:"'")

Exercise 3

Each step of concat is a matter of appending the current item to the previous result l1 ++ (l2 ++ (l3 ++ (l4 ++ [])))

a) l4 = l4
b) l3 ++ l4 = l3 ++ a
c) l2 ++ l3 ++ l4 = l2 ++ b
c) l1 ++ l2 ++ l3 ++ l4 = l1 ++ c

Building up the value using items from right to left means a right fold as a simple one liner.

baConcat :: [[a]] -> [a]
baConcat = foldr (++) []

Exercise 4

The recursive version of takeWhile:

baTakeWhile :: (a -> Bool) -> [a] -> [a]
baTakeWhile f [] = []
baTakeWhile f (x:xs)
 | f x       = x : baTakeWhile f xs
 | otherwise = []

Converting a recursive function that exits before the list argument is exhausted seems to be a wasteful because the fold calls its function argument for every value – but its a good exercise to think more creatively about using folds at a higher level. The key insight for me was that accumulating all items to the end of the result list (in original order) until the predicate is False is identical when traversing in reverse order to starting with an empty list and appending its value to the front of the result which lends itself a right fold.

baTakeWhile' :: (a -> Bool) -> [a] -> [a]
baTakeWhile' f xs = foldr takeStep [] xs
    where takeStep x acc = if f x then x:acc else []

Exercise 5

I had to rewrite my answer for this one because my original answer compared items pairwise along the length of the list so baGroupBy f [a,b,c,d] executes f a b, f b c, f c d until the predicate returns False.
groupBy doesn’t behave like that though – it executes : f a b, f a c, f a d until the predicate returns False.

baGroupBy :: (a -> a -> Bool) -> [a] -> [[a]]
baGroupBy f xs = foldl step [] xs
    where
    step [] x  = [[x]]
    step acc x =
        if f (head lastAdded) x
        then init acc ++ [lastAdded ++ [x]]
        else acc ++ [[x]]
            where lastAdded = last acc

My original answer though needed much more creative thinking – I transformed the list into a list of tuples using zip and ignored the last item – so [a,b,c,d] -> init [(a,b),(b,c),(c,d),(d,a)].
I’ll remember this technique in future when I need to hop pairwise through list items.

Exercise 6

any p xs can be written p xn || pxn-1 || ... || p1 || False and so we have a right fold

baAny :: (a -> Bool) -> [a] -> Bool
baAny p = foldr or False
          where or x acc = p x || acc

I would write cycle as a recursive function with no exit test and let Haskell’s laziness deal with
A right fold can be applied to an infinite list and in the past I’ve seen a right fold used to generate an infinite result list e.g. of even numbers using foldr (*2) [1..] and so

baCycle :: [a] -> [a]
baCycle xs = foldr selfAppend xs [1..]
    where selfAppend x ys = xs ++ ys

Another little trick I’ve discovered is using a tuple of (state, returnValue) as the return value the function being folded.
It feels a bit dirty though, like imperative programming, but the alternative when building up a list is to continually deconstruct and reconstruct it as in the gropBy function.
The list of words can be built up by working from the end of the given string and pre-pending each word built up form non spaces at the front of the result which means I can use a right fold again.

baWords :: String -> [String]
baWords ws = if null headWord
             then tailWords
             else headWord:tailWords
    where
      (headWord, tailWords) = foldr buildWord ("",[]) ws
      buildWord c (thisWord,allWords) | isSpace c = if null thisWord
                                                    then ("", allWords)
                                                    else ("", thisWord:allWords)
                                      | otherwise = (c:thisWord, allWords)

unlines can also be written using a right fold by prepending each word plus by a newline at the front of the result.

baUnlines :: [String] -> String
baUnlines ls = foldr appendCr [] ls
    where appendCr w ws = w ++ "\n" ++ ws

Lots of new things in this chapter but I do like the way the exercises stretch the material. The thing that caused me the most trouble was working out how the left fold was written using the right fold. Haskell keeps doing this, just when I start to feel comfortable with something I see there’s much more to it than meets the eye. I’m going to grab a copy of the cited paper on folds by Paul Hutton and have a look at that. Understanding how the left fold definition using foldr is one thing, but actually using a similar technique is going to take a lot of effort.

Real World Haskell Chapter 3 – Ruby

Chapter 3 exercise solutions.

The <=> method (the spaceship operator) is defined here to sort by y-coordinate and to choose the left-most in case of a match. This means that enumerations of Points can be sorted. This isn’t necessarily a good idea but it is suitable for finding the pivot point.

class Point
  attr_reader  ,:y
  def initialize(x,y)
    @x = x
    @y = y
  end

  def <=>(other)
    return -1 if @y < other.y
    return  1 if @y > other.y
    return -1 if @x < other.x
    return  1 if @x > other.x
    0
  end

  def inspect()
    "(#{@x},#{@y})"
  end
end

An explicit inspect method is defined to make checking of results a bit easier on the eyes.

Ruby’s built in enumeration sorting is equivalent to Haskell’s sortBy strategy, either by writing a spaceship operator or passing a block to sort that returns a suitable value.

def sort_by_angle
  # 1. Find the origin or lowest point
  initial_sort = @vertices.sort
  origin = initial_sort[0]
  # 2. Sort all points by the angle each point makes with the origin
  [origin] + initial_sort[1..-1].sort! {|v, pivot| compare_angles(origin, v, pivot)}
end

def compare_angles(origin, p1, p2)
  p = (p1.x - origin.x)*(p1.y - p2.y)
  q = (p1.y - origin.y)*(p1.x - p2.x)
  return -1 if p < q
  return  1 if p > q
  return -1 if p1.y > p2.y
  return  1 if p1.y < p2.y
  0
end

Real World Haskell Chapter 3 – Scheme

Chapter 3 exercise solutions

The only interesting difference between the scheme and haskell versions lies is in the sorting.
The exercise in chapter 3 to sorts a list of lists by length suggested using sortBy and so I chose to use that in finding the initial point and in sorting by the points by angle.
sortBy takes a function argument which compares 2 values and returns either EQ, LT or GT as you’d expect.
There’s also a sort function that uses the default compare function which I couldn’t use “as is” because I implemented my Point type as a simple tuple of 2 double values, representing x and y, and compare only checks the first value of the tuple (the x component) in its comparison. To avoid having to coerce my Point type to be usable with compare I decided to use sortBy.

Scheme’s built in sort function though accepts a final procedure argument that’s used to determine if the first of its arguments is less than the second. It requires a slightly different approach in sorting points and on sorting by angles. However, the underlying logic comparing points to find the lowest is the same as is comparing points by angle.

(define (cotan<? pivot)
  (lambda (p q)
    (let* ([pivot-x (point-x pivot)]
           [pivot-y (point-y pivot)]
           [px (point-x p)] [py (point-y p)]
           [qx (point-x q)] [qy (point-y q)]
           [cotan-p (* (- py pivot-y) (- qx pivot-x))]
           [cotan-q (* (- qy pivot-y) (- px pivot-x))])
      (cond [( cotan-p cotan-q) false]
            [(> py qy)           true]
            [(< py qy)           false]
            [(< px qx)           true]
            [else                false]))))

Something unexpected happened though, when using cotan<?

(define (cotan-sort ps)
  (let* ([initial-sort (sort ps point<=?)]
         [pivot (first initial-sort)])
     (sort initial-sort (cotan<? pivot))))

Here the points – ps – are sorted by their y co-ordinates to get the lowest point or pivot first in the list.
I expected the value return by ((cotan<? pivot) pivot pivot) to be first in the results but it wasn’t.
I think the reason is due to the calculations of co-incidental points – the cotan calculation is based on simplified arithmetic from calculating the tangent of an angle. If all three points forming the angle are identical there will be division by zero issues.
To overcome the problem I removed the pivot from the initial-sort results.

(define (cotan-sort ps)
  (let* ([initial-sort (sort ps point<=?)]
         [pivot (first initial-sort)])
      (cons pivot (sort (rest initial-sort) (cotan<? pivot)))))

Real World Haskell Chapter 3 – Haskell

The exercises from the first 2 chapters were fairly basic so I will jump straight in at chapter 3 and I’ll just concentrate on exercises that I think need some commentary.
Chapter 3 exercise solutions

Exercise 4. Turn a list into a palindrome.

I wrote two answers for this – the obvious answer is to reverse the given list and append it to the first.

makePalindrome :: [a] -> [a]
makePalindrome xs = xs ++ reverse xs

There is also another form of palindrome where the last item is a pivot and appears just once. This needs a guard to handle an empty list though as the reversed list needs the first item stripped.

makePalindrome' :: [a] -> [a]
makePalindrome' xs = xs ++ tail (reverse xs)

Exercise 7. Define a function that joins a list of lists together using a separator value.

Guards are needed for 2 base cases of an empty list i.e. no nested lists and a sinlge nested list.

intersperse :: a -> [[a]] -> [a]
intersperse _ []         = []
intersperse _ [xs]       = xs
intersperse sep (xs:xss) = xs ++ [sep] ++ intersperse sep xss

This is almost identical to Data.List.intersperse from the standard Prelude except the 2nd argument is a list of lists and not just a list of items. So the return value is constructed using cons (:) rather than appended using (++).

intersperse sep (x:xs) = x : sep : intersperse sep xs

Exercise 9. Specify a data type to represent the direction of the turn abc given the points a,b and c.

type Point     = (Double, Double)
data Direction = LeftTurn | RightTurn | Straight
                 deriving (Eq, Show)

Exercise 10. Find the direction of the turn abc given the points a,b and c.

We can tell which side of the line, containing a and b, that c lies on by calculating the magnitude of the cross product of the vectors ab and bc. If it is positive c lies to the left, if negative it lies to the right, if zero it is colinear.

direction :: Point -> Point -> Point -> Direction
direction (x1, y1) (x2, y2) (x3, y3)
     | cross < 0  = RightTurn
     | cross > 0  = LeftTurn
     | otherwise  = Straight
     where
       cross = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)

Exercise 12. Implement Graham’s scan algorithm for the convex hull of a set of 2D points.

I couldn’t think of a way of using a list of turns (the answer to exercise 11) to implement the algorithm because it contains a backtracking step which removes points from consideration. So I didn’t use the function I wrote for exercise to 11.

Graham’s algorithm is in 3 parts.

1. Find the lowest positioned point or left-most of those that share the lowest position. I’ve since heard this mentioned as a pivot
2. Order the points by the angle formed by a line from the pivot to the point with a horizontal line from the pvcot.
3. Start with the first 3 points as the hull. Keep adding points to the hull as long as the previous 3 points form a left turn (or straight line). If they don’t drop the last term added to the hull and re-calculate

I decided to create a list with the pivot as the first element and for that I used a fold whose accumulator is a list of all the points visited during the fold with the pivot so far as the first element. This is basically a single pass through a bubble sort.

initialSort :: [Point] -> [Point]
initialSort ps = foldr pointLess [head ps] (tail ps)
    where
      pointLess (x1,y1) (min:ps)
          | y1 < miny = min:(x1,y1):ps
          | x1 < minx = (x1,y1):min:ps
          | otherwise = min:(x1,y1):ps
          where
            minx = fst min
            miny = snd min

Step 2. Order the points by increasing angle. The tangent of the angle is the height of the point P from the pivot divided by the horizontal distance from the pivot. With a little arithmetic the cotangent can be without calling any trigonometry functions.
I had a subtle bug in my original cotanSort function due to the way the final points are sorted when they are all colinear with the pivot e.g. if they were all on the y-axis. That’s why the cotanCompare has those extra guards – they apply when the cotan calculations are equal for 2 points. In that case I want the further away from the pivot to be considerd “less” than the nearer point and therefore will be included in the hull at an earlier stage. A simple check of the y values of the 2 points does that because the pivot is already the lowest and left-most point.

cotanSort :: [Point] -> [Point]
cotanSort ps = initialPoint : sortBy cotanCompare remainingPoints
    where
      initialSorting = initialSort ps
      initialPoint = head initialSorting
      remainingPoints = tail initialSorting
      (pivotx,pivoty) = initialPoint
      cotanCompare (px,py) (qx,qy)
          | pCalc > qCalc = GT
          | pCalc < qCalc  = LT
          | py < qy       = GT
          | px > qx       = GT
          | otherwise     = EQ
          where
            pCalc = (py-pivoty)*(qx-pivotx)
            qCalc = (qy-pivoty)*(px-pivotx)

The first 3 points must all be on the hull as the points are sorted in order of angle with the pivot at the lowest left-most point.
The hull is constructed by pushing and popping items from stack. A basic stack can be implemented with a list – a push is to cons onto the front of the list and a pop results in the tail of the list – but that means the list items are in reverse order of the stack. To maintain the illusion create the initial hull reversing the first 3 items from the list of points sorted by angle.

grahamScan :: [Point] -> [Point]
grahamScan ps
    | length ps < 3 =  error "grahamScan requires at least 3 points"
    | otherwise     = contiguousLeftTurns initialHull remainingPoints
    where
      clockwisePoints = cotanSort ps
      remainingPoints = drop 3 clockwisePoints
      initialHull     = reverse (take 3 clockwisePoints)

The graham scan algorithm takes the last 2 points added to the hull along with the next point under consideration, P, and calculates their direction.
For a right turn, the last point added to the hull is discarded and the process is repeated discarding all the points from the hull in that form a right turn with P. This is the backtracking step which stopped me from using the answer to exercise 11 in the graham scan. The list of turns would have to be recalculated at this stage. I think the authors must have a very cunning plan indeed to be able to use a static list of turns to calculate the convex hull. Please tell me if you can find a way because my feeble brain couldn’t.
For a left turn (or a straight) P is added to the null and the next P is considered. This continues until all the points have been exhausted. NB This can be easily altered to only include points that strictly form left turns by discarding those that form a Straight direction.

contiguousLeftTurns :: [Point] -> [Point] -> [Point]
contiguousLeftTurns hull [] = reverse hull
contiguousLeftTurns (h1:h2:hs) (p:ps)
    | rightTurn = contiguousLeftTurns (h2:hs) (p:ps)
    | otherwise = contiguousLeftTurns (p:h1:h2:hs) ps
    where
      rightTurn = direction h2 h1 p == RightTurn

I’ve tried testing my implementation as best I can but I’m not completely confident it’s right.
Still testing and quality assurance isn’t until chapter 11 so I’m not too concerned

This was a fun exercise.

Making mistakes

When you make a mistake the best course of action is to admit your mistake immediately and take any punishment due as soon as possible, whether it’s just wiping the egg off your face or having to make reparations or something more unpleasant.

In this case I realise I’ve been using the wrong book. I’ve since come to realise that I should be using Real World Haskell for many reasons.
The content is freely available. It’s written at a higher level than beginner programmers so it’s more suitable for me. THe exercises look to be more interesting.

So with immediate effect I’m switching over to it. I’ll take the same approach though tackle all the exercise in scheme and ruby while contrasting all three languages as I go.

I think I’ll still continue going through The Craft of Functional Programming but I’m not going to post the exercises here.

Chapter 6 – Ruby supermarket

The different types introduced in the book translate into ruby classes and rather than have a monolithic single file with all the class definitions in them, the separate types are split into different files:

• bill.rb The Bill class which has various methods for formatting bills scattered throughout the exercises like skipping unknown items and adding a discount item.
• bill_item.rb The BillItem class which just stores name and price
• till.rb – the Till class to store bar codes and methods to create different types of bills
• database.rb – the Database class which stores a set of index items with methods to add and remove items
• index.rb – the Index class which just stores a name price and bar code
• supermarket.rb – the Supermarket class which has most of the exercise answers
• analysis.rb -the Analysis class with the extra exercises to analyse sets of tills

I find writing in ruby to be more opaque and less flexible than scheme – I think because of the scheme repl. Ruby has irb which is great for testing out ideas and playing around with classes to test them but I mean that when something goes wrong it’s generally easier for me to isolate and fix the problem in scheme than in ruby. This could definitely be improved by adopting a proper test-driven approach but even so I still find it easier to break apart and work with small problem areas using scheme. Haskell is hardest of all – especially with type errors, but I’m expecting that to improve as I start to get more comfortable in haskell and get to know the Prelude and other libraries better.

One of the inherent problems I find with ruby is that of method scope and testing – should I mark methods private and hide them from the outside world – which makes testing them more difficult – or should I leave them all public and expose methods that have no right being used outside the scope of the class. I haven’t come up with a good heuristic for deciding the answer to that question yet. In some respects it’s a non-question due to the extremely dynamic nature of ruby – you can’t really hide anything, but still it feels right to signal to the world the intention that helper methods are private and not really to be used by the whole universe.