{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
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. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b
stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e)
{-# INLINE stretch #-}
clamp01 :: (Ord a, Floating a) => a -> a
clamp01 !x = min (max 0 x) 1
{-# INLINE clamp01 #-}
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 = toWord64
{-# 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'}
#else
fieldFormat _ = defFieldFormat { fmtWidth = Just 20, fmtChar = 'd'}
#endif
toWord8 = dropDown
{-# INLINE toWord8 #-}
toWord16 = dropDown
{-# INLINE toWord16 #-}
toWord32 = dropDown
{-# INLINE toWord32 #-}
toWord64 = fromIntegral
{-# INLINE toWord64 #-}
toFloat = squashTo1
{-# INLINE toFloat #-}
toDouble = squashTo1
{-# INLINE toDouble #-}
fromDouble = stretch . clamp01
{-# INLINE fromDouble #-}
toRealFloat = squashTo1
{-# INLINE toRealFloat #-}
fromRealFloat = stretch . clamp01
{-# 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 . clamp01
{-# 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 . clamp01
{-# 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 . clamp01
{-# 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 . clamp01
{-# INLINE fromRealFloat #-}
instance Elevator Int where
maxValue = maxBound
minValue = 0
#if WORD_SIZE_IN_BITS < 64
fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}
#else
fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtChar = 'd'}
#endif
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 . clamp01
{-# INLINE fromRealFloat #-}
instance Elevator Float where
maxValue = 1
minValue = 0
fieldFormat _ = defFieldFormat { fmtWidth = Just 9, fmtPrecision = Just 6, fmtChar = 'f'}
toWord8 = stretch . clamp01
{-# INLINE toWord8 #-}
toWord16 = stretch . clamp01
{-# INLINE toWord16 #-}
toWord32 = stretch . clamp01
{-# INLINE toWord32 #-}
toWord64 = stretch . clamp01
{-# 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 . clamp01
{-# INLINE toWord8 #-}
toWord16 = stretch . clamp01
{-# INLINE toWord16 #-}
toWord32 = stretch . clamp01
{-# INLINE toWord32 #-}
toWord64 = stretch . clamp01
{-# 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 #-}