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