never executed always true always false
    1 {-|
    2 Module: Flaw.Graphics.Canvas
    3 Description: 2D painting.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE PatternSynonyms #-}
    8 
    9 module Flaw.Graphics.Canvas
   10   ( Canvas
   11   , initCanvas
   12   , drawBorderedRectangle
   13   , drawCubicBezierCurve
   14   ) where
   15 
   16 import qualified Data.ByteString.Unsafe as B
   17 import Data.Default
   18 import Foreign.Marshal.Array
   19 import Foreign.Ptr
   20 import Foreign.Storable
   21 
   22 import Flaw.Book
   23 import Flaw.Graphics
   24 import Flaw.Graphics.Blend
   25 import Flaw.Graphics.Program
   26 import Flaw.Math
   27 
   28 -- | Canvas contains additional things for 2D rendering.
   29 data Canvas d = Canvas
   30   {
   31   -- | Blend state for usual blending.
   32     canvasBlendState :: !(BlendStateId d)
   33   , canvasUs :: !(UniformStorage d)
   34   , canvasUX :: !(Node Float4)
   35   , canvasUY :: !(Node Float4)
   36   , canvasUFillColor :: !(Node Float4)
   37   , canvasUBorderColor :: !(Node Float4)
   38   , canvasUScaleParams :: !(Node Float4)
   39   , canvasVbBorderedRectangle :: !(VertexBufferId d)
   40   , canvasBorderedRectangleProgram :: !(ProgramId d)
   41   , canvasVbCubicBezierCurve :: !(VertexBufferId d)
   42   , canvasCubicBezierCurveProgram :: !(ProgramId d)
   43   }
   44 
   45 initCanvas :: Device d => d -> IO (Canvas d, IO ())
   46 initCanvas device = withSpecialBook $ \bk -> do
   47 
   48   -- create blend state for usual blending
   49   blendState <- book bk $ createBlendState device def
   50     { blendSourceColor = ColorSourceSrcAlpha
   51     , blendDestColor = ColorSourceInvSrcAlpha
   52     }
   53 
   54   ubs <- uniformBufferSlot 0
   55   -- uniform containing four X coordinates (from left to right)
   56   uX <- uniform ubs
   57   -- uniform containing four Y coordinates (from bottom to top)
   58   uY <- uniform ubs
   59   -- uniform with fill color
   60   uFillColor <- uniform ubs
   61   -- uniform with border color
   62   uBorderColor <- uniform ubs
   63   -- uniform with scale params
   64   let uScaleParams = uBorderColor -- same uniform
   65   us <- book bk $ createUniformStorage device ubs
   66 
   67   -- bordered rectangle
   68   vbBorderedRectangle <- do
   69     let
   70       vbStride = sizeOf (undefined :: Float) * 10
   71       vertices = do
   72         i <- [0..2] :: [Int] -- rows of quads from bottom to top
   73         j <- [0..2] :: [Int] -- columns of quads from left to right
   74         (x, y) <- [(1, 0), (0, 0), (0, 1), (1, 0), (0, 1), (1, 1)] -- 6 vertices per quad
   75         let
   76           r =
   77             [ if x + j == 0 then 1 else 0 -- x1
   78             , if x + j == 1 then 1 else 0 -- x2
   79             , if x + j == 2 then 1 else 0 -- x3
   80             , if x + j == 3 then 1 else 0 -- x4
   81             , if y + i == 0 then 1 else 0 -- y1
   82             , if y + i == 1 then 1 else 0 -- y2
   83             , if y + i == 2 then 1 else 0 -- y3
   84             , if y + i == 3 then 1 else 0 -- y4
   85             , if i == 1 && j == 1 then 1 else 0 -- use fill color?
   86             , if i == 1 && j == 1 then 0 else 1 -- use border color?
   87             ]
   88           in r
   89     book bk $ withArray (vertices :: [Float]) $ \ptr -> do
   90       bytes <- B.unsafePackCStringLen (castPtr ptr, vbStride * BORDERED_RECTANGLE_INDEX_COUNT)
   91       createStaticVertexBuffer device bytes vbStride
   92   borderedRectangleProgram <- book bk $ createProgram device $ do
   93     aX <- attribute 0 0 0 (AttributeVec4 AttributeFloat32)
   94     aY <- attribute 0 16 0 (AttributeVec4 AttributeFloat32)
   95     aC <- attribute 0 32 0 (AttributeVec2 AttributeFloat32)
   96     color <- temp (uFillColor * vecFromScalar (x_ aC) + uBorderColor * vecFromScalar (y_ aC))
   97     rasterize (cvec1111 (dot aX uX) (dot aY uY) (constf 0) (constf 1)) $ colorTarget 0 color
   98 
   99   -- cubic bezier curve
  100   vbCubicBezierCurve <- do
  101     let
  102       vbStride = sizeOf (undefined :: Float) * 8
  103       vertices = do
  104         i <- [0 .. (CUBIC_BEZIER_PIECES_COUNT - 1)]
  105         (l, k) <- [(1, -1), (0, -1), (0, 1), (1, -1), (0, 1), (1, 1)] -- 6 vertices per quad
  106         let
  107           t = fromIntegral (i + l) * (1 / fromIntegral CUBIC_BEZIER_PIECES_COUNT)
  108         let
  109           r =
  110             -- coefs for bezier point
  111             [ (1 - t) * (1 - t) * (1 - t)
  112             , (1 - t) * (1 - t) * t * 3
  113             , (1 - t) * t * t * 3
  114             , t * t * t
  115             -- coefs for bezier tangent (derivative)
  116             , ((-3) + t * 6 - t * t * 3) * k
  117             , (3 - t * 12 + t * t * 9) * k
  118             , (t * 6 - t * t * 9) * k
  119             , (t * t * 3) * k
  120             ]
  121           in r
  122     book bk $ withArray (vertices :: [Float]) $ \ptr -> do
  123       bytes <- B.unsafePackCStringLen (castPtr ptr, vbStride * CUBIC_BEZIER_INDEX_COUNT)
  124       createStaticVertexBuffer device bytes vbStride
  125   cubicBezierCurveProgram <- book bk $ createProgram device $ do
  126     aP <- attribute 0 0 0 (AttributeVec4 AttributeFloat32)
  127     aQ <- attribute 0 16 0 (AttributeVec4 AttributeFloat32)
  128     p <- temp $
  129       ( cvec11 (dot uX aP) (dot uY aP)
  130       + normalize (cvec11 (dot uY aQ) (-(dot uX aQ))) * zz__ uScaleParams
  131       ) * xy__ uScaleParams
  132     rasterize (cvec211 p 0 1) $ colorTarget 0 uFillColor
  133 
  134   return Canvas
  135     { canvasBlendState = blendState
  136     , canvasUs = us
  137     , canvasUX = uX
  138     , canvasUY = uY
  139     , canvasUFillColor = uFillColor
  140     , canvasUBorderColor = uBorderColor
  141     , canvasUScaleParams = uScaleParams
  142     , canvasVbBorderedRectangle = vbBorderedRectangle
  143     , canvasBorderedRectangleProgram = borderedRectangleProgram
  144     , canvasVbCubicBezierCurve = vbCubicBezierCurve
  145     , canvasCubicBezierCurveProgram = cubicBezierCurveProgram
  146     }
  147 
  148 -- | Draw bordered rectangle.
  149 -- Coordinates are integer pixels. Y directed down.
  150 drawBorderedRectangle :: Context c d => Canvas d -> Int4 -> Int4 -> Float4 -> Float4 -> Render c ()
  151 drawBorderedRectangle Canvas
  152   { canvasBlendState = blendState
  153   , canvasUs = us
  154   , canvasUX = uX
  155   , canvasUY = uY
  156   , canvasUFillColor = uFillColor
  157   , canvasUBorderColor = uBorderColor
  158   , canvasVbBorderedRectangle = vbBorderedRectangle
  159   , canvasBorderedRectangleProgram = borderedRectangleProgram
  160   } (Int4 x1 x2 x3 x4) (Int4 y1 y2 y3 y4) fillColor borderColor = renderScope $ do
  161 
  162   Vec4 viewportLeft viewportTop viewportRight viewportBottom <- renderGetViewport
  163   let
  164     scaleX = 2 / fromIntegral (viewportRight - viewportLeft)
  165     scaleY = 2 / fromIntegral (viewportTop - viewportBottom)
  166     xs = Float4
  167       (fromIntegral x1 * scaleX - 1)
  168       (fromIntegral x2 * scaleX - 1)
  169       (fromIntegral x3 * scaleX - 1)
  170       (fromIntegral x4 * scaleX - 1)
  171     ys = Float4 -- note reverse order of y's
  172       (fromIntegral y4 * scaleY + 1)
  173       (fromIntegral y3 * scaleY + 1)
  174       (fromIntegral y2 * scaleY + 1)
  175       (fromIntegral y1 * scaleY + 1)
  176 
  177   -- setup stuff
  178   renderVertexBuffer 0 vbBorderedRectangle
  179   renderIndexBuffer nullIndexBuffer
  180   renderUniformStorage us
  181   renderProgram borderedRectangleProgram
  182   -- enable blending only if needed
  183   renderBlendState $ if w_ fillColor >= 1 && w_ borderColor >= 1 then nullBlendState else blendState
  184 
  185   -- set uniforms
  186   renderUniform us uX xs
  187   renderUniform us uY ys
  188   renderUniform us uFillColor fillColor
  189   renderUniform us uBorderColor borderColor
  190   renderUploadUniformStorage us
  191 
  192   -- draw
  193   renderDraw BORDERED_RECTANGLE_INDEX_COUNT
  194 
  195 drawCubicBezierCurve :: Context c d => Canvas d -> Int4 -> Int4 -> Float4 -> Float -> Render c ()
  196 drawCubicBezierCurve Canvas
  197   { canvasBlendState = blendState
  198   , canvasUs = us
  199   , canvasUX = uX
  200   , canvasUY = uY
  201   , canvasUFillColor = uFillColor
  202   , canvasUScaleParams = uScaleParams
  203   , canvasVbCubicBezierCurve = vbCubicBezierCurve
  204   , canvasCubicBezierCurveProgram = cubicBezierCurveProgram
  205   } (Int4 x1 x2 x3 x4) (Int4 y1 y2 y3 y4) color thickness = renderScope $ do
  206 
  207   Vec4 viewportLeft viewportTop viewportRight viewportBottom <- renderGetViewport
  208   let
  209     viewportHalfWidth = fromIntegral (viewportRight - viewportLeft) * 0.5
  210     viewportHalfHeight = fromIntegral (viewportTop - viewportBottom) * 0.5
  211     scaleX = 1 / viewportHalfWidth
  212     scaleY = 1 / viewportHalfHeight
  213     xs = Float4
  214       (fromIntegral x1 - viewportHalfWidth)
  215       (fromIntegral x2 - viewportHalfWidth)
  216       (fromIntegral x3 - viewportHalfWidth)
  217       (fromIntegral x4 - viewportHalfWidth)
  218     ys = Float4
  219       (fromIntegral y1 + viewportHalfHeight)
  220       (fromIntegral y2 + viewportHalfHeight)
  221       (fromIntegral y3 + viewportHalfHeight)
  222       (fromIntegral y4 + viewportHalfHeight)
  223 
  224   -- setup stuff
  225   renderVertexBuffer 0 vbCubicBezierCurve
  226   renderIndexBuffer nullIndexBuffer
  227   renderUniformStorage us
  228   renderProgram cubicBezierCurveProgram
  229   -- enable blending only if needed
  230   renderBlendState $ if w_ color >= 1 then nullBlendState else blendState
  231 
  232   -- set uniforms
  233   renderUniform us uX xs
  234   renderUniform us uY ys
  235   renderUniform us uFillColor color
  236   renderUniform us uScaleParams (Vec4 scaleX scaleY thickness 0)
  237   renderUploadUniformStorage us
  238 
  239   -- draw
  240   renderDraw CUBIC_BEZIER_INDEX_COUNT
  241 
  242 
  243 pattern BORDERED_RECTANGLE_INDEX_COUNT :: Int
  244 pattern BORDERED_RECTANGLE_INDEX_COUNT = 54
  245 
  246 pattern CUBIC_BEZIER_PIECES_COUNT :: Int
  247 pattern CUBIC_BEZIER_PIECES_COUNT = 32
  248 pattern CUBIC_BEZIER_INDEX_COUNT :: Int
  249 pattern CUBIC_BEZIER_INDEX_COUNT = 192 -- CUBIC_BEZIER_PIECES_COUNT * 6