colors 0.1.1 → 0.2

raw patch · 2 files changed

+53/−26 lines, 2 files

Files

Data/Color.hs +49/−25
colors.cabal +4/−1

Data/Color.hs view

@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
 -- |
--- Module      :  Data.Color
+-- Module      :  Data.RGBA
 -- Copyright   :  (C) 2013 Fumiaki Kinoshita
 -- License     :  BSD-style (see the file LICENSE)
 --
@@ -8,56 +8,77 @@ -- Stability   :  provisional
 -- Portability :  non-portable
 --
--- Colors and its operations
+-- RGBAs and its operations
 ----------------------------------------------------------------------------
 module Data.Color (
     -- * The type
-    Color(..)
-    -- * Color operations
+    RGBA(..)
+    , Color
+    -- * RGBA operations
     , blend
+    , multRGBA
     , module Data.Color.Class
     ) where
 
 import Data.String
 import Data.Char
 import Data.Color.Class
+import Foreign.Storable
+import Foreign.Ptr
+import Control.Applicative
 
+type Color = RGBA
+
 -- | A color that has red, green, blue, alpha as its components.
 -- It is an instance of 'HasRGB' so there are some lenses to tweak individual components.
-data Color = Color Float Float Float Float deriving (Show, Read, Eq, Ord)
+data RGBA = RGBA Float Float Float Float deriving (Show, Read, Eq, Ord)
 
-instance HasRGB Color where
-    fromRGB r g b = Color r g b 1.0
-    _Red f (Color r g b a) = fmap (\r' -> Color r' g b a) (f r)
-    _Green f (Color r g b a) = fmap (\g' -> Color r g' b a) (f g)
-    _Blue f (Color r g b a) = fmap (\b' -> Color r g b' a) (f b)
+instance Storable RGBA where
+    sizeOf _ = sizeOf (0 :: Float) * 4
+    alignment _ = 0
+    peek ptr = RGBA
+        <$> peekElemOff (castPtr ptr) 0 
+        <*> peekElemOff (castPtr ptr) 1
+        <*> peekElemOff (castPtr ptr) 2
+        <*> peekElemOff (castPtr ptr) 3
+    poke ptr (RGBA r g b a) = do
+        pokeElemOff (castPtr ptr) 0 r
+        pokeElemOff (castPtr ptr) 1 g
+        pokeElemOff (castPtr ptr) 2 b
+        pokeElemOff (castPtr ptr) 3 a
 
-instance HasHSB Color where
+instance HasRGB RGBA where
+    fromRGB r g b = RGBA r g b 1.0
+    _Red f (RGBA r g b a) = fmap (\r' -> RGBA r' g b a) (f r)
+    _Green f (RGBA r g b a) = fmap (\g' -> RGBA r g' b a) (f g)
+    _Blue f (RGBA r g b a) = fmap (\b' -> RGBA r g b' a) (f b)
+
+instance HasHSB RGBA where
     fromHSB h s v = hsv_rgb h s v (argb 1.0)
-    _Hue f (Color r g b a) = rgb_hsv r g b $ \h s v -> fmap (\h' -> hsv_rgb h' s v (argb a)) (f h)
-    _Saturation f (Color r g b a) = rgb_hsv r g b $ \h s v -> fmap (\s' -> hsv_rgb h s' v (argb a)) (f s)
-    _Brightness f (Color r g b a) = rgb_hsv r g b $ \h s v -> fmap (\v' -> hsv_rgb h s v' (argb a)) (f v)
+    _Hue f (RGBA r g b a) = rgb_hsv r g b $ \h s v -> fmap (\h' -> hsv_rgb h' s v (argb a)) (f h)
+    _Saturation f (RGBA r g b a) = rgb_hsv r g b $ \h s v -> fmap (\s' -> hsv_rgb h s' v (argb a)) (f s)
+    _Brightness f (RGBA r g b a) = rgb_hsv r g b $ \h s v -> fmap (\v' -> hsv_rgb h s v' (argb a)) (f v)
 
-instance HasAlpha Color where
-    _Alpha f (Color r g b a) = fmap (\a' -> Color r g b a') (f a)
+instance HasAlpha RGBA where
+    _Alpha f (RGBA r g b a) = fmap (\a' -> RGBA r g b a') (f a)
 
-instance IsString Color where
-    fromString xs@[r,g,b,a] | all isHexDigit xs = Color (hf r) (hf g) (hf b) (hf a)
-    fromString xs@[r,g,b] | all isHexDigit xs = Color (hf r) (hf g) (hf b) 1
-    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
-    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
+instance IsString RGBA where
+    fromString xs@[r,g,b,a] | all isHexDigit xs = RGBA (hf r) (hf g) (hf b) (hf a)
+    fromString xs@[r,g,b] | all isHexDigit xs = RGBA (hf r) (hf g) (hf b) 1
+    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = RGBA (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
+    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = RGBA (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
     fromString x = error $ "Invalid color representation: " ++ x
 
 -- | Blend two colors.
-blend :: Float -> Color -> Color -> Color
-blend t (Color r0 g0 b0 a0) (Color r1 g1 b1 a1) = Color
+blend :: Num a => Float -> RGBA -> RGBA -> RGBA
+blend t (RGBA r0 g0 b0 a0) (RGBA r1 g1 b1 a1) = RGBA
     (r0 * (1 - t) + r1 * t)
     (g0 * (1 - t) + g1 * t)
     (b0 * (1 - t) + b1 * t)
     (a0 * (1 - t) + a1 * t)
 
-argb :: Float -> Float -> Float -> Float -> Color
-argb a r g b = Color r g b a
+argb :: Float -> Float -> Float -> Float -> RGBA
+argb a r g b = RGBA r g b a
 
 rgb_hsv :: Float -> Float -> Float -> (Float -> Float -> Float -> a) -> a
 rgb_hsv r g b f = f h (s / maxC) maxC where
@@ -90,3 +111,6 @@ 
 hf' :: Char -> Char -> Float
 hf' x y = fromIntegral (digitToInt x * 16 + digitToInt y) / 255
+
+multRGBA :: RGBA -> RGBA -> RGBA
+multRGBA (RGBA r0 g0 b0 a0) (RGBA r1 g1 b1 a1) = RGBA (r0 * r1) (g0 * g1) (b0 * b1) (a0 * a1)

colors.cabal view

@@ -1,5 +1,8 @@+-- Initial colors.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
 name:                colors
-version:             0.1.1
+version:             0.2
 synopsis:            A type for colors
 -- description:         
 homepage:            https://github.com/fumieval/colors