haskeem-0.7.16: WriteNumber.hs
{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>
Portions of this were derived from Jonathan Tang's haskell
tutorial "Write yourself a scheme in 48 hours" and are thus
Copyright Jonathan Tang (but there isn't much of his stuff left).
This file is part of haskeem.
haskeem is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
haskeem is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with haskeem; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
$Id: writenumber.hs,v 1.18 2010-01-18 00:08:49 uwe Exp $ -}
{-# LANGUAGE FlexibleContexts #-}
module WriteNumber (writeNum, ilogb) where
import Prelude
import Numeric
import Data.Ratio
import Maybe
import Control.Monad.Error as CME
import LispData
-- Generate the base prefix for a number. This is included explicitly in all
-- numbers generated by writeNum: that is contrary to what R6RS says; however,
-- I don't understand the rationale: what's the point of having "deadbeef"
-- floating around if you don't mark it as a number (if it is one)?
prefix :: Integer -> String
prefix 2 = "#b"
prefix 8 = "#o"
prefix 10 = "" -- implicit decimal, or "#d" if explicit prefix is desired
prefix 16 = "#x"
prefix _ = progError "writeNumber/prefix"
-- Exponent marker for floating-point numbers in scientific notation:
-- if we just use 'e' all the time, it makes base-16 numbers ambiguous,
-- so write 'x' for base-16. The parser understands this.
emark :: Integer -> String
emark n | n == 16 = "x"
| otherwise = "e"
sign :: (Num a, Ord a) => a -> String
sign n | n < 0 = "-"
| otherwise = "" -- or "+" if explicit sign is desired
sign2 :: Integer -> Integer -> String
sign2 n d | d == 0 = sign n -- to distinguish -1/0 from 1/0
| otherwise = sign (n*d)
d2c :: Int -> Char
d2c = ("0123456789abcdef" !!)
shi :: Integer -> Integer -> String
shi b n = showIntAtBase b d2c n ""
-- fast integer base-b log: this is exported for use in the library
-- as well as here
ilogb :: Integer -> Integer -> Integer
ilogb b n | n < 0 = ilogb b (- n)
| n < b = 0
| otherwise = up 1 - 1
where up a = if n < (b ^ a)
then bin (quot a 2) a
else up (2*a)
bin lo hi = if (hi - lo) <= 1
then hi
else let av = quot (lo + hi) 2
in if n < (b ^ av)
then bin lo av
else bin av hi
-- A small limitation: some of the lengths of strings are Int not Integer,
-- so all of the specified-precision stuff is is limited to somewhere around
-- MAXINT decimal places. That seems ok for now... even the minimum Int
-- size of 2^29 is pretty damned big for a number of digits.
writeInt :: Integer -> Integer -> Maybe Integer -> String
writeInt n b p =
let pval = fromJust p
nval = shi b (abs n)
hdr = prefix b ++ sign n
in if isNothing p
then hdr ++ nval
else if pval >= 0
then hdr ++ nval ++ "." ++ replicate (fromInteger pval) '0'
else writeRatE (fromInteger n) b (-pval)
-- The non-finite rationals get treated specially: they get written
-- in rational format regardless of whether we specified a precision
isSpRat :: Rational -> Bool
isSpRat n = n == myRatNaN || n == myRatPInf || n == myRatNInf
writeSpRat :: Rational -> String
writeSpRat n | n == myRatNaN = "0/0"
| n == myRatPInf = "1/0"
| n == myRatNInf = "-1/0"
| otherwise = progError "writeNumber/SpRat"
-- this is pretty complicated, but it's all pure, and because haskell
-- is lazy only those parts which are needed will get evaluated
writeRatF :: Rational -> Integer -> Maybe Integer -> String
writeRatF num b p =
let n = numerator num
d = denominator num
an = (abs n)
ad = (abs d)
pval = fromJust p
nval = (abs num)
(ni, nr) = quotRem an ad
pfrac = b ^ pval
nf = nr * pfrac
(nj, ns) = quotRem nf ad
nt = 2*ns
ng = if nt < ad || (nt == ad && even nj) then nj else nj + 1
(carry, remder) = quotRem ng pfrac
intp = shi b (ni + carry)
fnz = shi b remder
len = fromInteger (pval - toInteger (length fnz))
fracp = replicate len '0' ++ fnz
hdr = prefix b ++ sign2 n d
in if isNothing p
then hdr ++ shi b an ++ "/" ++ shi b ad
else if pval > 0
then hdr ++ intp ++ "." ++ fracp
else if pval == 0
then hdr ++ shi b (round nval) ++ "."
else writeRatE num b (-pval)
-- Normalize a rational number n such that it's in the half-open interval
-- [1, b), and return the scaled number and the logarithmic scale factor
-- required to get it there. The funky stuff with (sn2,lb2) etc is to
-- eliminate possible errors due to inaccuracy in calculating logBase.
normTo :: Rational -> Integer -> (Rational, Integer)
normTo n b =
let iln = ilogb 2 (numerator n)
ild = ilogb 2 (denominator n)
lb0 = fromInteger (iln - ild) / logBase 2.0 (fromInteger b) :: Double
lb1 = floor lb0
rb = fromInteger b
sn1 = if lb1 >= 0
then n / fromInteger (b ^ lb1)
else n * fromInteger (b ^ (-lb1))
(sn2, lb2) = if sn1 >= 1
then (sn1, lb1)
else (sn1 * rb, lb1 - 1)
in if sn2 < rb
then (sn2, lb2)
else (sn2 / rb, lb2 + 1)
writeRatE :: Rational -> Integer -> Integer -> String
writeRatE num b p =
let (sn, se) = normTo (abs num) b
snr = sn / fromInteger b
ser = se+1
str = writeRatF (sn * signum num) b (Just (abs p)) ++ ssuf se
strr = writeRatF (snr * signum num) b (Just (abs p)) ++ ssuf ser
in if num == 0
then writeRatF (0%1) b (Just (abs p)) ++ ssuf 0
else if noround str
then str
else strr
where ssuf e = emark b ++ sign e ++ shi b (abs e)
noround = chek . takeWhile (/= '.')
chek ('#':_:rest) = chek rest
chek ('-':rest) = chek rest
chek "10" = False
chek _ = True
-- The non-finite floating-point numbers get treated specially.
isSpFlt :: RealFloat a => a -> Bool
isSpFlt n = isNaN n || isInfinite n
writeSpFlt :: RealFloat a => a -> String
writeSpFlt n | n > 0 = "+inf.0"
| n < 0 = "-inf.0"
| otherwise = "+nan.0"
showFltAtBase :: Integer -> Double -> String
showFltAtBase b x =
let ((f:r),e) = floatToDigits b x
in d2c f : ("." ++ map d2c r ++ emark b ++
sign (e - 1) ++ shi b (toInteger (abs (e - 1))))
writeFlt :: Double -> Integer -> Maybe Integer -> String
writeFlt n b p =
if isNothing p
then prefix b ++ sign n ++ showFltAtBase b (abs n)
else writeRatF (toRational n) b p
goodBase :: Integer -> Bool
goodBase b = b == 2 || b == 8 || b == 10 || b == 16
badBase :: MonadError LispError m => Integer -> m b
badBase b =
throwError (Default ("bad base " ++ show b ++ " in number->string"))
rStr :: Monad m => String -> m LispVal
rStr = return . String
wrI :: MonadError LispError m =>
Integer -> Integer -> Maybe Integer -> m LispVal
wrI n b p = if goodBase b then rStr (writeInt n b p) else badBase b
wrR :: MonadError LispError m =>
Rational -> Integer -> Maybe Integer -> m LispVal
wrR n b p | isSpRat n = rStr (writeSpRat n)
| goodBase b = rStr (writeRatF n b p)
| otherwise = badBase b
wrF :: MonadError LispError m =>
Double -> Integer -> Maybe Integer -> m LispVal
wrF n b p | isSpFlt n = rStr (writeSpFlt n)
| goodBase b = rStr (writeFlt n b p)
| otherwise = badBase b
writeNum :: [LispVal] -> ThrowsError LispVal
writeNum [IntNumber n] = wrI n 10 Nothing
writeNum [IntNumber n, IntNumber b] = wrI n b Nothing
writeNum [IntNumber n, IntNumber b, IntNumber p] = wrI n b (Just p)
writeNum [RatNumber n] = wrR n 10 Nothing
writeNum [RatNumber n, IntNumber b] = wrR n b Nothing
writeNum [RatNumber n, IntNumber b, IntNumber p] = wrR n b (Just p)
writeNum [FltNumber n] = wrF n 10 Nothing
writeNum [FltNumber n, IntNumber b] = wrF n b Nothing
writeNum [FltNumber n, IntNumber b, IntNumber p] = wrF n b (Just p)
writeNum badArgList =
if length badArgList <= 3
then throwError (TypeMismatch "number->string" "number" (head badArgList))
else throwError (NumArgs "number->string" 3 badArgList)