{- Copyright 2008 Uwe Hollerbach
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 I can't easily tell anymore who originally wrote what)
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.14 2009-05-31 01:41:08 uwe Exp $ -}
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"
-- 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 d = ("0123456789abcdef" !! d)
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 -> [Char]
writeSpRat n | n == myRatNaN = "0/0"
| n == myRatPInf = "1/0"
| n == myRatNInf = "-1/0"
-- 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))
lb1 = toInteger (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 ((signum num)*sn) b (Just (abs p))) ++ (ssuf se)
strr = (writeRatF ((signum num)*snr) 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 s = chek (takeWhile (/= '.') s)
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 b =
throwError (Default ("bad base " ++ (show b) ++ " in number->string"))
writeNum :: [LispVal] -> ThrowsError LispVal
writeNum [IntNumber n] = return (String (writeInt n 10 Nothing))
writeNum [IntNumber n, IntNumber b] =
if goodBase b
then return (String (writeInt n b Nothing))
else badBase b
writeNum [IntNumber n, IntNumber b, IntNumber p] =
if goodBase b
then return (String (writeInt n b (Just p)))
else badBase b
writeNum [RatNumber n] = writeNum [RatNumber n, IntNumber 10]
writeNum [RatNumber n, IntNumber b] =
if isSpRat n
then return (String (writeSpRat n))
else if goodBase b
then return (String (writeRatF n b Nothing))
else badBase b
writeNum [RatNumber n, IntNumber b, IntNumber p] =
if isSpRat n
then return (String (writeSpRat n))
else if goodBase b
then return (String (writeRatF n b (Just p)))
else badBase b
writeNum [FltNumber n] = writeNum [FltNumber n, IntNumber 10]
writeNum [FltNumber n, IntNumber b] =
if isSpFlt n
then return (String (writeSpFlt n))
else if goodBase b
then return (String (writeFlt n b Nothing))
else badBase b
writeNum [FltNumber n, IntNumber b, IntNumber p] =
if isSpFlt n
then return (String (writeSpFlt n))
else if goodBase b
then return (String (writeFlt n b (Just p)))
else badBase b
writeNum badArgList =
if length badArgList <= 3
then throwError (TypeMismatch "number->string" "number" (badArgList !! 0))
else throwError (NumArgs "number->string" 3 badArgList)