---------------------------------------------------------------------------
-- |
-- Module      :  Data.Numbers.CrackNum
-- Copyright   :  (c) Levent Erkok
-- License     :  BSD3
-- Maintainer  :  erkokl@gmail.com
-- Stability   :  experimental
--
-- A library for formatting/analyzing FP and Integer values
-----------------------------------------------------------------------------

{-# LANGUAGE    NamedFieldPuns    #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Numbers.CrackNum
   (    -- * Internal representation of a Floating-point numbers
        FP(..), Precision(..), IPrecision(..), Kind(..)
        -- * Creating FP values
      , floatToFP, doubleToFP, stringToFP, integerToFP
        -- * Displaying FP and Int/Word values
      , displayFP, displayWord
   )
   where

import Data.Bits  (testBit, setBit, Bits)
import Data.Char  (toLower)
import Data.Int   (Int8, Int16, Int32, Int64)
import Data.List  (intercalate)
import Data.Maybe (isJust, fromJust, fromMaybe)

import Numeric
import Numeric.IEEE
import Data.Binary.IEEE754

import Data.Numbers.CrackNum.Data
import Data.Numbers.CrackNum.Utils

-- | Crack a Haskell Integer value as the given precision floating value. The Integer should
-- be the value corresponding to the bit-pattern as the float is laid out in memory according
-- to the IEEE rules.
integerToFP :: Precision -> Integer -> FP
integerToFP HP = crack HP   15 15 [14, 13 .. 10]   [9, 8 .. 0]
integerToFP SP = crack SP  127 31 [30, 29 .. 23] [22, 21 .. 0]
integerToFP DP = crack DP 1023 63 [62, 61 .. 52] [51, 50 .. 0]

-- | Use Haskell Float to represent SP
spVal :: Bool -> Int -> [Bool] -> Float
spVal dn expVal fracBits = ((2::Float) ** fromIntegral expVal) * add1 frac
  where frac = sum $ zipWith (\b i -> if b then (2::Float)**(-(fromIntegral (i::Int))) else 0) fracBits [1..]
        add1 | dn   = id
             | True = (1+)

-- | Use Haskell Double to represent DP
dpVal :: Bool -> Int -> [Bool] -> Double
dpVal dn expVal fracBits = ((2::Double) ** fromIntegral expVal) * add1 frac
  where frac = sum $ zipWith (\b i -> if b then (2::Double)**(-(fromIntegral (i::Int))) else 0) fracBits [1..]
        add1 | dn   = id
             | True = (1+)

-- | Assemble a FP from the given bits and pieces.
crack :: Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack vPrec vBias signPos expPos fracPos val
   = FP { intVal    = val
        , prec      = vPrec
        , sign      = vSign
        , stExpt    = vStoredExp
        , expt      = vStoredExp - curBias
        , bias      = curBias
        , fracBits  = vFracBits
        , bitLayOut = layOut [[vSign], vExpBits, vFracBits]
        , kind      = vKind
        }
   where bit i      = val `testBit` i
         vSign      = bit signPos
         vExpBits   = map bit expPos
         vStoredExp = bv vExpBits
         vFracBits  = map bit fracPos
         isZero     = all0 vExpBits && all0 vFracBits
         isDenormal = all0 vExpBits && any1 vFracBits
         isInfinity = all1 vExpBits && all0 vFracBits
         isNAN      = all1 vExpBits && any1 vFracBits
         vKind | isZero     = Zero vSign
               | isInfinity = Infty vSign
               | isNAN      = if head vFracBits then QNaN else SNaN
               | isDenormal = Denormal
               | True       = Normal
         curBias = case vKind of
                     Denormal -> vBias - 1
                     _        -> vBias

-- | Display a Floating-point number in a nicely formatted way. (This function is also available
-- through the 'Show' instance for 'FP', but is provided here for symmetry with 'displayWord'.)
displayFP :: FP -> String
displayFP FP{intVal, prec, sign, stExpt, bias, expt, fracBits, bitLayOut, kind} = intercalate "\n" ls
  where ls =    [ "                  " ++ inds1
                , "                  " ++ inds2
                , "                  " ++ inds3
                , "          Binary: " ++ bitLayOut
                , "             Hex: " ++ hexDisp allBits
                , "       Precision: " ++ show prec
                , "            Sign: " ++ if sign then "Negative" else "Positive"
                , "        Exponent: " ++ show expt ++ " (Stored: " ++ show stExpt ++ ", Bias: " ++ show bias ++ ")"
                , "           Value: " ++ val
                ]
             ++ [ "            Note: Representation for NaN's is not unique." | isNaNKind kind]
        (inds1, inds2, inds3) = case prec of
                                  HP -> (hpInds1, hpInds2, hpInds3)
                                  SP -> (spInds1, spInds2, spInds3)
                                  DP -> (dpInds1, dpInds2, dpInds3)
        allBits = case prec of
                    HP -> [intVal `testBit` i | i <- startsAt 15]
                    SP -> [intVal `testBit` i | i <- startsAt 31]
                    DP -> [intVal `testBit` i | i <- startsAt 63]
            where startsAt n = [n, n-1 .. 0]
        val = case kind of
                Zero    False   -> "+0"
                Zero    True    -> "-0"
                Infty   False   -> "+Infinity"
                Infty   True    -> "-Infinity"
                SNaN            -> "NaN (Screaming)"
                QNaN            -> "NaN (Quietized)"
                Denormal        -> nval True  ++ " (DENORMAL)"
                Normal          -> nval False ++ " (NORMAL)"
        nval dn = (if sign then "-" else "+") ++ v
         where v = case prec of
                     HP -> showGFloat Nothing (spVal dn expt fracBits) ""
                     SP -> showGFloat Nothing (spVal dn expt fracBits) ""
                     DP -> showGFloat Nothing (dpVal dn expt fracBits) ""

-- | Show instance for FP
instance Show FP where
   show = displayFP

-- | Display a Integer (signed/unsigned) number in a nicely formatted way
displayWord :: IPrecision -> Integer -> String
displayWord iprec intVal = intercalate "\n" ls
  where (sg, sz) = sgSz iprec
        ls =   [ "                  " ++ fromJust inds1 | isJust inds1]
            ++ [ "                  " ++ inds2
               , "          Binary: " ++ binDisp allBits
               , "             Hex: " ++ hexDisp allBits
               , "            Type: " ++ show iprec
               ]
            ++ [ "            Sign: " ++ if signBit then "Negative" else "Positive" | sg]
            ++ [ "           Value: " ++ val
               ]
        (inds1, inds2) = case sz of
                           8  -> (Nothing,     bInds2)
                           16 -> (Just wInds1, wInds2)
                           32 -> (Just dInds1, dInds2)
                           64 -> (Just qInds1, qInds2)
                           _  -> error $ "displayWord: Unexpected size: " ++ show sz
        allBits = [intVal `testBit` i | i <- [sz-1, sz-2 .. 0]]
        signBit = head allBits
        val | not sg = show intVal
            | True   = case iprec of
                         I8  -> show $ adjust (0::Int8)
                         I16 -> show $ adjust (0::Int16)
                         I32 -> show $ adjust (0::Int32)
                         I64 -> show $ adjust (0::Int64)
                         _   -> error $ "displayWord: Unexpected type: " ++ show iprec
        adjust :: Bits a => a -> a
        adjust v = foldr (flip setBit) v [i | (i, True) <- zip [0..] (reverse allBits)]

-- | Convert the given string to a IEEE number with the required precision
stringToFP :: Precision -> String -> FP
stringToFP precision input
   = case precision of
        SP -> fromMaybe (error $ "*** stringToFP: Cannot read a valid SP number from: " ++ show input) mbF
        DP -> fromMaybe (error $ "*** stringToFP: Cannot read a valid DP number from: " ++ show input) mbD
        _  -> error $ "*** stringToFP: Unsupported precision: " ++ show precision
  where i = map toLower (dropWhile (== '+') input)
        specials :: [(String, (FP, FP))]
        specials = [ (s, (floatToFP f, doubleToFP d))
                   | (s, (f, d)) <- [ ("infinity",  ( infinity,             infinity))
                                    , ("-infinity", (-infinity,          -  infinity))
                                    , ("0",         ( 0,                    0))
                                    , ("-0",        (-0,                 -  0))
                                    , ("max",       ( maxFinite,            maxFinite))
                                    , ("-max",      (-maxFinite,         -  maxFinite))
                                    , ("min",       ( minNormal,            minNormal))
                                    , ("-min",      (-minNormal,         -  minNormal))
                                    , ("epsilon",   ( epsilon,              epsilon))]  ]
                                 ++ [ ("ulp",       (integerToFP SP 1,          integerToFP DP 1))
                                    , ("nan",       (integerToFP SP 0x7f800001, integerToFP DP 0x7ff0000000000001))
                                    , ("snan",      (integerToFP SP 0x7f800001, integerToFP DP 0x7ff0000000000001))
                                    , ("qnan",      (integerToFP SP 0x7fc00000, integerToFP DP 0x7ff8000000000000))
                                    ]
        mbF, mbD :: Maybe FP
        (mbF, mbD) = case (i `lookup` specials, reads i, reads i) of
                       (Just (f, d), _        , _        ) -> (Just f,         Just d)
                       (Nothing,     [(f, "")], [(d, "")]) -> (Just (floatToFP f),  Just (doubleToFP d))
                       (Nothing,     [(f, "")], _        ) -> (Just (floatToFP f),  Nothing)
                       (Nothing,     _,         [(d, "")]) -> (Nothing,        Just (doubleToFP d))
                       _                                   -> (Nothing,        Nothing)

-- | Turn a Haskell float to the internal detailed FP representation
floatToFP :: Float -> FP
floatToFP = integerToFP SP . toInteger . floatToWord

-- | Turn a Haskell double to the internal detailed FP representation
doubleToFP :: Double -> FP
doubleToFP = integerToFP DP . toInteger . doubleToWord
