blog/published/2007.06.24-floating-point-in-elschemo.md

Title: Floating point in ElSchemo
Date: June 24, 2007
Timestamp: 1182711180
Author: sjs
Tags: elschemo, haskell, scheme
----

### Parsing floating point numbers ###

The first task is extending the <code>LispVal</code> type to grok floats.


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt>8<tt>
</tt>9<tt>
</tt><strong>10</strong><tt>
</tt>11<tt>
</tt>12<tt>
</tt>13<tt>
</tt>14<tt>
</tt>15<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">type LispInt = Integer<tt>
</tt>type LispFloat = Float<tt>
</tt><tt>
</tt>-- numeric data types<tt>
</tt>data LispNum = Integer LispInt<tt>
</tt>             | Float LispFloat<tt>
</tt><tt>
</tt>-- data types<tt>
</tt>data LispVal = Atom String<tt>
</tt>             | List [LispVal]<tt>
</tt>             | DottedList [LispVal] LispVal<tt>
</tt>             | Number LispNum<tt>
</tt>             | Char Char<tt>
</tt>             | String String<tt>
</tt>             | ...</pre></td>
</tr></table>


The reason for using the new <code>LispNum</code> type and not just throwing a new <code>Float Float</code> constructor in there is so that functions can accept and operate on parameters of any supported numeric type.  First the floating point numbers need to be parsed.  For now I only parse floating point numbers in decimal because the effort to parse other bases is too great for the benefits gained (none, for me).

ElSchemo now parses negative numbers so I'll start with 2 helper functions that are used when parsing both integers and floats:


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">parseSign :: Parser Char<tt>
</tt>parseSign = do try (char '-')<tt>
</tt>           &lt;|&gt; do optional (char '+')<tt>
</tt>                  return '+'<tt>
</tt><tt>
</tt>applySign :: Char -&gt; LispNum -&gt; LispNum<tt>
</tt>applySign sign n = if sign == '-' then negate n else n</pre></td>
</tr></table>


<code>parseSign</code> is straightforward as it follows the convention that a literal number is positive unless explicitly marked as negative with a leading minus sign. A leading plus sign is allowed but not required.

<code>applySign</code> takes a sign character and a <code>LispNum</code> and negates it if necessary, returning a <code>LispNum</code>.

Armed with these 2 functions we can now parse floating point numbers in decimal. Conforming to R5RS an optional <code>#d</code> prefix is allowed.


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt>8<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">parseFloat :: Parser LispVal<tt>
</tt>parseFloat = do optional (string "#d")<tt>
</tt>                sign &lt;- parseSign<tt>
</tt>                whole &lt;- many1 digit<tt>
</tt>                char '.'<tt>
</tt>                fract &lt;- many1 digit<tt>
</tt>                return . Number $ applySign sign (makeFloat whole fract)<tt>
</tt>    where makeFloat whole fract = Float . fst . head . readFloat $ whole ++ "." ++ fract</pre></td>
</tr></table>


The first 6 lines should be clear. Line 7 simply applies the parsed sign to the parsed number and returns it, delegating most of the work to <code>makeFloat</code>.  <code>makeFloat</code> in turn delegates the work to the <code>readFloat</code> library function, extracts the result and constructs a <code>LispNum</code> for it.

The last step for parsing is to modify <code>parseExpr</code> to try and parse floats.


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt>8<tt>
</tt>9<tt>
</tt><strong>10</strong><tt>
</tt>11<tt>
</tt>12<tt>
</tt>13<tt>
</tt>14<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">-- Integers, floats, characters and atoms can all start with a # so wrap those with try.<tt>
</tt>-- (Left factor the grammar in the future)<tt>
</tt>parseExpr :: Parser LispVal<tt>
</tt>parseExpr = (try parseFloat)<tt>
</tt>        &lt;|&gt; (try parseInteger)<tt>
</tt>        &lt;|&gt; (try parseChar)<tt>
</tt>        &lt;|&gt; parseAtom<tt>
</tt>        &lt;|&gt; parseString<tt>
</tt>        &lt;|&gt; parseQuoted<tt>
</tt>        &lt;|&gt; do char '('<tt>
</tt>               x &lt;- (try parseList) &lt;|&gt; parseDottedList<tt>
</tt>               char ')'<tt>
</tt>               return x<tt>
</tt>        &lt;|&gt; parseComment</pre></td>
</tr></table>


### Displaying the floats ###


That's it for parsing, now let's provide a way to display these suckers.  <code>LispVal</code> is an instance of show, where <code>show</code> = <code>showVal</code> so <code>showVal</code> is our first stop.  Remembering that <code>LispVal</code> now has a single <code>Number</code> constructor we modify it accordingly:


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">showVal (Number n) = showNum n<tt>
</tt><tt>
</tt>showNum :: LispNum -&gt; String<tt>
</tt>showNum (Integer contents) = show contents<tt>
</tt>showNum (Float contents) = show contents<tt>
</tt><tt>
</tt>instance Show LispNum where show = showNum</pre></td>
</tr></table>


One last, and certainly not least, step is to modify <code>eval</code> so that numbers evaluate to themselves.


    eval env val@(Number _) = return val

There's a little more housekeeping to be done such as fixing <code>integer?</code>, <code>number?</code>, implementing <code>float?</code> but I will leave those as an exercise to the reader, or just wait until I share the full code.  As it stands now floating point numbers can be parsed and displayed.  If you fire up the interpreter and type <code>2.5</code> or <code>-10.88</code> they will be understood.  Now try adding them:

    (+ 2.5 1.1)
    Invalid type: expected integer, found 2.5

Oops, we don't know how to operate on floats yet!

### Operating on floats ###

Parsing was the easy part.  Operating on the new floats is not necessarily difficult, but it was more work than I realized it would be.  I don't claim that this is the best or the only way to operate on any <code>LispNum</code>, it's just the way I did it and it seems to work.  There's a bunch of boilerplate necessary to make <code>LispNum</code> an instance of the required classes, Eq, Num, Real, and Ord.  I don't think I have done this properly but for now it works.  What is clearly necessary is the code that operates on different types of numbers.  I think I've specified sane semantics for coercion.  This will be very handy shortly.


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt>8<tt>
</tt>9<tt>
</tt><strong>10</strong><tt>
</tt>11<tt>
</tt>12<tt>
</tt>13<tt>
</tt>14<tt>
</tt>15<tt>
</tt>16<tt>
</tt>17<tt>
</tt>18<tt>
</tt>19<tt>
</tt><strong>20</strong><tt>
</tt>21<tt>
</tt>22<tt>
</tt>23<tt>
</tt>24<tt>
</tt>25<tt>
</tt>26<tt>
</tt>27<tt>
</tt>28<tt>
</tt>29<tt>
</tt><strong>30</strong><tt>
</tt>31<tt>
</tt>32<tt>
</tt>33<tt>
</tt>34<tt>
</tt>35<tt>
</tt>36<tt>
</tt>37<tt>
</tt>38<tt>
</tt>39<tt>
</tt><strong>40</strong><tt>
</tt>41<tt>
</tt>42<tt>
</tt>43<tt>
</tt>44<tt>
</tt>45<tt>
</tt>46<tt>
</tt>47<tt>
</tt>48<tt>
</tt>49<tt>
</tt><strong>50</strong><tt>
</tt>51<tt>
</tt>52<tt>
</tt>53<tt>
</tt>54<tt>
</tt>55<tt>
</tt>56<tt>
</tt>57<tt>
</tt>58<tt>
</tt>59<tt>
</tt><strong>60</strong><tt>
</tt>61<tt>
</tt>62<tt>
</tt>63<tt>
</tt>64<tt>
</tt>65<tt>
</tt>66<tt>
</tt>67<tt>
</tt>68<tt>
</tt>69<tt>
</tt><strong>70</strong><tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">lispNumEq :: LispNum -&gt; LispNum -&gt; Bool<tt>
</tt>lispNumEq (Integer arg1) (Integer arg2) = arg1 == arg2<tt>
</tt>lispNumEq (Integer arg1) (Float arg2) = (fromInteger arg1) == arg2<tt>
</tt>lispNumEq (Float arg1) (Float arg2) = arg1 == arg2<tt>
</tt>lispNumEq (Float arg1) (Integer arg2) = arg1 == (fromInteger arg2)<tt>
</tt><tt>
</tt>instance Eq LispNum where (==) = lispNumEq<tt>
</tt><tt>
</tt>lispNumPlus :: LispNum -&gt; LispNum -&gt; LispNum<tt>
</tt>lispNumPlus (Integer x) (Integer y) = Integer $ x + y<tt>
</tt>lispNumPlus (Integer x) (Float y)   = Float $ (fromInteger x) + y<tt>
</tt>lispNumPlus (Float x)   (Float y)   = Float $ x + y<tt>
</tt>lispNumPlus (Float x)   (Integer y) = Float $ x + (fromInteger y)<tt>
</tt><tt>
</tt>lispNumMinus :: LispNum -&gt; LispNum -&gt; LispNum<tt>
</tt>lispNumMinus (Integer x) (Integer y) = Integer $ x - y<tt>
</tt>lispNumMinus (Integer x) (Float y)   = Float $ (fromInteger x) - y<tt>
</tt>lispNumMinus (Float x)   (Float y)   = Float $ x - y<tt>
</tt>lispNumMinus (Float x)   (Integer y) = Float $ x - (fromInteger y)<tt>
</tt><tt>
</tt>lispNumMult :: LispNum -&gt; LispNum -&gt; LispNum<tt>
</tt>lispNumMult (Integer x) (Integer y) = Integer $ x * y<tt>
</tt>lispNumMult (Integer x) (Float y)   = Float $ (fromInteger x) * y<tt>
</tt>lispNumMult (Float x)   (Float y)   = Float $ x * y<tt>
</tt>lispNumMult (Float x)   (Integer y) = Float $ x * (fromInteger y)<tt>
</tt><tt>
</tt>lispNumDiv :: LispNum -&gt; LispNum -&gt; LispNum<tt>
</tt>lispNumDiv (Integer x) (Integer y) = Integer $ x `div` y<tt>
</tt>lispNumDiv (Integer x) (Float y)   = Float $ (fromInteger x) / y<tt>
</tt>lispNumDiv (Float x)   (Float y)   = Float $ x / y<tt>
</tt>lispNumDiv (Float x)   (Integer y) = Float $ x / (fromInteger y)<tt>
</tt><tt>
</tt>lispNumAbs :: LispNum -&gt; LispNum<tt>
</tt>lispNumAbs (Integer x) = Integer (abs x)<tt>
</tt>lispNumAbs (Float x) = Float (abs x)<tt>
</tt><tt>
</tt>lispNumSignum :: LispNum -&gt; LispNum<tt>
</tt>lispNumSignum (Integer x) = Integer (signum x)<tt>
</tt>lispNumSignum (Float x) = Float (signum x)<tt>
</tt><tt>
</tt>instance Num LispNum where<tt>
</tt>    (+) = lispNumPlus<tt>
</tt>    (-) = lispNumMinus<tt>
</tt>    (*) = lispNumMult<tt>
</tt>    abs = lispNumAbs<tt>
</tt>    signum = lispNumSignum<tt>
</tt>    fromInteger x = Integer x<tt>
</tt><tt>
</tt><tt>
</tt>lispNumToRational :: LispNum -&gt; Rational<tt>
</tt>lispNumToRational (Integer x) = toRational x<tt>
</tt>lispNumToRational (Float x) = toRational x<tt>
</tt><tt>
</tt>instance Real LispNum where<tt>
</tt>    toRational = lispNumToRational<tt>
</tt><tt>
</tt><tt>
</tt>lispIntQuotRem :: LispInt -&gt; LispInt -&gt; (LispInt, LispInt)<tt>
</tt>lispIntQuotRem n d = quotRem n d<tt>
</tt><tt>
</tt>lispIntToInteger :: LispInt -&gt; Integer<tt>
</tt>lispIntToInteger x = x<tt>
</tt><tt>
</tt>lispNumLessThanEq :: LispNum -&gt; LispNum -&gt; Bool<tt>
</tt>lispNumLessThanEq (Integer x) (Integer y) = x &lt;= y<tt>
</tt>lispNumLessThanEq (Integer x) (Float y)   = (fromInteger x) &lt;= y<tt>
</tt>lispNumLessThanEq (Float x)   (Integer y) = x &lt;= (fromInteger y)<tt>
</tt>lispNumLessThanEq (Float x)   (Float y)   = x &lt;= y<tt>
</tt><tt>
</tt>instance Ord LispNum where (&lt;=) = lispNumLessThanEq</pre></td>
</tr></table>


Phew, ok with that out of the way now we can actually extend our operators to work with any type of <code>LispNum</code>.  Our Scheme operators are defined using the functions <code>numericBinop</code> and <code>numBoolBinop</code>.  First we'll slightly modify our definition of <code>primitives</code>:


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt>8<tt>
</tt>9<tt>
</tt><strong>10</strong><tt>
</tt>11<tt>
</tt>12<tt>
</tt>13<tt>
</tt>14<tt>
</tt>15<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">primitives :: [(String, [LispVal] -&gt; ThrowsError LispVal)]<tt>
</tt>primitives = [("+", numericBinop (+)),<tt>
</tt>              ("-", subtractOp),<tt>
</tt>              ("*", numericBinop (*)),<tt>
</tt>              ("/", floatBinop (/)),<tt>
</tt>              ("mod", integralBinop mod),<tt>
</tt>              ("quotient", integralBinop quot),<tt>
</tt>              ("remainder", integralBinop rem),<tt>
</tt>              ("=", numBoolBinop (==)),<tt>
</tt>              ("&lt;", numBoolBinop (&lt;)),<tt>
</tt>              ("&gt;", numBoolBinop (&gt;)),<tt>
</tt>              ("/=", numBoolBinop (/=)),<tt>
</tt>              ("&gt;=", numBoolBinop (&gt;=)),<tt>
</tt>              ("&lt;=", numBoolBinop (&lt;=)),<tt>
</tt>              ...]</pre></td>
</tr></table>


Note that <code>mod</code>, <code>quotient</code>, and <code>remainder</code> are only defined for integers and as such use <code>integralBinop</code>, while division (/) is only defined for floating point numbers using <code>floatBinop</code>.  <code>subtractOp</code> is different to support unary usage, e.g. <code>(- 4) =&gt; -4</code>, but it uses <code>numericBinop</code> internally when more than 1 argument is given.  On to the implementation!  First extend <code>unpackNum</code> to work with any <code>LispNum</code>, and provide separate <code>unpackInt</code> and <code>unpackFloat</code> functions to handle both kinds of <code>LispNum</code>.


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt>8<tt>
</tt>9<tt>
</tt><strong>10</strong><tt>
</tt>11<tt>
</tt>12<tt>
</tt>13<tt>
</tt>14<tt>
</tt>15<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">unpackNum :: LispVal -&gt; ThrowsError LispNum<tt>
</tt>unpackNum (Number (Integer n)) = return $ Integer n<tt>
</tt>unpackNum (Number (Float n)) = return $ Float n<tt>
</tt>unpackNum notNum = throwError $ TypeMismatch "number" notNum<tt>
</tt><tt>
</tt>unpackInt :: LispVal -&gt; ThrowsError Integer<tt>
</tt>unpackInt (Number (Integer n)) = return n<tt>
</tt>unpackInt (List [n]) = unpackInt n<tt>
</tt>unpackInt notInt = throwError $ TypeMismatch "integer" notInt<tt>
</tt><tt>
</tt>unpackFloat :: LispVal -&gt; ThrowsError Float<tt>
</tt>unpackFloat (Number (Float f)) = return f<tt>
</tt>unpackFloat (Number (Integer f)) = return $ fromInteger f<tt>
</tt>unpackFloat (List [f]) = unpackFloat f<tt>
</tt>unpackFloat notFloat = throwError $ TypeMismatch "float" notFloat</pre></td>
</tr></table>


The initial work of separating integers and floats into the <code>LispNum</code> abstraction, and the code I said would be handy shortly, are going to be really handy here.  There's relatively no change in <code>numericBinop</code> except for the type signature.  <code>integralBinop</code> and <code>floatBinop</code> are just specific versions of the same function.  I'm sure there's a nice Haskelly way of doing this with less repetition, and I welcome such corrections.


<table class="CodeRay"><tr>
  <td class="line_numbers" title="click to toggle" onclick="with (this.firstChild.style) { display = (display == '') ? 'none' : '' }"><pre>1<tt>
</tt>2<tt>
</tt>3<tt>
</tt>4<tt>
</tt>5<tt>
</tt>6<tt>
</tt>7<tt>
</tt>8<tt>
</tt>9<tt>
</tt><strong>10</strong><tt>
</tt>11<tt>
</tt>12<tt>
</tt>13<tt>
</tt>14<tt>
</tt>15<tt>
</tt>16<tt>
</tt>17<tt>
</tt>18<tt>
</tt></pre></td>
  <td class="code"><pre ondblclick="with (this.style) { overflow = (overflow == 'auto' || overflow == '') ? 'visible' : 'auto' }">numericBinop :: (LispNum -&gt; LispNum -&gt; LispNum) -&gt; [LispVal] -&gt; ThrowsError LispVal<tt>
</tt>numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal<tt>
</tt>numericBinop op params = mapM unpackNum params &gt;&gt;= return . Number . foldl1 op<tt>
</tt><tt>
</tt>integralBinop :: (LispInt -&gt; LispInt -&gt; LispInt) -&gt; [LispVal] -&gt; ThrowsError LispVal<tt>
</tt>integralBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal<tt>
</tt>integralBinop op params = mapM unpackInt params &gt;&gt;= return . Number . Integer . foldl1 op<tt>
</tt><tt>
</tt>floatBinop :: (LispFloat -&gt; LispFloat -&gt; LispFloat) -&gt; [LispVal] -&gt; ThrowsError LispVal<tt>
</tt>floatBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal<tt>
</tt>floatBinop op params = mapM unpackFloat params &gt;&gt;= return . Number . Float . foldl1 op<tt>
</tt><tt>
</tt>subtractOp :: [LispVal] -&gt; ThrowsError LispVal<tt>
</tt>subtractOp num@[_] = unpackNum (head num) &gt;&gt;= return . Number . negate<tt>
</tt>subtractOp params = numericBinop (-) params<tt>
</tt><tt>
</tt>numBoolBinop :: (LispNum -&gt; LispNum -&gt; Bool) -&gt; [LispVal] -&gt; ThrowsError LispVal<tt>
</tt>numBoolBinop op params = boolBinop unpackNum op params</pre></td>
</tr></table>


That was a bit of work but now ElSchemo supports floating point numbers, and if you're following along then your Scheme might too if I haven't missed any important details!


Next time I'll go over some of the special forms I have added, including short-circuiting <code>and</code> and <code>or</code> forms and the full repetoire of <code>let</code>, <code>let*</code>, and <code>letrec</code>. Stay tuned!