# Write Yourself a Scheme in 48 Hours/Answers

 | author   =
 | section  = Answers
 | previous = [[../Conclusion|Conclusion]]
 | next     =
 | notes    =
}}
```
\_\_TOC\_\_

# Chapter 1

### Exercise 1

`main :: IO ()`\
`main = do args <- getArgs`\
`          putStrLn ("Hello, " ++ args!!0 ++ " " ++ args!!1)`

### Exercise 2

`main :: IO ()`\
`main = do args <- getArgs`\
`          print ((read $ args!!0) + (read $ args!!1))`

The `$` operator reduces the number of parentheses needed here.
Alternatively you could write the function applications as
`read (args!!0)`.

### Exercise 3

`main :: IO ()`\
`main = do putStrLn "What do they call thee at home?"`\
`          name <- getLine`\
`          putStrLn ("Ey up " ++ name)`

# Chapter 2

## Section 3 - Parsing

### Exercise 1

#### Part 1

`parseNumber :: Parser LispVal`\
`parseNumber = do x <- many1 digit`\
`                (return . Number . read) x`

#### Part 2

In order to answer this question, you need to do a bit of detective
work! It is helpful to read up on do
notation.
Using the information there, we can mechanically transform the above
answer into the following.

`parseNumber = many1 digit >>= \x -> (return . Number . read) x`

This can be cleaned up into the following:

`parseNumber = many1 digit >>= return . Number . read`

### Exercise 2

We need to create a new parser action that accepts a backslash followed
by either another backslash or a doublequote. This action needs to
return only the second character.

`escapedChars :: Parser Char`\
`escapedChars = do char '\\' -- a backslash`\
`                  x <- oneOf "\\\"" -- either backslash or doublequote`\
`                  return x -- return the escaped character`

Once that is done, we need to make some changes to parseString.

`parseString :: Parser LispVal`\
`parseString = do char '"'`\
`                 x <- many $ escapedChars <|> noneOf "\"\\"`\
`                 char '"'`\
`                 return $ String x`

### Exercise 3

`escapedChars :: Parser Char`\
`escapedChars = do char '\\' `\
`                  x <- oneOf "\\\"nrt" `\
`                  return $ case x of `\
`                    '\\' -> x`\
`                    '"'  -> x`\
`                    'n'  -> '\n'`\
`                    'r'  -> '\r'`\
`                    't'  -> '\t'`

### Exercise 4

First, it is necessary to change the definition of symbol.

`symbol :: Parser Char`\
`symbol = oneOf "!$%&|*+-/:<=>?@^_~"`

This means that it is no longer possible to begin an atom with the hash
character. This necessitates a different way of parsing #t and #f.

`parseBool :: Parser LispVal`\
`parseBool = do`\
`    char '#'`\
`    (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))`

This in turn requires us to make changes to parseExpr.

`parseExpr :: Parser LispVal`\
`parseExpr = parseAtom`\
`        <|> parseString`\
`        <|> parseNumber`\
`        <|> parseBool`

parseNumber need to be changed to the following.

`parseNumber :: Parser LispVal`\
`parseNumber = parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin`

And the following new functions need to be added.

`parseDecimal1 :: Parser LispVal`\
`parseDecimal1 = many1 digit >>= (return . Number . read)`

`parseDecimal2 :: Parser LispVal`\
`parseDecimal2 = do try $ string "#d"`\
`                   x <- many1 digit`\
`                   (return . Number . read) x`

`parseHex :: Parser LispVal`\
`parseHex = do try $ string "#x"`\
`              x <- many1 hexDigit`\
`              return $ Number (hex2dig x)`

`parseOct :: Parser LispVal`\
`parseOct = do try $ string "#o"`\
`              x <- many1 octDigit`\
`              return $ Number (oct2dig x)`

`parseBin :: Parser LispVal`\
`parseBin = do try $ string "#b"`\
`              x <- many1 (oneOf "10")`\
`              return $ Number (bin2dig x)`

`oct2dig x = fst $ readOct x !! 0`\
`hex2dig x = fst $ readHex x !! 0`\
`bin2dig  = bin2dig' 0`\
`bin2dig' digint "" = digint`\
`bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in`\
`                         bin2dig' old xs`

Import the *Numeric* module to use the readOct and readHex functions.

### Exercise 5

`data LispVal = Atom String`\
`             | List [LispVal]`\
`             | DottedList [LispVal] LispVal`\
`             | Number Integer`\
`             | String String`\
`             | Bool Bool`\
`             | Character Char`

`parseCharacter :: Parser LispVal`\
`parseCharacter = do`\
` try $ string "#\\"`\
` value <- try (string "newline" <|> string "space") `\
`         <|> do { x <- anyChar; notFollowedBy alphaNum ; return [x] }`\
`  return $ Character $ case value of`\
`    "space" -> ' '`\
`    "newline" -> '\n'`\
`    otherwise -> (value !! 0)`

The combination of anyChar and notFollowedBy ensure that only a single
character is read.

Note that this does not actually conform to the standard; as it stands,
\"space\" and \"newline\" must be entirely lowercase; the standard
states that they should be case insensitive.

`parseExpr :: Parser LispVal`\
`parseExpr = parseAtom`\
`        <|> parseString`\
`        <|> try parseNumber -- we need the 'try' because `\
`        <|> try parseBool -- these can all start with the hash char`\
`        <|> try parseCharacter`

### Exercise 6

A possible solution for floating point numbers:

` parseFloat :: Parser LispVal`\
` parseFloat = do x <- many1 digit`\
`                 char '.'`\
`                 y <- many1 digit`\
`                 return $ Float (fst.head$readFloat (x++"."++y))`

Furthermore, add

` try parseFloat`

*before* parseNumber in parseExpr and the line

` | Float Double`

to the LispVal type.

### Exercise 7

**Ratio**, using Haskell\'s Rational type:

` parseRatio :: Parser LispVal`\
` parseRatio = do x <- many1 digit`\
`                 char '/'`\
`                 y <- many1 digit`\
`                 return $ Ratio ((read x) % (read y))`

Additionally, import the *Data.Ratio* module, add

` try parseRatio`

*before* parseNumber in parseExpr and the line

` | Ratio Rational`

to the LispVal type.

**Real** is already implemented in the Float type from Exercise 6,
unless I\'m mistaken.

**Complex** using Haskell\'s Complex type:

` toDouble :: LispVal -> Double`\
` toDouble(Float f) = realToFrac f`\
` toDouble(Number n) = fromIntegral n`

` parseComplex :: Parser LispVal`\
` parseComplex = do x <- (try parseFloat <|> parseDecimal)`\
`                   char '+' `\
`                   y <- (try parseFloat <|> parseDecimal)`\
`                   char 'i' `\
`                   return $ Complex (toDouble x :+ toDouble y)`

As before, import the *Data.Complex* module, add

` try parseComplex`

*before* parseNumber and parseFloat in parseExpr and the line

`  | Complex (Complex Double)`

to the LispVal type.

## Section 4 - Recursive Parsers: Adding lists, dotted lists, and quoted datums

### Exercise 1

These two are analogous to parseQuoted:

` parseQuasiQuoted :: Parser LispVal`\
` parseQuasiQuoted = do`\
``      char '`' ``\
`     x <- parseExpr`\
`     return $ List [Atom "quasiquote", x]`

` parseUnQuote :: Parser LispVal`\
` parseUnQuote = do`\
`     char ','`\
`     x <- parseExpr`\
`     return $ List [Atom "unquote", x]`

` parseUnQuoteSplicing :: Parser LispVal`\
` parseUnQuoteSplicing = do`\
`     char ','`\
`     char '@'`\
`     x <- parseExpr`\
`     return $ List [Atom "unquote-splicing", x]`

Also add

`       <|> parseQuasiQuoted`\
`       <|> parseUnQuote`\
`       <|> parseUnQuoteSplicing`

to parseExpr.

### Exercise 2

I chose to go with Arrays as described in
Data.Array
and used list-array conversions for array construction.

` parseVector :: Parser LispVal`\
` parseVector = do arrayValues <- sepBy parseExpr spaces`\
`                  return $ Vector (listArray (0,(length arrayValues - 1)) arrayValues)`

In order to use this, import *Data.Array* and add the following to the
LispVal type:

`            | Vector (Array Int LispVal)`

Add the following lines to parseExpr; *before* the parser for Lists and
DottedLists.

`       <|> try (do string "#("`\
`                   x <- parseVector`\
`                   char ')'`\
`                   return x)`

### Exercise 3

This took a fair amount of fiddling with `sepBy`, `endBy` and friends. I
started by getting the `(. degenerate)` dotted list to work and then
went from there. This code tolerates trailing and leading spaces.

`parseAnyList :: Parser LispVal`\
`parseAnyList = do`\
`  P.char '('`\
`  optionalSpaces`\
`  head <- P.sepEndBy parseExpr spaces`\
`  tail <- (P.char '.' >> spaces >> parseExpr) <|> return (Nil ())`\
`  optionalSpaces`\
`  P.char ')'`\
`  return $ case tail of`\
`    (Nil ()) -> List head`\
`    otherwise -> DottedList head tail`

Another implementation using more advanced functions from the Parsec
library. `spaces` is the one from this tutorial.

`parseList :: Parser LispVal`\
`parseList = between beg end parseList1`\
`           where beg = (char '(' >> skipMany space)`\
`                 end = (skipMany space >> char ')')`

`parseList1 :: Parser LispVal`\
`parseList1 = do list <- sepEndBy parseExpr spaces`\
`               maybeDatum <- optionMaybe (char '.' >> spaces >> parseExpr)`\
`               return $ case maybeDatum of`\
`                  Nothing -> List list`\
`                  Just datum  -> DottedList list datum`

Alternative solution. `spaces` is the spaces from Parsec and `spaces1`
is the spaces from this tutorial.

`parseList :: Parser LispVal`\
`parseList = do char '(' >> spaces`\
``                head <- parseExpr `sepEndBy` spaces1 ``\
`               do char '.' >> spaces1`\
`                  tail <- parseExpr`\
`                  spaces >> char ')'`\
`                  return $ DottedList head tail`\
`                <|> (spaces >> char ')' >> (return $ List head))`

# Chapter 3

### Exercise 1

Here is one way of adding a few of them.

`primitives :: [(String , [LispVal] -> LispVal)]`\
`primitives = [("+" , numericBinop (+)) ,`\
`              ("-" , numericBinop (-)) ,`\
`              ("*" , numericBinop (*)) ,`\
`              ("/" , numericBinop div) ,`\
`              ("mod" , numericBinop mod) ,`\
`              ("quotient" , numericBinop quot) ,`\
`              ("remainder" , numericBinop rem) ,`\
`              ("symbol?" , unaryOp symbolp) ,`\
`              ("string?" , unaryOp stringp) ,`\
`              ("number?" , unaryOp numberp) ,`\
`              ("bool?", unaryOp boolp) ,`\
`              ("list?" , unaryOp listp)]`

`unaryOp :: (LispVal -> LispVal) -> [LispVal] -> LispVal`\
`unaryOp f [v] = f v`

`symbolp, numberp, stringp, boolp, listp :: LispVal -> LispVal`\
`symbolp (Atom _)   = Bool True`\
`symbolp _          = Bool False`\
`numberp (Number _) = Bool True`\
`numberp _          = Bool False`\
`stringp (String _) = Bool True`\
`stringp _          = Bool False`\
`boolp   (Bool _)   = Bool True`\
`boolp   _          = Bool False`\
`listp   (List _)   = Bool True`\
`listp   (DottedList _ _) = Bool False`\
`listp   _          = Bool False`

### Exercise 2

`unpackNum :: LispVal -> Integer`\
`unpackNum (Number n) = n`\
`unpackNum _          = 0`

### Exercise 3

Add symbol-\>string and string-\>symbol to the list of primitives, then:

`symbol2string, string2symbol :: LispVal -> LispVal`\
`symbol2string (Atom s)   = String s`\
`symbol2string _          = String ""`\
`string2symbol (String s) = Atom s`\
`string2symbol _          = Atom ""`

This doesn\'t deal well with bad input, which is covered later.

# Chapter 5

### Exercise 1

`eval env (List [Atom "if", pred, conseq, alt]) = do `\
`   result <- eval env pred`\
`   case result of`\
`     Bool False -> eval env alt`\
`     Bool True  -> eval env conseq`\
`     _          -> throwError $ TypeMismatch "bool" pred`

### Exercise 2

Define a helper function that takes the equal/eqv function as an
argument:

` eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal`\
` eqvList eqvFunc [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && `\
`                                                     (all eqvPair $ zip arg1 arg2)`\
`       where eqvPair (x1, x2) = case eqvFunc [x1, x2] of`\
`                                     Left err -> False`\
`                                     Right (Bool val) -> val`

Now adjust the eqv clause:

` eqv listPair@[List _, List _] = eqvList eqv listPair`

And add clauses for List and DottedList to the equal function:

` equal :: [LispVal] -> ThrowsError LispVal`\
` equal listPair@[List _, List _] = eqvList equal listPair`\
` equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]]`\
` equal [arg1, arg2] = do`\
`     primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)`\
`                        [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]`\
`     eqvEquals <- eqv [arg1, arg2]`\
`     return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)`\
` equal badArgList = throwError $ NumArgs 2 badArgList`

### Exercise 3

#### cond

Room for improvement here!

`eval (List ((Atom "cond"):cs))              = do `\
`  b <- (liftM (take 1 . dropWhile f) $ mapM condClause cs) >>= cdr   `\
`  car [b] >>= eval `\
`    where condClause (List [p,b]) = do q <- eval p`\
`                                       case q of`\
`                                         Bool _ -> return $ List [q,b]`\
`                                         _      -> throwError $ TypeMismatch "bool" q `\
`          condClause v            = throwError $ TypeMismatch "(pred body)" v `\
`          f                       = \(List [p,b]) -> case p of `\
`                                                       (Bool False) -> True`\
`                                                       _            -> False`

Another approach:

`eval env (List (Atom "cond" : expr : rest)) = do`\
`    eval' expr rest`\
`    where eval' (List [cond, value]) (x : xs) = do`\
`              result <- eval env cond`\
`              case result of`\
`                   Bool False -> eval' x xs`\
`                   Bool True  -> eval env value`\
`                   otherwise  -> throwError $ TypeMismatch "boolean" cond`\
`          eval' (List [Atom "else", value]) [] = do`\
`               eval env value`\
`          eval' (List [cond, value]) [] = do`\
`              result <- eval env cond`\
`              case result of`\
`                   Bool True  -> eval env value`\
`                   otherwise  -> throwError $ TypeMismatch "boolean" cond`

Yet another approach, piggy-backing off of the already-implemented if:

`eval form@(List (Atom "cond" : clauses)) =`\
`  if null clauses`\
`  then throwError $ BadSpecialForm "no true clause in cond expression: " form`\
`  else case head clauses of`\
`    List [Atom "else", expr] -> eval expr`\
`    List [test, expr]        -> eval $ List [Atom "if",`\
`                                             test,`\
`                                             expr,`\
`                                             List (Atom "cond" : tail clauses)]`\
`    _ -> throwError $ BadSpecialForm "ill-formed cond expression: " form`

Yet another approach

` eval (List ((Atom "cond") : alts)) = cond alts`

` cond :: [LispVal] -> ThrowsError LispVal`\
` cond ((List (Atom "else" : value : [])) : []) = eval value`\
` cond ((List (condition : value : [])) : alts) = do`\
`     result <- eval condition`\
`     boolResult :: Bool <- unpackBool result`\
`     if boolResult then eval value`\
`                   else cond alts`\
` cond ((List a) : _) = throwError $ NumArgs 2 a`\
` cond (a : _) = throwError $ NumArgs 2 [a]`\
` cond _ = throwError $ Default "Not viable alternative in cond"`

#### case

This solution requires LispVal to have a deriving (Eq) clause, in order
to use the \`elem\` function.

`eval form@(List (Atom "case" : key : clauses)) =`\
`  if null clauses`\
`  then throwError $ BadSpecialForm "no true clause in case expression: " form`\
`  else case head clauses of`\
`    List (Atom "else" : exprs) -> mapM eval exprs >>= return . last`\
`    List ((List datums) : exprs) -> do`\
`      result <- eval key`\
`      equality <- mapM (\x -> eqv [result, x]) datums`\
``       if Boolean True `elem` equality ``\
`        then mapM eval exprs >>= return . last`\
`        else eval $ List (Atom "case" : key : tail clauses)`\
`    _                     -> throwError $ BadSpecialForm "ill-formed case expression: " form`

### Exercise 4

Let\'s add string-length and string-ref:

`   primitives = [...`\
`                 ("string-length", stringLen),                                     │`\
`                 ("string-ref", stringRef),`\
`                 ...]`

`   stringLen :: [LispVal] -> ThrowsError LispVal`\
`   stringLen [(String s)] = Right $ Number $ fromIntegral $ length s`\
`   stringLen [notString]  = throwError $ TypeMismatch "string" notString`\
`   stringLen badArgList   = throwError $ NumArgs 1 badArgList`

`   stringRef :: [LispVal] -> ThrowsError LispVal`\
`   stringRef [(String s), (Number k)]`\
`       | length s < k' + 1 = throwError $ Default "Out of bound error"`\
`       | otherwise         = Right $ String $ [s !! k']`\
`       where k' = fromIntegral k`\
`   stringRef [(String s), notNum] = throwError $ TypeMismatch "number" notNum`\
`   stringRef [notString, _]       = throwError $ TypeMismatch "string" notString`\
`   stringRef badArgList           = throwError $ NumArgs 2 badArgList`

