4 files changed, 29 insertions(+), 19 deletions(-)

M lib/Graphics/Rendering/Rect.hs
M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs
M lib/Graphics/Rendering/Rect/Types.hs

@@ 35,7 35,7 @@ styleResolveImages atlas self =
   where
     atlasLookup' None = None
     atlasLookup' (Img path) = Img $ atlasLookup path atlas
-    atlasLookup' (Linear a b c) = Linear a b c
+    atlasLookup' (Linear a b) = Linear a b
 
 atlasFromStyles :: MonadIO m =>
         (Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas

@@ 32,15 32,16 @@ linearFragmentShader = B8.pack $ unlines [
     "in vec2 coord;",
     "out vec4 fcolour;",
     "uniform vec2 size;",
-    "uniform vec4 start;",
-    "uniform vec4 end;",
+    "uniform vec4 stops[10];",
+    "uniform int nStops;",
     "uniform float angle;",
     "void main() {",
     "   vec2 pos = coord/size;", -- Range 0..1
     "   pos -= 0.5; pos *= 2;", -- Range -1..1
     "   float a = pos.x*sin(angle) + pos.y*-cos(angle);", -- Range -1..1
     "   a /= 2; a += 0.5;", -- Range 0..1
-    "   fcolour = mix(start, end, a);",
+    "   a *= float(min(nStops, 10) - 1);", -- Range 0..(nStops-1)
+    "   fcolour = mix(stops[int(floor(a))], stops[int(ceil(a))], fract(a));",
     "}"
   ]
 


@@ 49,7 50,7 @@ renderBackgrounds :: (MonadIO m, MonadIO n) =>
 renderBackgrounds = do
     base <- renderRectWith baseFragmentShader ["colour"]
     layer <- renderRectWith imageFragmentShader ["size"]
-    linear <- renderRectWith linearFragmentShader ["size", "start", "end", "angle"]
+    linear <- renderRectWith linearFragmentShader ["size","stops","nStops","angle"]
     return $ \self a b -> do
         base [] [c $ background self] (headDef borderBox $ clip self) a b
         let layers = image self `zip` (clip self ++ repeat borderBox)


@@ 59,8 60,8 @@ renderBackgrounds = do
             Img img0 -> layer [img0] [
                     u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
                 ] clip0 a b
-            Linear angle start end -> linear [] [
-                    u $ v2 $ size $ clip0 a, c start, c end, u angle
+            Linear angle stops -> linear [] [
+                    u $ v2 $ size $ clip0 a, cs 10 stops, u $ length stops, u angle
                 ] clip0 a b
         return ()
 

@@ 24,7 24,7 @@ data Backgrounds img = Backgrounds {
 
 type C = AlphaColour Float
 
-data Pattern img = None | Img img | Linear Float C C deriving (Eq, Show, Read)
+data Pattern img = None | Img img | Linear Float [C] deriving (Eq, Show, Read)
 
 -- We need to resolve images before we can compute the actual lengths!
 data Resize = Cover | Contain | Size Length Length deriving (Eq, Show, Read)


@@ 56,16 56,16 @@ instance PropertyParser (Backgrounds Text) where
         inner [Url ret] = Just $ Img ret
         inner [Function "url", String ret, RightParen] = Just $ Img ret
         inner (Function "linear-gradient":toks)
-            | Just [s, e] <- colourStops (Comma:toks) = Just $ Linear pi s e
+            | Just cs@(_:_:_) <- colourStops (Comma:toks) = Just $ Linear pi cs
         inner (Function "linear-gradient":Dimension _ x unit:toks)
-            | Just rad <- lookup unit [("deg", pi/180), ("grad", pi/200),
+            | Just s <- lookup unit [("deg", pi/180), ("grad", pi/200),
                     ("rad", 1), ("turn", 2*pi)],
-                Just [s, e] <- colourStops toks = Just $ Linear (f x*rad) s e
+                Just cs@(_:_:_) <- colourStops toks = Just $ Linear (f x*s) cs
         inner (Function "linear-gradient":Ident "to":Ident a:Ident b:toks)
-            | Just angle <- corner a b, Just [s, e] <- colourStops toks =
-                Just $ Linear angle s e
-            | Just angle <- corner b a, Just [s, e] <- colourStops toks =
-                Just $ Linear angle s e
+            | Just angle <- corner a b, Just stops@(_:_:_) <- colourStops toks =
+                Just $ Linear angle stops
+            | Just angle <- corner b a, Just stops@(_:_:_) <- colourStops toks =
+                Just $ Linear angle stops
           where
             corner "top" "right" = Just $ 0.25*pi
             corner "bottom" "right" = Just $ 0.75*pi


@@ 75,7 75,7 @@ instance PropertyParser (Backgrounds Text) where
         inner (Function "linear-gradient":Ident "to":Ident side:toks)
             | Just angle <- lookup side [
                 ("top", 0), ("right", pi/2), ("bottom", pi), ("left", pi*1.5)],
-                Just [s, e] <- colourStops toks = Just $ Linear angle s e
+                Just cs@(_:_:_) <- colourStops toks = Just $ Linear angle cs
         inner _ = Nothing
         colourStops [RightParen] = Just []
         colourStops (Comma:toks)

@@ 2,7 2,7 @@
 -- So getters can implement typeclasses
 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 module Graphics.Rendering.Rect.Types(Rect(..), size, Rects(..), BoxSelector,
-        Uniform, u, c, renderRectWith, liftGL) where
+        Uniform, u, c, cs, renderRectWith, liftGL) where
 
 import Linear (M44, V2(..), V4(..))
 import qualified Data.ByteString.Char8 as B8


@@ 12,7 12,8 @@ import qualified Data.Vector.Unboxed as UV
 import Typograffiti.GL
 import Graphics.GL.Core32
 import Graphics.GL.Types
-import Foreign.Marshal.Array (withArray)
+import Foreign.Marshal.Array (withArray, withArrayLen)
+import Foreign.Ptr (castPtr)
 
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad (forM)


@@ 75,11 76,19 @@ u :: (MonadIO m, UniformValue a) => a -> Uniform m
 u val prog slot = liftIO $ updateUniform prog slot val
 
 c :: MonadIO m => AlphaColour Float -> Uniform m
-c rgba = u $ V4 r g b a
+c rgba = u $ c' rgba
+c' :: AlphaColour Float -> V4 Float
+c' rgba = V4 r g b a
   where
     a = alphaChannel rgba
     -- Workaround for missing APIs in "colour" hackage.
     RGB r g b = toSRGB $ over rgba black
+cs :: MonadIO m => Int -> [AlphaColour Float] -> Uniform m
+cs mlen rgba prog slot = do
+    let val = map c' $ take mlen rgba
+    liftIO $ withArrayLen val $ \len ->
+        glUniform4fv slot (toEnum len) . castPtr
+    clearUniformUpdateError prog slot val
 
 renderRectWith :: (MonadIO m, MonadIO n) => ByteString -> [String] ->
         n ([Texture] -> [Uniform m] -> (a -> Rect) -> a -> M44 Float -> m ())