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

<h3>Parsing floating point numbers</h3>


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


<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>


	<p>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).</p>


	<p>ElSchemo now parses negative numbers so I’ll start with 2 helper functions that are used when parsing both integers and floats:</p>


<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>


	<p><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.</p>


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


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


<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>


	<p>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.</p>


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


<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>


	<h3>Displaying the floats</h3>


	<p>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:</p>


<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>


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


<pre><code>eval env val@(Number _) = return val</code></pre>

	<p>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:</p>


<pre>(+ 2.5 1.1)
Invalid type: expected integer, found 2.5</pre>

	<p>Oops, we don’t know how to operate on floats yet!</p>


	<h3>Operating on floats</h3>


	<p>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.</p>


<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>


	<p>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>:</p>


<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>


	<p>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>.</p>


<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>


	<p>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.</p>


<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>


	<p>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!</p>


	<p>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!</p>
  
  <div class="extended">
    <p><a href="http://web.archive.org/web/20070628231343/http://sami.samhuri.net/2007/6/25/floating-point-in-elschemo">Continue reading...</a></p>
  </div>
