Some tests for Elevator

Color/Color.cabal

@@ -104,7 +104,8 @@ test-suite tests
   type:               exitcode-stdio-1.0
   hs-source-dirs:     tests
   main-is:            Main.hs
-  other-modules:      Graphics.Color.Illuminant.CIE1931Spec
+  other-modules:      Graphics.Color.Algebra.ElevatorSpec
+                    , Graphics.Color.Illuminant.CIE1931Spec
                     , Graphics.Color.Illuminant.CIE1964Spec
                     , Graphics.Color.Illuminant.Common
                     , Graphics.Color.Illuminant.WikipediaSpec

Color/src/Graphics/Color/Algebra/Elevator.hs

@@ -93,9 +93,24 @@ squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a)
 
 -- | Convert to integral streaching it's value up to a maximum value.
 stretch :: forall a b. (RealFloat a, Integral b, Bounded b) => a -> b
-stretch !e = roundRealFloatPositive (fromIntegral (maxBound :: b) * clamp01 e)
+stretch !e = --round (fromIntegral (maxBound :: b) * clamp01 e)
+  roundRealFloatPositive (fromIntegral (maxBound :: b) * clamp01 e)
 {-# INLINE stretch #-}
 
+roundRealFloatPositive :: forall a b . (Integral b, Bounded b, RealFloat a) => a -> b
+roundRealFloatPositive x
+  | rounded > toInteger (maxBound :: b) = maxBound
+  | otherwise = fromIntegral rounded
+  where
+    rounded =
+      case decodeFloat x of
+        (m, n) ->
+          if n >= 0
+            then m * 2 ^ n
+            else case quotRem m (2 ^ negate n) of
+                   (w, r)
+                     | odd w && encodeFloat r n >= (0.5 :: Float) -> w + 1
+                     | otherwise -> w
 
 -- | Clamp a value to @[0, 1]@ range.
 clamp01 :: RealFloat a => a -> a
@@ -208,17 +223,19 @@ instance Elevator Word where
   minValue = minBound
 #if WORD_SIZE_IN_BITS < 64
   fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}
+  toWord64 = dropDown
+  {-# INLINE toWord64 #-}
 #else
   fieldFormat _ = defFieldFormat { fmtWidth = Just 20, fmtChar = 'd'}
+  toWord64 = fromIntegral
+  {-# INLINE toWord64 #-}
 #endif
   toWord8 = dropDown
   {-# INLINE toWord8 #-}
   toWord16 = dropDown
   {-# INLINE toWord16 #-}
   toWord32 = dropDown
   {-# INLINE toWord32 #-}
-  toWord64 = fromIntegral
-  {-# INLINE toWord64 #-}
   toFloat = squashTo1
   {-# INLINE toFloat #-}
   toDouble = squashTo1
@@ -320,17 +337,19 @@ instance Elevator Int where
   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 #-}
-  toWord64 = fromIntegral . max 0
-  {-# INLINE toWord64 #-}
   toFloat = squashTo1 . max 0
   {-# INLINE toFloat #-}
   toRealFloat = squashTo1 . max 0
@@ -421,21 +440,3 @@ instance (PrintfArg e, Elevator e, RealFloat e) => Elevator (Complex e) where
   {-# INLINE toRealFloat #-}
   fromRealFloat = (:+ 0) . fromRealFloat
   {-# INLINE fromRealFloat #-}
-
-
-
-
-roundRealFloatPositive :: forall a b . (Integral b, Bounded b, RealFloat a) => a -> b
-roundRealFloatPositive x
-  | rounded > toInteger (maxBound :: b) = maxBound
-  | otherwise = fromIntegral rounded
-  where
-    rounded =
-      case decodeFloat x of
-        (m, n) ->
-          if n >= 0
-            then m * 2 ^ n
-            else case quotRem m (2 ^ negate n) of
-                   (w, r)
-                     | odd w && encodeFloat r n >= (0.5 :: Float) -> w + 1
-                     | otherwise -> w

Color/tests/Graphics/Color/Algebra/ElevatorSpec.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Graphics.Color.Algebra.ElevatorSpec (spec) where
+
+import Graphics.Color.Algebra
+import Graphics.Color.Model.Common
+
+eprop :: (Testable prop, Elevator a, Random a) => String -> (a -> prop) -> Spec
+eprop name = prop name . forAll arbitraryElevator
+
+
+spec :: Spec
+spec =
+  describe "Elevator" $ do
+    describe "Word8" $ do
+      eprop "toWord8 . toWord8" $ \(e :: Word8) -> e === toWord8 e
+      eprop "toWord8 . toWord16" $ \(e :: Word8) -> e === toWord8 (toWord16 e)
+      eprop "toWord8 . toWord32" $ \(e :: Word8) -> e === toWord8 (toWord32 e)
+      eprop "toWord8 . toWord64" $ \(e :: Word8) -> e === toWord8 (toWord64 e)
+      eprop "toWord8 . toFloat" $ \(e :: Word8) -> e === toWord8 (toFloat e)
+      eprop "toWord8 . toDouble" $ \(e :: Word8) -> e === toWord8 (toDouble e)
+      eprop "toWord8 . toRealFloat :: Float" $ \(e :: Word8) ->
+        e === toWord8 (toRealFloat e :: Float)
+      eprop "toWord8 . toRealFloat :: Double" $ \(e :: Word8) ->
+        e === toWord8 (toRealFloat e :: Double)
+      eprop "fromRealFloat . toRealFloat :: Float" $ \(e :: Word8) ->
+        e === fromRealFloat (toRealFloat e :: Float)
+      eprop "fromRealFloat . toRealFloat :: Double" $ \(e :: Word8) ->
+        e === fromRealFloat (toRealFloat e :: Double)
+      eprop "fromDouble . toDouble" $ \(e :: Word8) -> e === fromDouble (toDouble e)
+      eprop "read . toShowS" $ \(e :: Word8) -> e === read (toShowS e "")
+    describe "Word16" $ do
+      eprop "toWord16 . toWord16" $ \(e :: Word16) -> e === toWord16 e
+      eprop "toWord16 . toWord32" $ \(e :: Word16) -> e === toWord16 (toWord32 e)
+      eprop "toWord16 . toWord64" $ \(e :: Word16) -> e === toWord16 (toWord64 e)
+      eprop "toWord16 . toFloat" $ \(e :: Word16) -> e === toWord16 (toFloat e)
+      eprop "toWord16 . toDouble" $ \(e :: Word16) -> e === toWord16 (toDouble e)
+      eprop "toWord16 . toRealFloat :: Float" $ \(e :: Word16) ->
+        e === toWord16 (toRealFloat e :: Float)
+      eprop "toWord16 . toRealFloat :: Double" $ \(e :: Word16) ->
+        e === toWord16 (toRealFloat e :: Double)
+      eprop "fromRealFloat . toRealFloat :: Float" $ \(e :: Word16) ->
+        e === fromRealFloat (toRealFloat e :: Float)
+      eprop "fromRealFloat . toRealFloat :: Double" $ \(e :: Word16) ->
+        e === fromRealFloat (toRealFloat e :: Double)
+      eprop "fromDouble . toDouble" $ \(e :: Word16) -> e === fromDouble (toDouble e)
+      eprop "read . toShowS" $ \(e :: Word16) -> e === read (toShowS e "")
+    describe "Word32" $ do
+      eprop "toWord32 . toWord32" $ \(e :: Word32) -> e === toWord32 e
+      eprop "toWord32 . toWord64" $ \(e :: Word32) -> e === toWord32 (toWord64 e)
+      prop "toWord32 . toFloat" $
+        forAll (choose (0, maxFloatI)) $ \(e :: Word32) -> e === toWord32 (toFloat e)
+      eprop "toWord32 . toDouble" $ \(e :: Word32) -> e === toWord32 (toDouble e)
+      prop "toWord32 . toRealFloat :: Float" $
+        forAll (choose (0, maxFloatI)) $ \(e :: Word32) -> e === toWord32 (toRealFloat e :: Float)
+      eprop "toWord32 . toRealFloat :: Double" $ \(e :: Word32) ->
+        e === toWord32 (toRealFloat e :: Double)
+      prop "fromRealFloat . toRealFloat :: Float" $
+        forAll (choose (0, maxFloatI)) $ \(e :: Word32) ->
+          e === fromRealFloat (toRealFloat e :: Float)
+      eprop "fromRealFloat . toRealFloat :: Double" $ \(e :: Word32) ->
+        e === fromRealFloat (toRealFloat e :: Double)
+      eprop "fromDouble . toDouble" $ \(e :: Word32) -> e === fromDouble (toDouble e)
+      eprop "read . toShowS" $ \(e :: Word32) -> e === read (toShowS e "")
+    describe "Word64" $ do
+      eprop "toWord64 . toWord64" $ \(e :: Word64) -> e === toWord64 e
+      prop "toWord64 . toFloat" $
+        forAll (choose (0, maxFloatI)) $ \(e :: Word64) -> e === toWord64 (toFloat e)
+      prop "toWord64 . toDouble" $
+        forAll (choose (0, maxDoubleI)) $ \(e :: Word64) ->
+          shouldBeApproxIntegral 1 e (toWord64 (toDouble e))
+      prop "toWord64 . toRealFloat :: Float" $
+        forAll (choose (0, maxFloatI)) $ \(e :: Word64) -> e === toWord64 (toRealFloat e :: Float)
+      prop "toWord64 . toRealFloat :: Double" $
+        forAll (choose (0, maxDoubleI)) $ \(e :: Word64) ->
+          shouldBeApproxIntegral 1 e (toWord64 (toRealFloat e :: Double))
+      prop "fromRealFloat . toRealFloat :: Float" $
+        forAll (choose (0, maxFloatI)) $ \(e :: Word64) ->
+          e === fromRealFloat (toRealFloat e :: Float)
+      prop "fromRealFloat . toRealFloat :: Double" $
+        forAll (choose (0, maxFloatI)) $ \(e :: Word64) ->
+          e === fromRealFloat (toRealFloat e :: Double)
+      prop "fromDouble . toDouble" $
+        forAll (choose (0, maxDoubleI)) $ \(e :: Word64) ->
+          shouldBeApproxIntegral 1 e (fromDouble (toDouble e))
+      eprop "read . toShowS" $ \(e :: Word64) -> e === read (toShowS e "")
+    describe "Float" $ do
+      -- eprop "toWord8 . toWord8" $ \(e :: Word8) -> e === toWord8 e
+      -- eprop "toWord8 . toWord16" $ \(e :: Word8) -> e === toWord8 (toWord16 e)
+      -- eprop "toWord8 . toWord32" $ \(e :: Word8) -> e === toWord8 (toWord32 e)
+      -- eprop "toWord8 . toWord64" $ \(e :: Word8) -> e === toWord8 (toWord64 e)
+      -- eprop "toWord8 . toFloat" $ \(e :: Word8) -> e === toWord8 (toFloat e)
+      -- eprop "toWord8 . toDouble" $ \(e :: Word8) -> e === toWord8 (toDouble e)
+      -- eprop "toWord8 . toRealFloat :: Float" $ \(e :: Word8) ->
+      --   e === toWord8 (toRealFloat e :: Float)
+      -- eprop "toWord8 . toRealFloat :: Double" $ \(e :: Word8) ->
+      --   e === toWord8 (toRealFloat e :: Double)
+      eprop "fromRealFloat . toRealFloat :: Float" $ \(e :: Float) ->
+        e === fromRealFloat (toRealFloat e :: Float)
+      eprop "fromRealFloat . toRealFloat :: Double" $ \(e :: Float) ->
+        e === fromRealFloat (toRealFloat e :: Double)
+      eprop "fromDouble . toDouble" $ \(e :: Float) -> e === fromDouble (toDouble e)
+      eprop "read . toShowS" $ \(e :: Float) -> e === read (toShowS e "")
+    describe "Double" $ do
+      it "toWord64 edge case" $ toWord64 (1 :: Double) `shouldBe` maxBound
+  where
+    maxFloatI, maxDoubleI :: Integral a => a
+    maxFloatI = 2 ^ (24 :: Int)
+    maxDoubleI = 2 ^ (54 :: Int)

Color/tests/Graphics/Color/Illuminant/CIE1931Spec.hs

@@ -80,8 +80,8 @@ daylightChromaticityX_7000to25000K t =
   + 1.90180 * 10 ^ (6 :: Int) / (t ^ (2 :: Int))
   - 2.00640 * 10 ^ (9 :: Int) / (t ^ (3 :: Int))
 
-chromaticity :: (Show e, RealFloat e) => e -> V2 e
-chromaticity t = V2 x y
+_chromaticity :: (Show e, RealFloat e) => e -> V2 e
+_chromaticity t = V2 x y
   where
     x
       | 4000 <= t && t < 7000 = daylightChromaticityX_4000to7000K t
@@ -91,15 +91,11 @@ chromaticity t = V2 x y
 
 
 
-ts =
+_ts :: [Double]
+_ts =
   [ unCCT (colorTemperature :: CCT 'D50)
   , unCCT (colorTemperature :: CCT 'D55)
   , unCCT (colorTemperature :: CCT 'D60)
   , unCCT (colorTemperature :: CCT 'D65)
   , unCCT (colorTemperature :: CCT 'D75)
   ]
-
-
---data D (t :: Nat)
-
---instance