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