{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Graphics.Color.Algebra.Elevator
( Elevator(..)
, module Data.Word
, clamp01
) where
import Data.Complex
import Data.Int
import Data.Typeable
import Data.Vector.Storable (Storable)
import Data.Vector.Unboxed (Unbox)
import Data.Word
import GHC.Float
import Text.Printf
defFieldFormat :: FieldFormat
defFieldFormat = FieldFormat Nothing Nothing Nothing Nothing False "" 'v'
class (Show e, Eq e, Num e, Typeable e, Unbox e, Storable e) => Elevator e where
maxValue :: e
minValue :: e
fieldFormat :: e -> FieldFormat
fieldFormat _ = defFieldFormat
toShowS :: e -> ShowS
default toShowS :: PrintfArg e => e -> ShowS
toShowS e = formatArg e (fieldFormat e)
toWord8 :: e -> Word8
toWord16 :: e -> Word16
toWord32 :: e -> Word32
toWord64 :: e -> Word64
toRealFloat :: (Elevator a, RealFloat a) => e -> a
fromRealFloat :: (Elevator a, RealFloat a) => a -> e
toFloat :: e -> Float
toFloat = toRealFloat
toDouble :: e -> Double
toDouble = toRealFloat
fromDouble :: Double -> e
fromDouble = fromRealFloat
dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b
dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div`
fromIntegral (maxBound :: b))
{-# INLINE dropDown #-}
raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b
raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a))
{-# INLINE raiseUp #-}
squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b
squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a)
{-# INLINE squashTo1 #-}
stretch :: forall a b. (RealFloat a, Integral b, Bounded b) => a -> b
stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e)
{-# INLINE stretch #-}
clamp01 :: RealFloat a => a -> a
clamp01 !x = min (max 0 x) 1
{-# INLINE clamp01 #-}
float2Word32 :: Float -> Word32
float2Word32 d'
| d' <= 0 = 0
| d > 4.294967e9 = maxBound
| otherwise = round d
where
d = maxWord32 * d'
{-# INLINE float2Word32 #-}
maxWord32 :: Float
maxWord32 = F# 4.2949673e9#
{-# INLINE maxWord32 #-}
double2Word64 :: Double -> Word64
double2Word64 d'
| d' <= 0 = 0
| d > 1.844674407370955e19 = maxBound
| otherwise = round d
where
d = maxWord64 * d'
{-# INLINE double2Word64 #-}
maxWord64 :: Double
maxWord64 = D# 1.8446744073709552e19##
{-# INLINE maxWord64 #-}
{-# RULES
"fromRealFloat :: Double -> Word" fromRealFloat = fromDouble :: Double -> Word
"fromRealFloat :: Double -> Word64" fromRealFloat = fromDouble :: Double -> Word64
"fromRealFloat :: Float -> Word32" fromRealFloat = float2Word32
#-}
instance Elevator Word8 where
maxValue = maxBound
minValue = minBound
fieldFormat _ = defFieldFormat {fmtWidth = Just 3, fmtChar = 'd'}
toWord8 = id
{-# INLINE toWord8 #-}
toWord16 = raiseUp
{-# INLINE toWord16 #-}
toWord32 = raiseUp
{-# INLINE toWord32 #-}
toWord64 = raiseUp
{-# INLINE toWord64 #-}
toFloat = squashTo1
{-# INLINE toFloat #-}
toDouble = squashTo1
{-# INLINE toDouble #-}
fromDouble = toWord8
{-# INLINE fromDouble #-}
toRealFloat = squashTo1
{-# INLINE toRealFloat #-}
fromRealFloat = toWord8
{-# INLINE fromRealFloat #-}
instance Elevator Word16 where
maxValue = maxBound
minValue = minBound
fieldFormat _ = defFieldFormat { fmtWidth = Just 5, fmtChar = 'd'}
toWord8 = dropDown
{-# INLINE toWord8 #-}
toWord16 = id
{-# INLINE toWord16 #-}
toWord32 = raiseUp
{-# INLINE toWord32 #-}
toWord64 = raiseUp
{-# INLINE toWord64 #-}
toFloat = squashTo1
{-# INLINE toFloat #-}
toDouble = squashTo1
{-# INLINE toDouble #-}
fromDouble = toWord16
{-# INLINE fromDouble #-}
toRealFloat = squashTo1
{-# INLINE toRealFloat #-}
fromRealFloat = toWord16
{-# INLINE fromRealFloat #-}
instance Elevator Word32 where
maxValue = maxBound
minValue = minBound
fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}
toWord8 = dropDown
{-# INLINE toWord8 #-}
toWord16 = dropDown
{-# INLINE toWord16 #-}
toWord32 = id
{-# INLINE toWord32 #-}
toWord64 = raiseUp
{-# INLINE toWord64 #-}
toFloat = squashTo1
{-# INLINE toFloat #-}
toDouble = squashTo1
{-# INLINE toDouble #-}
fromDouble = toWord32
{-# INLINE fromDouble #-}
toRealFloat = squashTo1
{-# INLINE toRealFloat #-}
fromRealFloat = toWord32
{-# INLINE fromRealFloat #-}
instance Elevator Word64 where
maxValue = maxBound
minValue = minBound
fieldFormat _ = defFieldFormat { fmtWidth = Just 20, fmtChar = 'd'}
toWord8 = dropDown
{-# INLINE toWord8 #-}
toWord16 = dropDown
{-# INLINE toWord16 #-}
toWord32 = dropDown
{-# INLINE toWord32 #-}
toWord64 = id
{-# INLINE toWord64 #-}
toFloat = squashTo1
{-# INLINE toFloat #-}
toDouble = squashTo1
{-# INLINE toDouble #-}
fromDouble = double2Word64
{-# INLINE fromDouble #-}
toRealFloat = squashTo1
{-# INLINE toRealFloat #-}
fromRealFloat = toWord64
{-# INLINE fromRealFloat #-}
instance Elevator Word where
maxValue = maxBound
minValue = minBound
#if WORD_SIZE_IN_BITS < 64
fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}
toWord64 = dropDown
{-# INLINE toWord64 #-}
fromDouble = stretch
{-# INLINE fromDouble #-}
#else
fieldFormat _ = defFieldFormat { fmtWidth = Just 20, fmtChar = 'd'}
toWord64 (W64# w#) = (W# w#)
{-# INLINE toWord64 #-}
fromDouble = toWord64 . double2Word64
{-# INLINE fromDouble #-}
#endif
toWord8 = dropDown
{-# INLINE toWord8 #-}
toWord16 = dropDown
{-# INLINE toWord16 #-}
toWord32 = dropDown
{-# INLINE toWord32 #-}
toFloat = squashTo1
{-# INLINE toFloat #-}
toDouble = squashTo1
{-# INLINE toDouble #-}
toRealFloat = squashTo1
{-# INLINE toRealFloat #-}
fromRealFloat = stretch
{-# INLINE fromRealFloat #-}
instance Elevator Int8 where
maxValue = maxBound
minValue = 0
fieldFormat _ = defFieldFormat { fmtWidth = Just 3, fmtChar = 'd'}
toWord8 = fromIntegral . max 0
{-# INLINE toWord8 #-}
toWord16 = raiseUp . max 0
{-# INLINE toWord16 #-}
toWord32 = raiseUp . max 0
{-# INLINE toWord32 #-}
toWord64 = raiseUp . max 0
{-# INLINE toWord64 #-}
toFloat = squashTo1 . max 0
{-# INLINE toFloat #-}
toRealFloat = squashTo1 . max 0
{-# INLINE toRealFloat #-}
fromRealFloat = stretch
{-# INLINE fromRealFloat #-}
instance Elevator Int16 where
maxValue = maxBound
minValue = 0
fieldFormat _ = defFieldFormat { fmtWidth = Just 5, fmtChar = 'd'}
toWord8 = dropDown . max 0
{-# INLINE toWord8 #-}
toWord16 = fromIntegral . max 0
{-# INLINE toWord16 #-}
toWord32 = raiseUp . max 0
{-# INLINE toWord32 #-}
toWord64 = raiseUp . max 0
{-# INLINE toWord64 #-}
toFloat = squashTo1 . max 0
{-# INLINE toFloat #-}
toRealFloat = squashTo1 . max 0
{-# INLINE toRealFloat #-}
fromRealFloat = stretch
{-# INLINE fromRealFloat #-}
instance Elevator Int32 where
maxValue = maxBound
minValue = 0
fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}
toWord8 = dropDown . max 0
{-# INLINE toWord8 #-}
toWord16 = dropDown . max 0
{-# INLINE toWord16 #-}
toWord32 = fromIntegral . max 0
{-# INLINE toWord32 #-}
toWord64 = raiseUp . max 0
{-# INLINE toWord64 #-}
toFloat = squashTo1 . max 0
{-# INLINE toFloat #-}
toRealFloat = squashTo1 . max 0
{-# INLINE toRealFloat #-}
fromRealFloat = stretch
{-# INLINE fromRealFloat #-}
instance Elevator Int64 where
maxValue = maxBound
minValue = 0
fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtChar = 'd'}
toWord8 = dropDown . max 0
{-# INLINE toWord8 #-}
toWord16 = dropDown . max 0
{-# INLINE toWord16 #-}
toWord32 = dropDown . max 0
{-# INLINE toWord32 #-}
toWord64 = fromIntegral . max 0
{-# INLINE toWord64 #-}
toFloat = squashTo1 . max 0
{-# INLINE toFloat #-}
toRealFloat = squashTo1 . max 0
{-# INLINE toRealFloat #-}
fromRealFloat = stretch
{-# INLINE fromRealFloat #-}
instance Elevator Int where
maxValue = maxBound
minValue = 0
#if WORD_SIZE_IN_BITS < 64
fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}
toWord64 = dropDown . max 0
{-# INLINE toWord64 #-}
#else
fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtChar = 'd'}
toWord64 = fromIntegral . max 0
{-# INLINE toWord64 #-}
#endif
toWord8 = dropDown . max 0
{-# INLINE toWord8 #-}
toWord16 = dropDown . max 0
{-# INLINE toWord16 #-}
toWord32 = dropDown . max 0
{-# INLINE toWord32 #-}
toFloat = squashTo1 . max 0
{-# INLINE toFloat #-}
toRealFloat = squashTo1 . max 0
{-# INLINE toRealFloat #-}
fromRealFloat = stretch
{-# INLINE fromRealFloat #-}
instance Elevator Float where
maxValue = 1
minValue = 0
fieldFormat _ = defFieldFormat { fmtWidth = Just 9, fmtPrecision = Just 6, fmtChar = 'f'}
toWord8 = stretch
{-# INLINE toWord8 #-}
toWord16 = stretch
{-# INLINE toWord16 #-}
toWord32 = float2Word32
{-# INLINE toWord32 #-}
toWord64 = stretch
{-# INLINE toWord64 #-}
toFloat = id
{-# INLINE toFloat #-}
toDouble = float2Double
{-# INLINE toDouble #-}
fromDouble = toFloat
{-# INLINE fromDouble #-}
toRealFloat = uncurry encodeFloat . decodeFloat
{-# INLINE toRealFloat #-}
fromRealFloat = uncurry encodeFloat . decodeFloat
{-# INLINE fromRealFloat #-}
instance Elevator Double where
maxValue = 1
minValue = 0
fieldFormat _ = defFieldFormat { fmtWidth = Just 15, fmtPrecision = Just 12, fmtChar = 'f' }
toWord8 = stretch
{-# INLINE toWord8 #-}
toWord16 = stretch
{-# INLINE toWord16 #-}
toWord32 = stretch
{-# INLINE toWord32 #-}
toWord64 = double2Word64
{-# INLINE toWord64 #-}
toFloat = double2Float
{-# INLINE toFloat #-}
toDouble = id
{-# INLINE toDouble #-}
fromDouble = id
{-# INLINE fromDouble #-}
toRealFloat = uncurry encodeFloat . decodeFloat
{-# INLINE toRealFloat #-}
fromRealFloat = uncurry encodeFloat . decodeFloat
{-# INLINE fromRealFloat #-}
{-# RULES
"toRealFloat :: Double -> Double / Float -> Float" toRealFloat = id
"toRealFloat :: Double -> Float" toRealFloat = double2Float
"toRealFloat :: Float -> Double" toRealFloat = float2Double
"fromRealFloat :: Double -> Double / Float -> Float" fromRealFloat = id
"fromRealFloat :: Double -> Float" fromRealFloat = double2Float
"fromRealFloat :: Float -> Double" fromRealFloat = float2Double
#-}
instance (PrintfArg e, Elevator e, RealFloat e) => Elevator (Complex e) where
maxValue = maxValue :+ maxValue
minValue = minValue :+ minValue
toShowS (r :+ i) = toShowS r . formatArg i ((fieldFormat i) {fmtSign = Just SignPlus}) . ('i' :)
toWord8 = toWord8 . realPart
{-# INLINE toWord8 #-}
toWord16 = toWord16 . realPart
{-# INLINE toWord16 #-}
toWord32 = toWord32 . realPart
{-# INLINE toWord32 #-}
toWord64 = toWord64 . realPart
{-# INLINE toWord64 #-}
toFloat = toFloat . realPart
{-# INLINE toFloat #-}
toDouble = toDouble . realPart
{-# INLINE toDouble #-}
fromDouble = (:+ 0) . fromDouble
{-# INLINE fromDouble #-}
toRealFloat = toRealFloat . realPart
{-# INLINE toRealFloat #-}
fromRealFloat = (:+ 0) . fromRealFloat
{-# INLINE fromRealFloat #-}