gelatin 0.0.0.3 → 0.1.0.0

raw patch · 34 files changed

+1597/−1948 lines, 34 filesdep +mtldep +transformersdep −FontyFruitydep −GLFW-bdep −JuicyPixelsdep ~basedep ~bytestringdep ~containersbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, transformers

Dependencies removed: FontyFruity, GLFW-b, JuicyPixels, async, directory, file-embed, gl, time

Dependency ranges changed: base, bytestring, containers, lens, linear, vector

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• app/Example.hs +17/−0
• docimages/demoteCubic.png binary
• gelatin.cabal +40/−105
• shaders/2d.frag +0/−16
• shaders/2d.vert +0/−18
• shaders/bezier.frag +0/−47
• shaders/bezier.vert +0/−22
• shaders/mask.frag +0/−13
• shaders/mask.vert +0/−15
• src/Example.hs +0/−30
• src/Gelatin.hs +27/−0
• src/Gelatin/Compiler.hs +237/−0
• src/Gelatin/Core.hs +46/−0
• src/Gelatin/Core/Bezier.hs +356/−0
• src/Gelatin/Core/Bounds.hs +63/−0
• src/Gelatin/Core/Color.hs +153/−152
• src/Gelatin/Core/Polyline.hs +95/−0
• src/Gelatin/Core/Rendering.hs +0/−642
• src/Gelatin/Core/Rendering/Font.hs +0/−112
• src/Gelatin/Core/Rendering/Geometrical.hs +0/−103
• src/Gelatin/Core/Rendering/Polylines.hs +0/−216
• src/Gelatin/Core/Rendering/Types.hs +0/−168
• src/Gelatin/Core/Shader.hs +0/−115
• src/Gelatin/Core/Stroke.hs +38/−0
• src/Gelatin/Core/Transform.hs +84/−0
• src/Gelatin/Core/Triangle.hs +38/−0
• src/Gelatin/Core/Triangulation/Common.hs +0/−61
• src/Gelatin/Core/Triangulation/EarClipping.hs +0/−35
• src/Gelatin/Core/Triangulation/KET.hs +0/−77
• src/Gelatin/Core/Utils.hs +23/−0
• src/Gelatin/Picture.hs +59/−0
• src/Gelatin/Picture/Internal.hs +279/−0
• src/Gelatin/Picture/Shapes.hs +41/−0

@@ -1,4 +1,4 @@-Copyright (c) 2015 Schell Scivally+Copyright (c) 2016 Schell Scivally  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the

@@ -0,0 +1,17 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+import           Gelatin+import           Linear++--------------------------------------------------------------------------------+-- Example+--------------------------------------------------------------------------------+picture :: Picture () (V2 Float, V4 Float) ()+picture = setGeometry $ fan $ do+  to (0, red)+  to (V2 100 0, green)+  to (100, blue)+  to (V2 0 100, white)++main :: IO ()+main = putStrLn "picture"

binary file changed (absent → 23597 bytes)

@@ -1,124 +1,59 @@--- Initial gelatin-core.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/---- The name of the package. name:                gelatin---- The package version.  See the Haskell package versioning policy (PVP)--- for standards guiding when and how versions should be incremented.--- http://www.haskell.org/haskellwiki/Package_versioning_policy--- PVP summary:      +-+------- breaking API changes---                   | | +----- non-breaking API additions---                   | | | +--- code changes with no API change-version:             0.0.0.3---- A short (one-line) description of the package.-synopsis:            An experimental real time renderer.---- A longer description of the package.-description:         gelatin is a very experimental real time rendering-                     engine for 2d graphics. It is backed by opengl 3.3.---- The license under which the package is released.+version:             0.1.0.0+synopsis:            A graphics description language.+description:         An EDSL for describing pictures and scenes.+homepage:            https://github.com/schell/gelatin license:             MIT---- The file containing the license text. license-file:        LICENSE---- The package author(s). author:              Schell Scivally---- An email address to which users can send suggestions, bug reports, and--- patches.-maintainer:          efsubenovex@gmail.com---- A copyright notice.--- copyright:-+maintainer:          schell@takt.com category:            Graphics- build-type:          Simple---- Extra files to be distributed with the package, such as examples or a--- README.-extra-source-files:    shaders/2d.frag,-                       shaders/2d.vert,-                       shaders/bezier.frag,-                       shaders/bezier.vert,-                       shaders/mask.frag,-                       shaders/mask.vert---- Constraint on the version of Cabal needed to build this package.-cabal-version:       >=1.10+extra-doc-files:     docimages/*.png+stability:           experimental -source-repository head-  type: git-  location: https://github.com/schell/gelatin+cabal-version:       >=1.18  library   ghc-options:         -Wall-  -- Modules exported by the library.-  exposed-modules:     Gelatin.Core.Rendering,-                       Gelatin.Core.Rendering.Font,-                       Gelatin.Core.Rendering.Types,-                       Gelatin.Core.Rendering.Geometrical,-                       Gelatin.Core.Rendering.Polylines,-                       Gelatin.Core.Shader,-                       Gelatin.Core.Color,-                       Gelatin.Core.Triangulation.Common,-                       Gelatin.Core.Triangulation.EarClipping,-                       Gelatin.Core.Triangulation.KET -  -- Modules included in this library but not exported.-  -- other-modules:--  -- LANGUAGE extensions used by modules in this package.-  other-extensions:    OverloadedStrings,-                       FlexibleContexts,-                       GeneralizedNewtypeDeriving,-                       TemplateHaskell+  exposed-modules:     Gelatin+                     , Gelatin.Compiler+                     , Gelatin.Core+                     , Gelatin.Core.Bezier+                     , Gelatin.Core.Bounds+                     , Gelatin.Core.Color+                     --, Gelatin.Core.Font+                     , Gelatin.Core.Polyline+                     , Gelatin.Core.Stroke+                     , Gelatin.Core.Transform+                     , Gelatin.Core.Triangle+                     , Gelatin.Core.Utils+                     , Gelatin.Picture+                     , Gelatin.Picture.Internal+                     , Gelatin.Picture.Shapes -  -- Other library packages from which modules are imported.-  build-depends:       base >=4.7 && < 5,-                       linear >=1.18,-                       gl >=0.7,-                       GLFW-b >= 1.4.7.2,-                       FontyFruity >=0.5,-                       JuicyPixels,-                       time >=1.4,-                       async >=2.0,-                       directory >=1.2,-                       containers >=0.5,-                       vector >=0.10,-                       lens,-                       file-embed >= 0.0.8.2,-                       bytestring+  build-depends:       base                  >=4.8 && <4.11+                     , linear                >=1.20 && <1.21+                     , containers            >=0.5 && <0.6+                     , vector                >=0.12 && <0.13+                     , mtl                   >=2.2 && <2.3+                     , transformers          >=0.4 && <0.6+                     , bytestring            >=0.10 && <0.11+                     , lens                  >=4.14 && <4.16 -  -- Directories containing source files.   hs-source-dirs:      src--  -- Base language which the package is written in.   default-language:    Haskell2010  executable example-  buildable:           True-  ghc-prof-options:    -Wall-  hs-source-dirs:      src-  main-is:             Example.hs-  build-depends:       base >=4.6 && <5.0,-                       gelatin -any,-                       linear >=1.18,-                       gl >=0.7,-                       GLFW-b >= 1.4.7.2,-                       FontyFruity >=0.5,-                       JuicyPixels,-                       time >=1.4,-                       async >=2.0,-                       directory >=1.2,-                       containers >=0.5,-                       vector >=0.10,-                       lens,-                       file-embed >= 0.0.8.2,-                       bytestring+  ghc-options:         -Wall +  build-depends:       base                  >=4.8 && <4.11+                     , gelatin+                     , linear                >=1.20 && <1.21+                     , vector                >=0.12 && <0.13+                     , mtl                   >=2.2 && <2.3++  hs-source-dirs:      app+  main-is:             Example.hs   default-language:    Haskell2010

@@ -1,16 +0,0 @@-#version 330 core-in vec4 fcolor;-in vec2 fuv;-out vec4 fragColor;--uniform bool hasUV;-uniform sampler2D sampler;---void main() {-    if (hasUV) {-        fragColor = texture(sampler, fuv.st);-    } else {-        fragColor = fcolor;-    }-}

@@ -1,18 +0,0 @@-#version 330 core-layout(location = 0) in vec2 position;-layout(location = 1) in vec4 color;-layout(location = 2) in vec2 uv;--uniform mat4 projection;-uniform mat4 modelview;-uniform bool hasUV;-uniform sampler2D sampler;--out vec4 fcolor;-out vec2 fuv;--void main() {-    fcolor = color;-    fuv = uv;-    gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);-}

@@ -1,47 +0,0 @@-// Loop-Blinn curve rendering--#version 330 core-in vec3 fbez;-in vec4 fcolor;-in vec2 fuv;-out vec4 fragColor;--uniform bool hasUV;-uniform sampler2D sampler;--void main() {-    vec2 p = fbez.xy;-    // When cw is true, winding is clockwise and we're drawing outside the-    // curve.-    bool cw = bool(fbez.z);-    // Gradients-    vec2 px = dFdx(p);-    vec2 py = dFdy(p);-    // Chain rule-    float fx = (2*p.x)*px.x - px.y;-    float fy = (2*p.x)*py.x - py.y;-    // Signed distance-    float sd = (p.x*p.x - p.y) / sqrt(fx*fx + fy*fy);-    //Linear alpha-    float alpha = 0.5 - sd;-    alpha = cw ? 1 - alpha : alpha;-    // Find the resulting fragment color-    float a = 0;--    if (alpha > 1) {-        a = 1;-    } else if (alpha < 0) {-        discard;-    } else {-        // We are right on the boundary, interpolate the color intensity.-        a = alpha;-    }--    vec4 color = vec4(0);-    if (hasUV) {-        color = texture(sampler, fuv.st);-    } else {-        color = fcolor;-    }-    fragColor = vec4(color.rgb, color.a * a);-}

@@ -1,22 +0,0 @@-// Loop-Blinn curve rendering--#version 330 core--layout(location = 0) in vec2 position;-layout(location = 1) in vec4 color;-layout(location = 2) in vec2 uv;-layout(location = 3) in vec3 bez;--uniform mat4 projection;-uniform mat4 modelview;--out vec3 fbez;-out vec4 fcolor;-out vec2 fuv;--void main() {-    fbez = bez;-    fuv = uv;-    fcolor = color;-    gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);-}

@@ -1,13 +0,0 @@-#version 330 core-uniform sampler2D mainTex;-uniform sampler2D maskTex;--in vec2 fuv;--out vec4 fragColor;--void main() {-    vec4 color = texture(mainTex, fuv.st);-    vec4 mask  = texture(maskTex, fuv.st);-    fragColor = vec4(color.rgb, color.a * mask.a);-}

@@ -1,15 +0,0 @@-#version 330 core-layout(location = 0) in vec2 position;-layout(location = 2) in vec2 uv;--uniform mat4 projection;-uniform mat4 modelview;-uniform sampler2D mainTex;-uniform sampler2D maskTex;--out vec2 fuv;--void main() {-    fuv = uv;-    gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);-}

@@ -1,30 +0,0 @@-module Main where--import System.Environment-import Gelatin.Core.Rendering-import Graphics.UI.GLFW-import Examples.PolylineTest-import Examples.PolylineWinding-import Examples.Masking-import Examples.Text-import Examples.ClipTexture--examples :: [(String, Window -> GeomRenderSource -> BezRenderSource -> IO ())]-examples = [("polylineTest", polylineTest)-           ,("polylineWinding", polylineWinding)-           ,("masking", masking)-           ,("text", text)-           ,("clipTexture", clippingTexture)-           ]--main :: IO ()-main = do-    name:_ <- getArgs-    True   <- initGelatin-    win    <- newWindow 800 600 "Syndeca Mapper" Nothing Nothing-    grs    <- loadGeomRenderSource-    brs    <- loadBezRenderSource--    let Just example = lookup name examples--    example win grs brs

@@ -0,0 +1,27 @@+-- |+-- Module:     Gelatin+-- Copyright:  (c) 2017 Schell Scivally+-- License:    MIT+-- Maintainer: Schell Scivally <schell@takt.com>+--+-- [@Core@]+-- Core types and pure functions.+--+-- [@Picture@]+-- Creating pictures.+--+-- [@Compiler@]+-- Shared types for writing backends and compiling pictures.+--+module Gelatin+  ( -- * Re-exports+    module Gelatin.Core+  , module Gelatin.Picture+  , module Gelatin.Compiler+  , module Linear+  ) where++import Gelatin.Core+import Gelatin.Picture+import Gelatin.Compiler+import Linear hiding (rotate)

@@ -0,0 +1,237 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Gelatin.Compiler where++import qualified Data.Vector as B+import           Data.Vector.Unboxed (Vector)+import           Data.Functor.Identity+import           Data.Foldable (foldl')+import           Linear (V4(..), V2(..), M44, identity, (!*!))+import           Control.Monad.IO.Class++import           Gelatin.Core+import           Gelatin.Picture.Internal+--------------------------------------------------------------------------------+-- Compilation results in a Renderer+--------------------------------------------------------------------------------+data RenderTransform v r s = Spatial (Affine v r)+                           | Special s++extractSpatial :: [RenderTransform v r s] -> [Affine v r]+extractSpatial = concatMap f+  where f (Spatial x) = [x]+        f _ = []++type Renderer v r s = (IO (), [RenderTransform v r s] -> IO ())+--------------------------------------------------------------------------------+-- Renderers can be transformed with many things, but here are some concrete+-- examples.+--------------------------------------------------------------------------------+data Raster = Alpha Float+            | Multiply (V4 Float)+            | ColorReplacement (V4 Float)+            deriving (Show, Eq)++type RenderTransform2 = RenderTransform (V2 Float) Float Raster+type Renderer2        = Renderer        (V2 Float) Float Raster+--------------------------------------------------------------------------------+-- Transformation Helpers+--------------------------------------------------------------------------------+unwrapTransforms :: [RenderTransform2]+                 -> (M44 Float, Float, V4 Float, Maybe (V4 Float))+unwrapTransforms = foldl' f (identity, 1, white, Nothing)+  where f (mv, alph, mlt, rep) (Spatial a) =+          (mv !*! affine2Modelview a, alph, mlt, rep)+        f (mv, alph, mlt, rep) (Special (Alpha a)) =+          (mv, alph * a, mlt, rep)+        f (mv, alph, mlt, rep) (Special (Multiply a)) =+          (mv, alph, mlt * a, rep)+        f (mv, alph, mlt, _) (Special (ColorReplacement a)) =+          (mv, alph, mlt, Just a)+--------------------------------------------------------------------------------+-- Conveniences for creating transformations+--------------------------------------------------------------------------------+move :: Float -> Float -> RenderTransform2+move x y = Spatial $ Translate $ V2 x y++moveV2 :: V2 Float -> RenderTransform2+moveV2 (V2 x y) = move x y++scale :: Float -> Float -> RenderTransform2+scale x y = Spatial $ Scale $ V2 x y++scaleV2 :: V2 Float -> RenderTransform2+scaleV2 (V2 x y) = scale x y++rotate :: Float -> RenderTransform2+rotate = Spatial . Rotate++alpha :: Float -> RenderTransform2+alpha = Special . Alpha++multiply :: Float -> Float -> Float -> Float -> RenderTransform2+multiply r g b a = Special $ Multiply $ V4 r g b a++multiplyV4 :: V4 Float -> RenderTransform2+multiplyV4 (V4 r g b a) = multiply r g b a++redChannelReplacement :: Float -> Float -> Float -> Float -> RenderTransform2+redChannelReplacement r g b a = Special $ ColorReplacement $ V4 r g b a++redChannelReplacementV4 :: V4 Float -> RenderTransform2+redChannelReplacementV4 (V4 r g b a) = redChannelReplacement r g b a+--------------------------------------------------------------------------------+-- Making compiling easier through types+--------------------------------------------------------------------------------+data VertexType = VertexTriangles+                | VertexBeziers+                | VertexStrip+                | VertexFan+                deriving (Show, Eq)++data GeometryCompiler vx v r s = GeometryCompiler+  { compileShapes :: VertexType -> Vector vx -> IO (Renderer v r s)+  , compileLine   :: Stroke     -> Vector vx -> IO (Renderer v r s)+  }++type MakeCompiler z vx v r s = z -> GeometryCompiler vx v r s+--------------------------------------------------------------------------------+-- Specifying the backend+--------------------------------------------------------------------------------+data BackendOps tex event = BackendOps+  { backendOpGetFramebufferSize :: IO (V2 Int)+  , backendOpGetWindowSize      :: IO (V2 Int)+  , backendOpClearWindow        :: IO ()+  , backendOpUpdateWindow       :: IO ()+  , backendOpSetClearColor      :: V4 Float -> IO ()+  , backendOpAllocTexture       :: FilePath -> IO (Maybe (tex, V2 Int))+  , backendOpBindTextures       :: [tex] -> IO () -> IO ()+  , backendOpGetEvents          :: IO [event]+  }+data BackendCompiler vert spatial rot rast = BackendComp+  { backendCompApplyOption :: Renderer spatial rot rast -> RenderingOption+                           -> Renderer spatial rot rast+  , backendCompCompiler    :: GeometryCompiler vert spatial rot rast+  }+data Backend tex event vert spatial rot rast = Backend+  { backendOps      :: BackendOps tex event+  , backendCompiler :: BackendCompiler vert spatial rot rast+  }++compiler :: Backend tex event vert spatial rot rast+         -> GeometryCompiler vert spatial rot rast+compiler = backendCompCompiler . backendCompiler++applyCompilerOption :: Backend tex event vert spatial rot rast+                    -> Renderer spatial rot rast+                    -> RenderingOption+                    -> Renderer spatial rot rast+applyCompilerOption b = backendCompApplyOption $ backendCompiler b++bindTextures :: Backend tex event vert spatial rot rast -> [tex] -> IO () -> IO ()+bindTextures b = backendOpBindTextures $ backendOps b++allocTexture :: Backend tex event vert spatial rot rast -> FilePath+                   -> IO (Maybe (tex, V2 Int))+allocTexture b = backendOpAllocTexture $ backendOps b++clearWindow :: Backend tex event vert spatial rot rast -> IO ()+clearWindow = backendOpClearWindow . backendOps++updateWindow :: Backend tex event vert spatial rot rast -> IO ()+updateWindow = backendOpUpdateWindow . backendOps++getEvents :: Backend tex event vert spatial rot rast -> IO [event]+getEvents = backendOpGetEvents . backendOps+--------------------------------------------------------------------------------+-- Compiling Concrete Picture Types+--------------------------------------------------------------------------------+compilePictureT :: MonadIO m+                => Backend tex event vert spatial rot rast+                -> PictureT tex vert m a+                -> m (a, Renderer spatial rot rast)+compilePictureT b pic = do+  (a, dat) <- runPictureT pic+  glr      <- compilePictureData b dat+  return (a, glr)++compilePicture :: MonadIO m+               => Backend tex event vert spatial rot rast+               -> Picture tex vert a+               -> m (a, Renderer spatial rot rast)+compilePicture b pic = do+  let (a, dat) = runIdentity $ runPictureT pic+  glr <- compilePictureData b dat+  return (a, glr)++--extractTransformData :: PictureData t (V2 Float) Float v -> [RenderTransform]+--extractTransformData PictureData{..} =+--  let afs = map Spatial _picDataAffine+--      ts  = Alpha _picDataAlpha : Multiply _picDataMultiply : afs+--  in case _picDataReplaceColor of+--       Nothing -> ts+--       Just c  -> ColorReplacement c : ts+--+compileGeometry :: GeometryCompiler vx v r s -> [StrokeAttr] -> RawGeometry vx+                -> IO (Renderer v r s)+compileGeometry GeometryCompiler{..} _ (RawTriangles v) =+  compileShapes VertexTriangles v+compileGeometry GeometryCompiler{..} _ (RawBeziers v) =+  compileShapes VertexBeziers v+compileGeometry GeometryCompiler{..} _ (RawTriangleStrip v) =+  compileShapes VertexStrip v+compileGeometry GeometryCompiler{..} _ (RawTriangleFan v) =+  compileShapes VertexFan v+compileGeometry GeometryCompiler{..} ss (RawLine v) =+  compileLine (strokeWith ss) v++compilePictureData :: MonadIO m+                   => Backend tex event vert spatial rot rast+                   -> PictureData tex vert+                   -> m (Renderer spatial rot rast)+compilePictureData b PictureData{..} = do+  let compile = liftIO . compileGeometry (compiler b) _picDataStroke+  glrs <- B.mapM compile _picDataGeometry+  let render rs = bindTextures b _picDataTextures $ mapM_ (($ rs) . snd) glrs+      clean = mapM_ fst glrs+      glr   = foldl (applyCompilerOption b) (clean, render) _picDataOptions+  return glr++--compileColorPictureData :: Rez -> ColorPictureData -> IO Renderer+--compileColorPictureData = compilePictureData rgbaCompiler+--+--compileTexturePictureData :: Rez -> TexturePictureData -> IO Renderer+--compileTexturePictureData = compilePictureData uvCompiler+----------------------------------------------------------------------------------+---- Top level compilation functions+----------------------------------------------------------------------------------+--compileColorPictureT :: MonadIO m => Rez -> ColorPictureT m a -> m (a, Renderer)+--compileColorPictureT rz pic = do+--  (a, dat) <- runPictureT pic+--  glr <- liftIO $ compileColorPictureData rz dat+--  return (a,glr)+--+--compileTexturePictureT :: MonadIO m => Rez -> TexturePictureT m a -> m (a, Renderer)+--compileTexturePictureT rz pic = do+--  (a, dat) <- runPictureT pic+--  glr <- liftIO $ compileTexturePictureData rz dat+--  return (a,glr)+--+--compileColorPicture :: MonadIO m => Rez -> ColorPicture a -> m (a, Renderer)+--compileColorPicture rz pic = do+--  let (a, dat) = runPicture pic+--  glr <- liftIO $ compileColorPictureData rz dat+--  return (a,glr)+--+--compileTexturePicture :: MonadIO m => Rez -> TexturePicture a -> m (a, Renderer)+--compileTexturePicture rz pic = do+--  let (a, dat) = runPicture pic+--  glr <- liftIO $ compileTexturePictureData rz dat+--  return (a,glr)+--------------------------------------------------------------------------------+-- Specifying a proper backend.+--------------------------------------------------------------------------------+

@@ -0,0 +1,46 @@+-- | In this module you'll find the types and functions used throughout gelatin.+--+-- [@Bezier@]+-- Inner and outer beziers.+--+-- [@Bounds@]+-- Working with bounding boxes.+--+-- [@Color@]+-- All the nifty named css colors.+--+-- [@Polyline@]+-- Creating smooth, anti-aliased lines with end caps.+--+-- [@Stroke@]+-- Helpers for stroking polylines.+--+-- [@Transform@]+-- Affine transformations (and more).+--+-- [@Triangle@]+-- Most likely not used - contains triangles.+--+-- [@Utils@]+-- Various utilities.+module Gelatin.Core (+    module Gelatin.Core.Bezier+  , module Gelatin.Core.Bounds+  , module Gelatin.Core.Color+--  , module Gelatin.Core.Font+  , module Gelatin.Core.Polyline+  , module Gelatin.Core.Utils+  , module Gelatin.Core.Stroke+  , module Gelatin.Core.Transform+  , module Gelatin.Core.Triangle+) where++import Gelatin.Core.Bezier+import Gelatin.Core.Bounds+import Gelatin.Core.Color+--import Gelatin.Core.Font+import Gelatin.Core.Polyline+import Gelatin.Core.Utils+import Gelatin.Core.Stroke+import Gelatin.Core.Transform+import Gelatin.Core.Triangle

@@ -0,0 +1,356 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Here is a simple bezier algebra.+-- To better server drawing beziers the 'Bezier' type's first+-- record is a boolean representing its fill direction (inner or outer).+module Gelatin.Core.Bezier (+  -- * Types+  Bezier,+  QuadraticBezier,+  CubicBezier,+  -- * Smart Constructors+  bezier,+  bez3,+  bez4,+  -- * Special helpers+  fmapBezier,+  fmapQuadraticBezier,+  fmapCubicBezier,+  transformBezier,+  transformQuadraticBezier,+  transformCubicBezier,+  triangleArea,+  -- * Conversion+  bezToBez3,+  bez3ToBez,+  bez3ToBezInner,+  bez3ToBezOuter,+  bez4ToBez,+  bez4ToBezInner,+  bez4ToBezOuter,+  bez4sToPath,+  flipBez4,+  demoteCubic,+  -- * Subdivision+  deCasteljau,+  subdivideAdaptive,+  subdivideAdaptive3,+  subdivideAdaptive4,+  cleanSeqDupes,+  -- * Shapes+  arcBez4,+  arcBez3,+  ellipseBez4,+  ellipseBez3,+  cornerBez4,+  cornerBez3+) where++import           Gelatin.Core.Transform+import           Linear+import qualified Data.Vector.Unboxed as V+import           Data.Vector.Unboxed (Vector, Unbox)++-- | A bezier that fills internally or externally.+type Bezier a = (Bool, a, a, a)++-- | A simple quadratic bezier with no explicit fill direction.+type QuadraticBezier a = (a, a, a)++-- | A simple cubic bezier with no explicit fill direction.+type CubicBezier a = (a, a, a, a)++fmapBezier :: (a -> b) -> Bezier a -> Bezier b+fmapBezier f (o, a, b, c) = (o, f a, f b, f c)++fmapQuadraticBezier :: (a -> b) -> QuadraticBezier a -> QuadraticBezier b+fmapQuadraticBezier f (a, b, c) = (f a, f b, f c)++fmapCubicBezier :: (a -> b) -> CubicBezier a -> CubicBezier b+fmapCubicBezier f (a, b, c, d) = (f a, f b, f c, f d)++transformBezier :: Num a => M44 a -> Bezier (V2 a) -> Bezier (V2 a)+transformBezier = fmapBezier . transformV2++transformQuadraticBezier :: Num a => M44 a -> QuadraticBezier (V2 a)+                         -> QuadraticBezier (V2 a)+transformQuadraticBezier = fmapQuadraticBezier . transformV2++transformCubicBezier :: Num a => M44 a -> CubicBezier (V2 a)+                     -> CubicBezier (V2 a)+transformCubicBezier = fmapCubicBezier . transformV2++-- | Create a bezier primitive. The area of the triangle formed by the+-- bezier's three points will be used to determine the orientation.+bezier :: (Ord a, Fractional a) => V2 a -> V2 a -> V2 a -> Bezier (V2 a)+bezier a b c = (triangleArea a b c > 0, a, b, c)++triangleArea :: Num a => V2 a -> V2 a -> V2 a -> a+triangleArea (V2 x2 y2) (V2 x0 y0) (V2 x1 y1) =+        (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)++--bezToPath :: (RealFloat a, Unbox a) => Bezier (V2 a) -> Path (V2 a)+--bezToPath = Path . subdivideAdaptive 100 0 . bezToBez3++-- | Create a quadratic bezier. This is an alias of 'QuadraticBezier'.+bez3 :: V2 a -> V2 a -> V2 a -> QuadraticBezier (V2 a)+bez3 = (,,)++-- | Convert a Bezier to a QuadraticBezier.+bezToBez3 :: Bezier a -> QuadraticBezier a+bezToBez3 (_,a,b,c) = (a,b,c)++-- | Create a cubic bezier. This is an alias of 'CubicBezier'.+bez4 :: V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier (V2 a)+bez4 = (,,,)++flipBez4 :: CubicBezier a -> CubicBezier a+flipBez4 (a,b,c,d) = (d,c,b,a)++-- | Convert a quadratic bezier into a bezier primitive and derives the winding+-- (which determines drawing an inner or outer bez) from the order of control+-- points.+bez3ToBez :: (Ord a, Fractional a, Unbox a)+          => QuadraticBezier (V2 a) -> Bezier (V2 a)+bez3ToBez (a,b,c) = bezier a b c++-- | Convert a quadratic bezier into a bezier primitive that fills outer.+bez3ToBezOuter :: (Ord a, Fractional a, Unbox a)+               => QuadraticBezier (V2 a) -> Bezier (V2 a)+bez3ToBezOuter qbz =+    case bez3ToBez qbz of+        z@(True,_,_,_) -> z+        (_,a,b,c) -> bezier c b a++-- | Convert a quadratic bezier into a bezier primitive that fills inner.+bez3ToBezInner :: (Ord a, Fractional a, Unbox a)+               => QuadraticBezier (V2 a) -> Bezier (V2 a)+bez3ToBezInner qbz =+    case bez3ToBez qbz of+        (True,a,b,c) -> bezier c b a+        b -> b++-- | Convert a cubic bezier into a list of drawable bezier primitives.+bez4ToBez :: (Ord a, Fractional a, Unbox a)+          => CubicBezier (V2 a) -> Vector (Bezier (V2 a))+bez4ToBez = V.map bez3ToBez . demoteCubic++-- | Convert a cubic bezier into a list of drawable bezier primitives that+-- fill the inner bezier.+bez4ToBezInner :: (Ord a, Fractional a, Unbox a)+               => CubicBezier (V2 a) -> Vector (Bezier (V2 a))+bez4ToBezInner = V.map bez3ToBezInner . demoteCubic++-- | Convert a cubic bezier into a list of drawable bezier primitives that+-- fill the inner bezier.+bez4ToBezOuter :: (Ord a, Fractional a, Unbox a)+               => CubicBezier (V2 a) -> Vector (Bezier (V2 a))+bez4ToBezOuter = V.map bez3ToBezOuter . demoteCubic++-- | Convert a list of cubic beziers into a smooth path.+bez4sToPath :: (RealFloat a, Unbox a)+            => a -> a -> Vector (CubicBezier (V2 a)) -> Vector (V2 a)+bez4sToPath mScale mAngle =+  cleanSeqDupes . V.concatMap (subdivideAdaptive4 mScale mAngle)++-- | Compute the point at `t` along an N-bezier curve.+deCasteljau :: (Additive f, R1 f, R2 f, Num a) => a -> [f a] -> f a+deCasteljau _ [b] = b+deCasteljau t coefs = deCasteljau t reduced+  where reduced = zipWith (flip (lerp t)) coefs (Prelude.tail coefs)++curveCollinearityEpsilon :: Double+curveCollinearityEpsilon = 1e-30++curveAngleToleranceEpsilon :: Double+curveAngleToleranceEpsilon = 0.01++curveRecursionLimit :: Int+curveRecursionLimit = 32++-- | Approximate a cubic bezier with a list of four quadratic beziers.+--+-- <<docimages/demoteCubic.png>>+demoteCubic :: (Fractional a, Unbox a)+            => CubicBezier (V2 a) -> Vector (QuadraticBezier (V2 a))+demoteCubic (a,b,c,d) = V.fromList [q1,q2,q3,q4]+    where mid = lerp 0.5+          m1 = mid a b+          m2 = mid b c+          m3 = mid c d+          m1m2 = mid m1 m2+          m2m3 = mid m2 m3+          mam1 = mid a m1+          h1 = mid mam1 m1+          p2 = mid m1m2 m2m3+          m1m2p2 = mid m1m2 p2+          h2 = mid m1m2 m1m2p2+          mp2m2m3 = mid p2 m2m3+          h3 = mid mp2m2m3 m2m3+          mdm3 = mid d m3+          h4 = mid mdm3 m3+          p1 = mid h1 h2+          --p2 = mid h2 h3+          p3 = mid h3 h4+          q1 = bez3 a h1 p1+          q2 = bez3 p1 h2 p2+          q3 = bez3 p2 h3 p3+          q4 = bez3 p3 h4 d++-- | Adaptively subdivide the quadratic bezier into a series of points (line+-- segments).+-- i.e. Generate more points along the part of the curve with greater curvature.+-- @see http://www.antigrain.com/research/adaptive_bezier/index.html+-- and http://www.antigrain.com/__code/src/agg_curves.cpp.html+subdivideAdaptive,subdivideAdaptive3 :: (RealFloat a, Unbox a)+                                     => a -> a -> QuadraticBezier (V2 a)+                                     -> Vector (V2 a)+subdivideAdaptive3 = subdivideAdaptive+subdivideAdaptive mScale mAngle (va,vb,vc) =+    let mDistanceToleranceSquare = (0.5 / mScale) ** 2+        vs = subdivide mDistanceToleranceSquare mAngle 0 va vb vc+    in va `V.cons` vs V.++ V.singleton vc++-- | Adaptively subdivide the cubic bezier into a series of points (line+-- segments).+subdivideAdaptive4 :: (RealFloat a, Unbox a)+                   => a -> a -> CubicBezier (V2 a) -> Vector (V2 a)+subdivideAdaptive4 s a = cleanSeqDupes . V.concatMap (subdivideAdaptive s a) . demoteCubic++-- | Removes sequential duplicates from a vector.+cleanSeqDupes :: (Eq a, Unbox a) => Vector a -> Vector a+cleanSeqDupes vs+  | V.length vs > 1 = vs1 `V.snoc` V.last vs+  | otherwise = vs+  where vs1 = V.map fst $ V.filter (uncurry (/=)) $ V.zip vs (V.drop 1 vs)++subdivide :: (RealFloat a, Unbox a)+          => a -> a -> Int -> V2 a -> V2 a -> V2 a -> Vector (V2 a)+subdivide mDistanceToleranceSquare mAngleTolerance level+          v1@(V2 x1 y1) v2@(V2 x2 y2) v3@(V2 x3 y3)+    | level > curveRecursionLimit = V.empty+    | otherwise =+            -- calculate the midpoints of the line segments+        let v12 = (v1 + v2) / 2+            v23 = (v2 + v3) / 2+            v123= (v12 + v23) / 2+            V2 dx dy = v3 - v1+            d = abs $ (x2 - x3) * dy - (y2 - y3) * dx+            subdivideFurther = subdivide mDistanceToleranceSquare+                                         mAngleTolerance+                                         (level + 1)+                                         v1 v12 v123+                               V.+++                               subdivide mDistanceToleranceSquare+                                         mAngleTolerance+                                         (level + 1)+                                         v123 v23 v3+        in if d > realToFrac curveCollinearityEpsilon+           then -- test regular case+               if (d * d) <= (mDistanceToleranceSquare * (dx*dx + dy*dy))+               then -- if the curvature is within our distance tolerance then+                    -- we're done subdividing+                    if mAngleTolerance < realToFrac curveAngleToleranceEpsilon+                    then V.singleton v123+                    else -- test angle and cusp condition+                         let preDA = abs (atan2 (y3 - y2) (x3 - x2) -+                                     atan2 (y2 - y1) (x2 - x1))+                             da = if preDA >= pi then 2*pi - preDA else preDA+                         in if da < mAngleTolerance+                            then V.singleton v123+                            else subdivideFurther+               else subdivideFurther+           else -- test collinear case+                let da = dx*dx + dy*dy+                    f a b = if quadrance (a - b) < mDistanceToleranceSquare+                            then V.singleton v2+                            else subdivideFurther+                in if da == 0+                   then f v1 v2+                   else let d' = ((x2 - x1) * dx + (y2 - y1) * dy) / da+                        in if d' > 0 && d' < 1+                           then -- this is the simple collinear case, 1-2-3+                                V.empty+                           else f v2 $ if d' <= 0+                                then v1+                                else if d' >= 1+                                     then v3+                                     else V2 (x1 + d'*dx) (y1 + d'*dy)+--------------------------------------------------------------------------------+-- Shapes with beziers+--------------------------------------------------------------------------------+kappa :: Fractional a => a+kappa = 0.5522847498307936++cornerBez4 :: RealFloat a => a -> a -> CubicBezier (V2 a)+cornerBez4 xr yr = bez4 (V2 0 yr) (V2 0 y) (V2 x 0) (V2 xr 0)+    where x = xr * kappa+          y = yr * kappa++cornerBez3 :: (RealFloat a, Unbox a)+           => a -> a -> Vector (QuadraticBezier (V2 a))+cornerBez3 xr yr = demoteCubic $ cornerBez4 xr yr++-- | Generate a cubic Bezier representing an arc on the unit circle of total+-- angle `size` radians, beginning `start` radians above the x-axis. Up to four+-- of these curves are combined to make a full arc.+-- See www.joecridge.me/bezier.pdf for an explanation of the method.+acuteArc :: RealFloat a => a -> a -> CubicBezier (V2 a)+acuteArc start size = bez4 a b c d+    where [a,b,c,d] = [V2 ax ay, V2 bx by, V2 cx cy, V2 dx dy]+          ax = cos start+          ay = sin start+          bx = lambda * cosPhi + mu * sinPhi+          by = lambda * sinPhi - mu * cosPhi+          cx = lambda * cosPhi - mu * sinPhi+          cy = lambda * sinPhi + mu * cosPhi+          dx = cos (start + size)+          dy = sin (start + size)+          alpha = size / 2+          cosAlpha = cos alpha+          sinAlpha = sin alpha+          cotAlpha = 1 / tan alpha+          phi = start + alpha+          cosPhi = cos phi+          sinPhi = sin phi+          lambda = (4 - cosAlpha) / 3+          mu = sinAlpha + (cosAlpha - lambda) * cotAlpha++curveEpsilon :: Fractional a => a+curveEpsilon = 0.00001++-- | Create a list of cubic beziers representing an arc along an ellipse with+-- width `w`, height `h` and total angle `stop - start` radians, beginning+-- `start` radians above the x-axis.+arcBez4,arc' :: (Epsilon a, RealFloat a)+             => a -> a -> a -> a -> [CubicBezier (V2 a)]+arcBez4 w h start stop = if stop - start >= 2*pi+                     then close $ arc' w h start (start + 2*pi)+                     else arc' w h start stop+        -- This is a full arc so make sure the first and last points are equal+  where close [c1@(d,_,_,_) ,c2,c3,(a,b,c,_)] =+            [c1,c2,c3,(a,b,c,d)]+        close cs = cs++arc' w h start stop+    | (stop - start) > curveEpsilon = a : arcBez4 w h (start + arcToDraw) stop+    | otherwise = []+        where arcToDraw = min (stop - start) (pi/2)+              mv = affine2Modelview $ Scale (realToFrac <$> V2 w h)+              a = transformCubicBezier mv $ acuteArc start arcToDraw++arcBez3 :: (Epsilon a, RealFloat a, Unbox a)+        => a -> a -> a -> a -> Vector (QuadraticBezier (V2 a))+arcBez3 w h start stop = V.concat $ map demoteCubic $ arcBez4 w h start stop++-- | Create a list of cubic beziers that represent an entire closed+-- ellipse.+ellipseBez4 :: (Epsilon a, RealFloat a) => a -> a -> [CubicBezier (V2 a)]+ellipseBez4 xr yr = arcBez4 xr yr 0 (2*pi)++ellipseBez3 :: (Epsilon a, RealFloat a, Unbox a)+            => a -> a -> Vector (QuadraticBezier (V2 a))+ellipseBez3 xr yr = V.concat $ map demoteCubic $ ellipseBez4 xr yr

@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+module Gelatin.Core.Bounds where++import           Control.Arrow          (Arrow, first, second, (>>>))+import           Data.Vector.Unboxed    (Unbox, Vector)+import qualified Data.Vector.Unboxed    as V+import           Gelatin.Core.Transform+import           Linear++type BBox = (V2 Float, V2 Float)++type BCube = (V3 Float, V3 Float)++--------------------------------------------------------------------------------+-- 3d+--------------------------------------------------------------------------------+boundingCube :: (Unbox a, Real a) => Vector (V3 a) -> BCube+boundingCube vs+  | V.null vs = (0,0)+  | otherwise = V.foldl' f (br,tl) vs+  where mn a = min a . realToFrac+        mx a = max a . realToFrac+        f (a, b) c = (mn <$> a <*> c, mx <$> b <*> c)+        inf = 1/0+        ninf = (-1)/0+        tl = V3 ninf ninf ninf+        br = V3 inf inf inf++listToCube :: [V3 Float] -> BCube+listToCube = boundingCube . V.fromList++foldIntoCube :: Vector BCube -> BCube+foldIntoCube = boundingCube . uncurry (V.++) . V.unzip++pointInCube :: V2 Float -> BBox -> Bool+pointInCube (V2 px py) (V2 minx miny, V2 maxx maxy) =+  (px >= minx && px <= maxx) && (py >= miny && py <= maxy)++applyTfrmToCube :: M44 Float -> BBox -> BBox+applyTfrmToCube t (tl,br) = listToBox [transformV2 t tl, transformV2 t br]+--------------------------------------------------------------------------------+-- 2d+--------------------------------------------------------------------------------+both :: Arrow a => a d c -> a (d, d) (c, c)+both f = first f >>> second f++boundingBox :: (Unbox a, Real a) => Vector (V2 a) -> BBox+boundingBox = second demoteV3 . first demoteV3 . boundingCube . V.map promoteV2++listToBox :: [V2 Float] -> BBox+listToBox = boundingBox . V.fromList++foldIntoBox :: Vector BBox -> BBox+foldIntoBox = boundingBox . uncurry (V.++) . V.unzip++pointInBox :: V2 Float -> BBox -> Bool+pointInBox (V2 px py) (V2 minx miny, V2 maxx maxy) =+  (px >= minx && px <= maxx) && (py >= miny && py <= maxy)++applyTfrmToBox :: M44 Float -> BBox -> BBox+applyTfrmToBox t (tl,br) = listToBox [transformV2 t tl, transformV2 t br]

@@ -1,446 +1,447 @@+-- | CSS style colors! Also includes 'withAlpha' and 'fromHex', for+-- convenience. module Gelatin.Core.Color where -import Linear-import Data.Bits-import Gelatin.Core.Rendering.Types (Fill(..))+import           Data.Bits+import           Linear -solid :: V4 Float -> Fill-solid = FillColor . const+type Color = V4 Float -maroon :: (Num a, Fractional a) => V4 a+maroon :: Fractional a => V4 a maroon = V4 (128/255) (0/255) (0/255) 1 -red :: (Num a, Fractional a) => V4 a+red :: Fractional a => V4 a red = V4 (255/255) (0/255) (0/255) 1 -orange :: (Num a, Fractional a) => V4 a+orange :: Fractional a => V4 a orange = V4 (255/255) (165/255) (0/255) 1 -yellow :: (Num a, Fractional a) => V4 a+yellow,canary :: Fractional a => V4 a yellow = V4 (255/255) (255/255) (0/255) 1+canary = yellow -olive :: (Num a, Fractional a) => V4 a+olive :: Fractional a => V4 a olive = V4 (128/255) (128/255) (0/255) 1 -green :: (Num a, Fractional a) => V4 a+green :: Fractional a => V4 a green = V4 0 (128/255) (0/255) 1 -purple :: (Num a, Fractional a) => V4 a+purple :: Fractional a => V4 a purple = V4 (128/255) (0/255) (128/255) 1 -fuchsia :: (Num a, Fractional a) => V4 a+fuchsia :: Fractional a => V4 a fuchsia = V4 (255/255) (0/255) (255/255) 1 -lime :: (Num a, Fractional a) => V4 a+lime :: Fractional a => V4 a lime = V4 0 (255/255) (0/255) 1 -teal :: (Num a, Fractional a) => V4 a+teal :: Fractional a => V4 a teal = V4 0 (128/255) (128/255) 1 -aqua :: (Num a, Fractional a) => V4 a+aqua :: Fractional a => V4 a aqua = V4 0 (255/255) (255/255) 1 -blue :: (Num a, Fractional a) => V4 a+blue :: Fractional a => V4 a blue = V4 0 (0/255) (255/255) 1 -navy :: (Num a, Fractional a) => V4 a+navy :: Fractional a => V4 a navy = V4 0 (0/255) (128/255) 1 -black :: (Num a, Fractional a) => V4 a+black :: Fractional a => V4 a black = V4 0 (0/255) (0/255) 1 -gray :: (Num a, Fractional a) => V4 a+gray :: Fractional a => V4 a gray = V4 (128/255) (128/255) (128/255) 1 -grey :: (Num a, Fractional a) => V4 a+grey :: Fractional a => V4 a grey = gray -silver :: (Num a, Fractional a) => V4 a+silver :: Fractional a => V4 a silver = V4 (192/255) (192/255) (192/255) 1 -white :: (Num a, Fractional a) => V4 a+white :: Fractional a => V4 a white = V4 (255/255) (255/255) (255/255) 1 -indianRed :: (Num a, Fractional a) => V4 a+indianRed :: Fractional a => V4 a indianRed = V4 (205/255) (92/255) (92/255) 1 -lightCoral :: (Num a, Fractional a) => V4 a+lightCoral :: Fractional a => V4 a lightCoral = V4 (240/255) (128/255) (128/255) 1 -salmon :: (Num a, Fractional a) => V4 a+salmon :: Fractional a => V4 a salmon = V4 (250/255) (128/255) (114/255) 1 -darkSalmon :: (Num a, Fractional a) => V4 a+darkSalmon :: Fractional a => V4 a darkSalmon = V4 (233/255) (150/255) (122/255) 1 -lightSalmon :: (Num a, Fractional a) => V4 a+lightSalmon :: Fractional a => V4 a lightSalmon = V4 (255/255) (160/255) (122/255) 1 -crimson :: (Num a, Fractional a) => V4 a+crimson :: Fractional a => V4 a crimson = V4 (220/255) (20/255) (60/255) 1 -fireBrick :: (Num a, Fractional a) => V4 a+fireBrick :: Fractional a => V4 a fireBrick = V4 (178/255) (34/255) (34/255) 1 -darkRed :: (Num a, Fractional a) => V4 a+darkRed :: Fractional a => V4 a darkRed = V4 (139/255) (0/255) (0/255) 1 -pink :: (Num a, Fractional a) => V4 a+pink :: Fractional a => V4 a pink = V4 (255/255) (192/255) (203/255) 1 -lightPink :: (Num a, Fractional a) => V4 a+lightPink :: Fractional a => V4 a lightPink = V4 (255/255) (182/255) (193/255) 1 -hotPink :: (Num a, Fractional a) => V4 a+hotPink :: Fractional a => V4 a hotPink = V4 (255/255) (105/255) (180/255) 1 -deepPink :: (Num a, Fractional a) => V4 a+deepPink :: Fractional a => V4 a deepPink = V4 (255/255) (20/255) (147/255) 1 -mediumVioletRed :: (Num a, Fractional a) => V4 a+mediumVioletRed :: Fractional a => V4 a mediumVioletRed = V4 (199/255) (21/255) (133/255) 1 -paleVioletRed :: (Num a, Fractional a) => V4 a+paleVioletRed :: Fractional a => V4 a paleVioletRed = V4 (219/255) (112/255) (147/255) 1 -coral :: (Num a, Fractional a) => V4 a+coral :: Fractional a => V4 a coral = V4 (255/255) (127/255) (80/255) 1 -tomato :: (Num a, Fractional a) => V4 a+tomato :: Fractional a => V4 a tomato = V4 (255/255) (99/255) (71/255) 1 -orangeRed :: (Num a, Fractional a) => V4 a+orangeRed :: Fractional a => V4 a orangeRed = V4 (255/255) (69/255) (0/255) 1 -darkOrange :: (Num a, Fractional a) => V4 a+darkOrange :: Fractional a => V4 a darkOrange = V4 (255/255) (140/255) (0/255) 1 -gold :: (Num a, Fractional a) => V4 a+gold :: Fractional a => V4 a gold = V4 (255/255) (215/255) (0/255) 1 -lightYellow :: (Num a, Fractional a) => V4 a+lightYellow :: Fractional a => V4 a lightYellow = V4 (255/255) (255/255) (224/255) 1 -lemonChiffon :: (Num a, Fractional a) => V4 a+lemonChiffon :: Fractional a => V4 a lemonChiffon = V4 (255/255) (250/255) (205/255) 1 -lightGoldenrodYellow :: (Num a, Fractional a) => V4 a+lightGoldenrodYellow :: Fractional a => V4 a lightGoldenrodYellow = V4 (250/255) (250/255) (210/255) 1 -papayaWhip :: (Num a, Fractional a) => V4 a+papayaWhip :: Fractional a => V4 a papayaWhip = V4 (255/255) (239/255) (213/255) 1 -moccasin :: (Num a, Fractional a) => V4 a+moccasin :: Fractional a => V4 a moccasin = V4 (255/255) (228/255) (181/255) 1 -peachPuff :: (Num a, Fractional a) => V4 a+peachPuff :: Fractional a => V4 a peachPuff = V4 (255/255) (218/255) (185/255) 1 -paleGoldenrod :: (Num a, Fractional a) => V4 a+paleGoldenrod :: Fractional a => V4 a paleGoldenrod = V4 (238/255) (232/255) (170/255) 1 -khaki :: (Num a, Fractional a) => V4 a+khaki :: Fractional a => V4 a khaki = V4 (240/255) (230/255) (140/255) 1 -darkKhaki :: (Num a, Fractional a) => V4 a+darkKhaki :: Fractional a => V4 a darkKhaki = V4 (189/255) (183/255) (107/255) 1 -lavender :: (Num a, Fractional a) => V4 a+lavender :: Fractional a => V4 a lavender = V4 (230/255) (230/255) (250/255) 1 -thistle :: (Num a, Fractional a) => V4 a+thistle :: Fractional a => V4 a thistle = V4 (216/255) (191/255) (216/255) 1 -plum :: (Num a, Fractional a) => V4 a+plum :: Fractional a => V4 a plum = V4 (221/255) (160/255) (221/255) 1 -violet :: (Num a, Fractional a) => V4 a+violet :: Fractional a => V4 a violet = V4 (238/255) (130/255) (238/255) 1 -orchid :: (Num a, Fractional a) => V4 a+orchid :: Fractional a => V4 a orchid = V4 (218/255) (112/255) (214/255) 1 -magenta :: (Num a, Fractional a) => V4 a+magenta :: Fractional a => V4 a magenta = V4 (255/255) (0/255) (255/255) 1 -mediumOrchid :: (Num a, Fractional a) => V4 a+mediumOrchid :: Fractional a => V4 a mediumOrchid = V4 (186/255) (85/255) (211/255) 1 -mediumPurple :: (Num a, Fractional a) => V4 a+mediumPurple :: Fractional a => V4 a mediumPurple = V4 (147/255) (112/255) (219/255) 1 -amethyst :: (Num a, Fractional a) => V4 a+amethyst :: Fractional a => V4 a amethyst = V4 (153/255) (102/255) (204/255) 1 -blueViolet :: (Num a, Fractional a) => V4 a+blueViolet :: Fractional a => V4 a blueViolet = V4 (138/255) (43/255) (226/255) 1 -darkViolet :: (Num a, Fractional a) => V4 a+darkViolet :: Fractional a => V4 a darkViolet = V4 (148/255) (0/255) (211/255) 1 -darkOrchid :: (Num a, Fractional a) => V4 a+darkOrchid :: Fractional a => V4 a darkOrchid = V4 (153/255) (50/255) (204/255) 1 -darkMagenta :: (Num a, Fractional a) => V4 a+darkMagenta :: Fractional a => V4 a darkMagenta = V4 (139/255) (0/255) (139/255) 1 -indigo :: (Num a, Fractional a) => V4 a+indigo :: Fractional a => V4 a indigo = V4 (75/255) (0/255) (130/255) 1 -slateBlue :: (Num a, Fractional a) => V4 a+slateBlue :: Fractional a => V4 a slateBlue = V4 (106/255) (90/255) (205/255) 1 -darkSlateBlue :: (Num a, Fractional a) => V4 a+darkSlateBlue :: Fractional a => V4 a darkSlateBlue = V4 (72/255) (61/255) (139/255) 1 -mediumSlateBlue :: (Num a, Fractional a) => V4 a+mediumSlateBlue :: Fractional a => V4 a mediumSlateBlue = V4 (123/255) (104/255) (238/255) 1 -greenYellow :: (Num a, Fractional a) => V4 a+greenYellow :: Fractional a => V4 a greenYellow = V4 (173/255) (255/255) (47/255) 1 -chartreuse :: (Num a, Fractional a) => V4 a+chartreuse :: Fractional a => V4 a chartreuse = V4 (127/255) (255/255) (0/255) 1 -lawnGreen :: (Num a, Fractional a) => V4 a+lawnGreen :: Fractional a => V4 a lawnGreen = V4 (124/255) (252/255) (0/255) 1 -limeGreen :: (Num a, Fractional a) => V4 a+limeGreen :: Fractional a => V4 a limeGreen = V4 (50/255) (205/255) (50/255) 1 -paleGreen :: (Num a, Fractional a) => V4 a+paleGreen :: Fractional a => V4 a paleGreen = V4 (152/255) (251/255) (152/255) 1 -lightGreen :: (Num a, Fractional a) => V4 a+lightGreen :: Fractional a => V4 a lightGreen = V4 (144/255) (238/255) (144/255) 1 -mediumSpringGreen :: (Num a, Fractional a) => V4 a+mediumSpringGreen :: Fractional a => V4 a mediumSpringGreen = V4 0 (250/255) (154/255) 1 -springGreen :: (Num a, Fractional a) => V4 a+springGreen :: Fractional a => V4 a springGreen = V4 0 (255/255) (127/255) 1 -mediumSeaGreen :: (Num a, Fractional a) => V4 a+mediumSeaGreen :: Fractional a => V4 a mediumSeaGreen = V4 (60/255) (179/255) (113/255) 1 -seaGreen :: (Num a, Fractional a) => V4 a+seaGreen :: Fractional a => V4 a seaGreen = V4 (46/255) (139/255) (87/255) 1 -forestGreen :: (Num a, Fractional a) => V4 a+forestGreen :: Fractional a => V4 a forestGreen = V4 (34/255) (139/255) (34/255) 1 -darkGreen :: (Num a, Fractional a) => V4 a+darkGreen :: Fractional a => V4 a darkGreen = V4 0 (100/255) (0/255) 1 -yellowGreen :: (Num a, Fractional a) => V4 a+yellowGreen :: Fractional a => V4 a yellowGreen = V4 (154/255) (205/255) (50/255) 1 -oliveDrab :: (Num a, Fractional a) => V4 a+oliveDrab :: Fractional a => V4 a oliveDrab = V4 (107/255) (142/255) (35/255) 1 -darkOliveGreen :: (Num a, Fractional a) => V4 a+darkOliveGreen :: Fractional a => V4 a darkOliveGreen = V4 (85/255) (107/255) (47/255) 1 -mediumAquamarine :: (Num a, Fractional a) => V4 a+mediumAquamarine :: Fractional a => V4 a mediumAquamarine = V4 (102/255) (205/255) (170/255) 1 -darkSeaGreen :: (Num a, Fractional a) => V4 a+darkSeaGreen :: Fractional a => V4 a darkSeaGreen = V4 (143/255) (188/255) (143/255) 1 -lightSeaGreen :: (Num a, Fractional a) => V4 a+lightSeaGreen :: Fractional a => V4 a lightSeaGreen = V4 (32/255) (178/255) (170/255) 1 -darkCyan :: (Num a, Fractional a) => V4 a+darkCyan :: Fractional a => V4 a darkCyan = V4 0 (139/255) (139/255) 1 -cyan :: (Num a, Fractional a) => V4 a+cyan :: Fractional a => V4 a cyan = V4 0 (255/255) (255/255) 1 -lightCyan :: (Num a, Fractional a) => V4 a+lightCyan :: Fractional a => V4 a lightCyan = V4 (224/255) (255/255) (255/255) 1 -paleTurquoise :: (Num a, Fractional a) => V4 a+paleTurquoise :: Fractional a => V4 a paleTurquoise = V4 (175/255) (238/255) (238/255) 1 -aquamarine :: (Num a, Fractional a) => V4 a+aquamarine :: Fractional a => V4 a aquamarine = V4 (127/255) (255/255) (212/255) 1 -turquoise :: (Num a, Fractional a) => V4 a+turquoise :: Fractional a => V4 a turquoise = V4 (64/255) (224/255) (208/255) 1 -mediumTurquoise :: (Num a, Fractional a) => V4 a+mediumTurquoise :: Fractional a => V4 a mediumTurquoise = V4 (72/255) (209/255) (204/255) 1 -darkTurquoise :: (Num a, Fractional a) => V4 a+darkTurquoise :: Fractional a => V4 a darkTurquoise = V4 0 (206/255) (209/255) 1 -cadetBlue :: (Num a, Fractional a) => V4 a+cadetBlue :: Fractional a => V4 a cadetBlue = V4 (95/255) (158/255) (160/255) 1 -steelBlue :: (Num a, Fractional a) => V4 a+steelBlue :: Fractional a => V4 a steelBlue = V4 (70/255) (130/255) (180/255) 1 -lightSteelBlue :: (Num a, Fractional a) => V4 a+lightSteelBlue :: Fractional a => V4 a lightSteelBlue = V4 (176/255) (196/255) (222/255) 1 -powderBlue :: (Num a, Fractional a) => V4 a+powderBlue :: Fractional a => V4 a powderBlue = V4 (176/255) (224/255) (230/255) 1 -lightBlue :: (Num a, Fractional a) => V4 a+lightBlue :: Fractional a => V4 a lightBlue = V4 (173/255) (216/255) (230/255) 1 -skyBlue :: (Num a, Fractional a) => V4 a+skyBlue :: Fractional a => V4 a skyBlue = V4 (135/255) (206/255) (235/255) 1 -lightSkyBlue :: (Num a, Fractional a) => V4 a+lightSkyBlue :: Fractional a => V4 a lightSkyBlue = V4 (135/255) (206/255) (250/255) 1 -deepSkyBlue :: (Num a, Fractional a) => V4 a+deepSkyBlue :: Fractional a => V4 a deepSkyBlue = V4 0 (191/255) (255/255) 1 -dodgerBlue :: (Num a, Fractional a) => V4 a+dodgerBlue :: Fractional a => V4 a dodgerBlue = V4 (30/255) (144/255) (255/255) 1 -cornflowerBlue :: (Num a, Fractional a) => V4 a+cornflowerBlue :: Fractional a => V4 a cornflowerBlue = V4 (100/255) (149/255) (237/255) 1 -royalBlue :: (Num a, Fractional a) => V4 a+royalBlue :: Fractional a => V4 a royalBlue = V4 (65/255) (105/255) (225/255) 1 -mediumBlue :: (Num a, Fractional a) => V4 a+mediumBlue :: Fractional a => V4 a mediumBlue = V4 0 (0/255) (205/255) 1 -darkBlue :: (Num a, Fractional a) => V4 a+darkBlue :: Fractional a => V4 a darkBlue = V4 0 (0/255) (139/255) 1 -midnightBlue :: (Num a, Fractional a) => V4 a+midnightBlue :: Fractional a => V4 a midnightBlue = V4 (25/255) (25/255) (112/255) 1 -cornsilk :: (Num a, Fractional a) => V4 a+cornsilk :: Fractional a => V4 a cornsilk = V4 (255/255) (248/255) (220/255) 1 -blanchedAlmond :: (Num a, Fractional a) => V4 a+blanchedAlmond :: Fractional a => V4 a blanchedAlmond = V4 (255/255) (235/255) (205/255) 1 -bisque :: (Num a, Fractional a) => V4 a+bisque :: Fractional a => V4 a bisque = V4 (255/255) (228/255) (196/255) 1 -navajoWhite :: (Num a, Fractional a) => V4 a+navajoWhite :: Fractional a => V4 a navajoWhite = V4 (255/255) (222/255) (173/255) 1 -wheat :: (Num a, Fractional a) => V4 a+wheat :: Fractional a => V4 a wheat = V4 (245/255) (222/255) (179/255) 1 -burlyWood :: (Num a, Fractional a) => V4 a+burlyWood :: Fractional a => V4 a burlyWood = V4 (222/255) (184/255) (135/255) 1 -tan :: (Num a, Fractional a) => V4 a+tan :: Fractional a => V4 a tan = V4 (210/255) (180/255) (140/255) 1 -rosyBrown :: (Num a, Fractional a) => V4 a+rosyBrown :: Fractional a => V4 a rosyBrown = V4 (188/255) (143/255) (143/255) 1 -sandyBrown :: (Num a, Fractional a) => V4 a+sandyBrown :: Fractional a => V4 a sandyBrown = V4 (244/255) (164/255) (96/255) 1 -goldenrod :: (Num a, Fractional a) => V4 a+goldenrod :: Fractional a => V4 a goldenrod = V4 (218/255) (165/255) (32/255) 1 -darkGoldenrod :: (Num a, Fractional a) => V4 a+darkGoldenrod :: Fractional a => V4 a darkGoldenrod = V4 (184/255) (134/255) (11/255) 1 -peru :: (Num a, Fractional a) => V4 a+peru :: Fractional a => V4 a peru = V4 (205/255) (133/255) (63/255) 1 -chocolate :: (Num a, Fractional a) => V4 a+chocolate :: Fractional a => V4 a chocolate = V4 (210/255) (105/255) (30/255) 1 -saddleBrown :: (Num a, Fractional a) => V4 a+saddleBrown :: Fractional a => V4 a saddleBrown = V4 (139/255) (69/255) (19/255) 1 -sienna :: (Num a, Fractional a) => V4 a+sienna :: Fractional a => V4 a sienna = V4 (160/255) (82/255) (45/255) 1 -brown :: (Num a, Fractional a) => V4 a+brown :: Fractional a => V4 a brown = V4 (165/255) (42/255) (42/255) 1 -snow :: (Num a, Fractional a) => V4 a+snow :: Fractional a => V4 a snow = V4 (255/255) (250/255) (250/255) 1 -honeydew :: (Num a, Fractional a) => V4 a+honeydew :: Fractional a => V4 a honeydew = V4 (240/255) (255/255) (240/255) 1 -mintCream :: (Num a, Fractional a) => V4 a+mintCream :: Fractional a => V4 a mintCream = V4 (245/255) (255/255) (250/255) 1 -azure :: (Num a, Fractional a) => V4 a+azure :: Fractional a => V4 a azure = V4 (240/255) (255/255) (255/255) 1 -aliceBlue :: (Num a, Fractional a) => V4 a+aliceBlue :: Fractional a => V4 a aliceBlue = V4 (240/255) (248/255) (255/255) 1 -ghostWhite :: (Num a, Fractional a) => V4 a+ghostWhite :: Fractional a => V4 a ghostWhite = V4 (248/255) (248/255) (255/255) 1 -whiteSmoke :: (Num a, Fractional a) => V4 a+whiteSmoke :: Fractional a => V4 a whiteSmoke = V4 (245/255) (245/255) (245/255) 1 -seashell :: (Num a, Fractional a) => V4 a+seashell :: Fractional a => V4 a seashell = V4 (255/255) (245/255) (238/255) 1 -beige :: (Num a, Fractional a) => V4 a+beige :: Fractional a => V4 a beige = V4 (245/255) (245/255) (220/255) 1 -oldLace :: (Num a, Fractional a) => V4 a+oldLace :: Fractional a => V4 a oldLace = V4 (253/255) (245/255) (230/255) 1 -floralWhite :: (Num a, Fractional a) => V4 a+floralWhite :: Fractional a => V4 a floralWhite = V4 (255/255) (250/255) (240/255) 1 -ivory :: (Num a, Fractional a) => V4 a+ivory :: Fractional a => V4 a ivory = V4 (255/255) (255/255) (240/255) 1 -antiqueWhite :: (Num a, Fractional a) => V4 a+antiqueWhite :: Fractional a => V4 a antiqueWhite = V4 (250/255) (235/255) (215/255) 1 -linen :: (Num a, Fractional a) => V4 a+linen :: Fractional a => V4 a linen = V4 (250/255) (240/255) (230/255) 1 -lavenderBlush :: (Num a, Fractional a) => V4 a+lavenderBlush :: Fractional a => V4 a lavenderBlush = V4 (255/255) (240/255) (245/255) 1 -mistyRose :: (Num a, Fractional a) => V4 a+mistyRose :: Fractional a => V4 a mistyRose = V4 (255/255) (228/255) (225/255) 1 -gainsboro :: (Num a, Fractional a) => V4 a+gainsboro :: Fractional a => V4 a gainsboro = V4 (220/255) (220/255) (220/255) 1 -lightGrey :: (Num a, Fractional a) => V4 a+lightGrey :: Fractional a => V4 a lightGrey = V4 (211/255) (211/255) (211/255) 1 -darkGray :: (Num a, Fractional a) => V4 a+darkGray :: Fractional a => V4 a darkGray = V4 (169/255) (169/255) (169/255) 1 -dimGray :: (Num a, Fractional a) => V4 a+dimGray :: Fractional a => V4 a dimGray = V4 (105/255) (105/255) (105/255) 1 -lightSlateGray :: (Num a, Fractional a) => V4 a+lightSlateGray :: Fractional a => V4 a lightSlateGray = V4 (119/255) (136/255) (153/255) 1 -slateGray :: (Num a, Fractional a) => V4 a+slateGray :: Fractional a => V4 a slateGray = V4 (112/255) (128/255) (144/255) 1 -darkSlateGray :: (Num a, Fractional a) => V4 a+darkSlateGray :: Fractional a => V4 a darkSlateGray = V4 (47/255) (79/255) (79/255) 1 -transparent :: (Num a, Fractional a) => V4 a+transparent :: Fractional a => V4 a transparent = V4 0 0 0 0 -alpha :: (Num a, Fractional a) => V4 a -> a -> V4 a-alpha (V4 r g b _) a = V4 r g b a+withAlpha :: V4 a -> a -> V4 a+withAlpha (V4 r g b _) = V4 r g b -hex :: (Num b, Fractional b) => Int -> V4 b-hex n = fmap ((/255) . fromIntegral) $ V4 r g b a+fromHex :: Fractional b => Int -> V4 b+fromHex n = ((/255) . fromIntegral) <$> V4 r g b a     where r = n `shiftR` 24           g = n `shiftR` 16 .&. 0xFF           b = n `shiftR` 8 .&. 0xFF

@@ -0,0 +1,95 @@+-- | This module is planned to disappear in favor of a stateful polyline+-- drawing mode. It's still here for various renderers.+module Gelatin.Core.Polyline where++import           Data.List           (unzip5)+import           Data.Vector.Unboxed (Unbox, Vector)+import qualified Data.Vector.Unboxed as V+import           Linear              hiding (trace)+++type PolylineData f =+  ( Vector (V2 Float)+  , Vector (f Float)+  , Vector (V2 Float)+  , Vector (V2 Float)+  , Vector (V2 Float)+  , Float+  )++expandPolyline :: Unbox (f Float)+               => Vector (V2 Float) -> Vector (f Float) -> Float -> Float+               -> Maybe (PolylineData f)+expandPolyline verts colors thickness feather+    | Just (v1,v2) <- (,) <$> (verts V.!? 0) <*> (verts V.!? 1)+    , Just c1  <- colors V.!? 0+    , Just (v3,v3n) <- (,) <$> (verts V.!? (V.length verts -1))+                           <*> (verts V.!? (V.length verts -2))+    , Just c3 <- colors V.!? (V.length verts -1) =+    let -- clamp the lower bound of our thickness to 1+        absthick = max thickness 1+        d = fromIntegral (ceiling $ absthick + 2.5 * feather :: Integer)+        lens = 0 `V.cons` V.zipWith distance verts (V.drop 1 verts)+        totalLen = V.foldl' (+) 0 lens+        totalEnd = totalLen + d+        seqfunc (total,ts) len = (total + len,ts V.++ V.singleton (total + len))+        seqLens  = snd $ V.foldl' seqfunc (0,mempty) lens+        isClosed = distance v1 v3 <= 0.00001+        -- if the polyline is closed return a miter with the last point+        startCap = ( V.fromList [cap,cap]+                   , V.fromList [c1,c1]+                   , uvs+                   , V.fromList [v2,v2]+                   , V.fromList [prev,prev]+                   )+            where (uvs,cap,prev) = if isClosed+                                   -- no cap+                                   then (V.fromList [V2 0 d, V2 0 (-d)],v1,v3n)+                                   -- cap+                                   else let c = d *^ signorm (v2 - v1)+                                        in ( V.fromList [V2 (-d) d, V2 (-d) (-d)]+                                           , v1 - c+                                           , v1 - 2*c)+        endCap = ( V.fromList [cap,cap]+                 , V.fromList [c3,c3]+                 , uvs+                 , V.fromList [next,next]+                 , V.fromList [v3n,v3n]+                 )+            where (uvs,cap,next) = if isClosed+                                   -- no cap+                                   then ( V.fromList [ V2 totalLen d+                                                     , V2 totalLen (-d)+                                                     ]+                                        , v3+                                        , v2+                                        )+                                   -- cap+                                   else let c = d *^ signorm (v3 - v3n)+                                        in (V.fromList [ V2 totalEnd d+                                                       , V2 totalEnd (-d)+                                                       ]+                                           , v3 + c+                                           , v3 + 2*c+                                           )+        vcs  = V.toList $ V.zip3 verts colors seqLens+        zs   = zipWith3 strp vcs (drop 1 vcs) (drop 2 vcs)+        -- Expand the line into a triangle strip+        strp :: Unbox (f Float)+             => (V2 Float, f Float, Float) -> (V2 Float, f Float, Float)+             -> (V2 Float, f Float, Float) -> (Vector (V2 Float)+                                              ,Vector (f Float)+                                              ,Vector (V2 Float)+                                              ,Vector (V2 Float)+                                              ,Vector (V2 Float)+                                              )+        strp (a,_,_) (b,bc,l) (c,_,_) =+          ( V.fromList [b,b]+          , V.fromList [bc,bc]+          , V.fromList [V2 l d,V2 l (-d)]+          , V.fromList [c,c]+          , V.fromList [a,a]+          )+        (vs,cs,us,ns,ps) = unzip5 $ startCap : zs ++ [endCap]+      in Just (V.concat vs, V.concat cs, V.concat us, V.concat ns, V.concat ps, totalLen)+    | otherwise = Nothing

@@ -1,642 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Gelatin.Core.Rendering (-    module R,-    initGelatin,-    newWindow,-    loadGeomRenderSource,-    loadBezRenderSource,-    loadMaskRenderSource,-    loadRenderSource,-    loadTexture,-    loadTextureUnit,-    unloadTexture,-    loadImageAsTexture,-    filledTriangleRendering,-    colorRendering,-    colorBezRendering,-    colorFontRendering,-    textureRendering,-    textureUnitRendering,-    maskRendering,-    transformRendering,-    stencilMask,-    alphaMask,-    toTexture,-    toTextureUnit,-    clipTexture,-    calculateDpi-) where--import Gelatin.Core.Shader-import Gelatin.Core.Rendering.Types as R-import Gelatin.Core.Rendering.Polylines as R-import Gelatin.Core.Rendering.Geometrical as R-import Gelatin.Core.Rendering.Font as R-import Linear-import Graphics.Text.TrueType-import Graphics.GL.Core33-import Graphics.GL.Types-import Graphics.UI.GLFW as GLFW hiding (Image(..))-import Codec.Picture.Types-import Codec.Picture (readImage)-import Foreign.Marshal.Array-import Foreign.Marshal.Utils-import Foreign.C.String-import Foreign.Storable-import Foreign.Ptr-import Data.Monoid-import Data.Maybe-import Data.Vector.Storable (Vector,unsafeWith)-import Control.Monad-import System.Directory-import System.IO-import System.Exit-import qualified Data.ByteString.Char8 as B-import qualified Data.Foldable as F-import GHC.Stack---- | Initializes the system. This must be called before creating a window.--- Returns True when initialization was successful.-initGelatin :: IO Bool-initGelatin = do-    setErrorCallback $ Just $ \_ -> hPutStrLn stderr-    GLFW.init---- | Creates a window. This can only be called after initializing with--- `initGelatin`.-newWindow :: Int -- ^ Width-          -> Int -- ^ Height-          -> String -- ^ Title-          -> Maybe Monitor -- ^ The monitor to fullscreen into.-          -> Maybe Window -- ^ A window to share OpenGL contexts with.-          -> IO Window-newWindow ww wh ws mmon mwin = do-    defaultWindowHints-    windowHint $ WindowHint'OpenGLDebugContext True-    windowHint $ WindowHint'OpenGLProfile OpenGLProfile'Core-    windowHint $ WindowHint'OpenGLForwardCompat True-    windowHint $ WindowHint'ContextVersionMajor 3-    windowHint $ WindowHint'ContextVersionMinor 3-    windowHint $ WindowHint'DepthBits 16-    mwin' <- createWindow ww wh ws mmon mwin-    makeContextCurrent mwin'-    window <- case mwin' of-                  Nothing  -> do putStrLn "could not create window"-                                 exitFailure-                  Just win -> return win-    return window------------------------------------------------------------------------------------- Renderings------------------------------------------------------------------------------------ | Creates and returns a renderer that renders a given string of--- triangles with the given filling.-filledTriangleRendering :: Window -> GeomRenderSource -> [Triangle (V2 Float)]-                       -> Fill -> IO Rendering-filledTriangleRendering win grs ts fill = do-    let vs = trisToComp ts-    mfr <- getFillResult fill vs-    case mfr of-        Just (FillResultColor cs) -> colorRendering win grs GL_TRIANGLES vs cs-        Just (FillResultTexture _ uvs) -> textureRendering win grs GL_TRIANGLES-                                                                  vs uvs-        _ -> do putStrLn "Could not create a filledTriangleRendering."-                return $ Rendering (const $ putStrLn "Non op renderer.") (return ())---- | Applies a fill to a list of points to create a fill result. If the--- Fill is a texture then the texture's image will be loaded.-getFillResult :: Fill -> [V2 Float] -> IO (Maybe FillResult)-getFillResult (FillColor f) vs = return $ Just $ FillResultColor $ map f vs-getFillResult (FillTexture fp f) vs = do-    mtex <- loadImageAsTexture fp-    return $ case mtex of-        Nothing  -> Nothing-        Just tex -> Just $ FillResultTexture tex $ map f vs---- | TODO: textureFontRendering and then fontRendering.---- | Creates and returns a renderer that renders a given FontString.-colorFontRendering :: Window -> GeomRenderSource -> BezRenderSource-                  -> FontString -> (V2 Float -> V4 Float) -> IO Rendering-colorFontRendering window grs brs fstr clrf = do-    dpi <- calculateDpi-    let (bs,ts) = fontGeom dpi fstr-        vs = concatMap (\(Triangle a b c) -> [a,b,c]) ts-        cs = map clrf vs-    Rendering fg cg <- colorRendering window grs GL_TRIANGLES vs cs--    let bcs = map ((\(Bezier _ a b c) -> Triangle a b c) . fmap clrf) bs-    Rendering fb cb <- colorBezRendering window brs bs bcs--    let s t  = stencilMask (fg t) (fg t)-        gs t = s t >> fb t-    return $ Rendering gs (cg >> cb)---- | Creates and returns a renderer that renders the given colored--- geometry.-colorRendering :: Window -> GeomRenderSource -> GLuint -> [V2 Float]-              -> [V4 Float] -> IO Rendering-colorRendering window grs mode vs gs = do-    let (GRS src) = grs-        srcs = [src]--    withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do-        let ps = map realToFrac $ concatMap F.toList vs :: [GLfloat]-            cs = map realToFrac $ concatMap F.toList $ take (length vs) gs :: [GLfloat]--        glDisableVertexAttribArray uvLoc-        glEnableVertexAttribArray colorLoc--        bufferAttrib positionLoc 2 pbuf ps-        bufferAttrib colorLoc 4 cbuf cs-        glBindVertexArray 0--        let num = fromIntegral $ length vs-            renderFunction t = do-                withUniform "hasUV" srcs $ \p huv -> do-                    glUseProgram p-                    glUniform1i huv 0-                withUniform "projection" srcs $ setOrthoWindowProjection window-                withUniform "modelview" srcs $ setModelview t-                drawBuffer (rsProgram src) vao mode num-            cleanupFunction = do-                withArray [pbuf, cbuf] $ glDeleteBuffers 2-                withArray [vao] $ glDeleteVertexArrays 1-        return $ Rendering renderFunction cleanupFunction---- | Creates and returns a renderer that renders a textured--- geometry using the texture bound to GL_TEXTURE0.-textureRendering :: Window -> GeomRenderSource -> GLuint -> [V2 Float]-                -> [V2 Float] -> IO Rendering-textureRendering = textureUnitRendering Nothing---- | Creates and returns a renderer that renders the given textured--- geometry using the specified texture binding.-textureUnitRendering :: (Maybe GLint) -> Window -> GeomRenderSource -> GLuint-                    -> [V2 Float] -> [V2 Float] -> IO Rendering-textureUnitRendering Nothing w gs md vs uvs =-    textureUnitRendering (Just 0) w gs md vs uvs-textureUnitRendering (Just u) win grs mode vs uvs = do-    let (GRS src) = grs-        srcs = [src]--    withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do-        let f xs = map realToFrac $ concatMap F.toList xs :: [GLfloat]-            ps = f vs-            cs = f $ take (length vs) uvs--        glDisableVertexAttribArray colorLoc-        glEnableVertexAttribArray uvLoc--        bufferAttrib positionLoc 2 pbuf ps-        bufferAttrib uvLoc 2 cbuf cs-        glBindVertexArray 0--        let num = fromIntegral $ length vs-            renderFunction tfrm = do-                withUniform "hasUV" srcs $ \p huv -> do-                    glUseProgram p-                    glUniform1i huv 1-                withUniform "sampler" srcs $ \p smp -> do-                    glUseProgram p-                    glUniform1i smp u-                withUniform "projection" srcs $ setOrthoWindowProjection win-                withUniform "modelview" srcs $ setModelview tfrm-                drawBuffer (rsProgram src) vao mode num-            cleanupFunction = do-                withArray [pbuf, cbuf] $ glDeleteBuffers 2-                withArray [vao] $ glDeleteVertexArrays 1-        return $ Rendering renderFunction cleanupFunction---- | Creates and returns a renderer that renders the given colored beziers.-colorBezRendering :: Window -> BezRenderSource -> [Bezier (V2 Float)]-                 -> [Triangle (V4 Float)] -> IO Rendering-colorBezRendering window (BRS src) bs ts =-    withVAO $ \vao -> withBuffers 3 $ \[pbuf, tbuf, cbuf] -> do-        let vs = concatMap (\(Bezier _ a b c) -> [a,b,c]) bs-            cvs = concatMap (\(Triangle a b c) -> [a,b,c]) $ take (length bs) ts-            ps = map realToFrac $ concatMap F.toList vs :: [GLfloat]-            cs = map realToFrac $ concatMap F.toList cvs :: [GLfloat]-            ws = concatMap (\(Bezier w _ _ _) -> let w' = fromBool $ w == LT-                                                 in [ 0, 0, w'-                                                    , 0.5, 0, w'-                                                    , 1, 1, w'-                                                    ])-                           bs :: [GLfloat]--        glDisableVertexAttribArray uvLoc-        glEnableVertexAttribArray colorLoc-        bufferAttrib positionLoc 2 pbuf ps-        bufferAttrib bezLoc 3 tbuf ws-        bufferAttrib colorLoc 4 cbuf cs-        glBindVertexArray 0--        let cleanupFunction = do-                withArray [pbuf, tbuf, cbuf] $ glDeleteBuffers 3-                withArray [vao] $ glDeleteVertexArrays 1-            num = fromIntegral $ length vs-            srcs = [src]-            renderFunction t = do-                withUniform "hasUV" srcs $ \p huv -> do-                    glUseProgram p-                    glUniform1i huv 0-                withUniform "projection" srcs $ setOrthoWindowProjection window-                withUniform "modelview" srcs $ setModelview t-                drawBuffer (rsProgram src) vao GL_TRIANGLES num-        return $ Rendering renderFunction cleanupFunction---- | Creates and returns a renderer that masks a textured rectangular area with--- another texture.-maskRendering :: Window -> MaskRenderSource -> GLuint -> [V2 Float]-             -> [V2 Float] -> IO Rendering-maskRendering win (MRS src) mode vs uvs =-    withVAO $ \vao -> withBuffers 2 $ \[pbuf, uvbuf] -> do-        let vs'  = map realToFrac $ concatMap F.toList vs :: [GLfloat]-            uvs' = map realToFrac $ concatMap F.toList uvs :: [GLfloat]--        glDisableVertexAttribArray colorLoc-        glEnableVertexAttribArray positionLoc-        glEnableVertexAttribArray uvLoc-        bufferAttrib positionLoc 2 pbuf vs'-        bufferAttrib uvLoc 2 uvbuf uvs'-        glBindVertexArray 0--        let cleanup = do withArray [pbuf, uvbuf] $ glDeleteBuffers 2-                         withArray [vao] $ glDeleteVertexArrays 1-            num = fromIntegral $ length vs-            render t = do-                withUniform "projection" [src] $ setOrthoWindowProjection win-                withUniform "modelview" [src] $ setModelview t-                withUniform "mainTex" [src] $ \p smp -> do-                    glUseProgram p-                    glUniform1i smp 0-                withUniform "maskTex" [src] $ \p smp -> do-                    glUseProgram p-                    glUniform1i smp 1-                drawBuffer (rsProgram src) vao mode num-        return $ Rendering render cleanup---- | Creates a rendering that masks an IO () drawing computation with the alpha--- value of another.-alphaMask :: Window -> MaskRenderSource -> IO () -> IO () -> IO Rendering-alphaMask win mrs r2 r1 = do-    mainTex <- toTextureUnit (Just GL_TEXTURE0) win r2-    maskTex <- toTextureUnit (Just GL_TEXTURE1) win r1-    (w,h)   <- getWindowSize win-    let vs = map (fmap fromIntegral) [V2 0 0, V2 w 0, V2 w h, V2 0 h]-        uvs = [V2 0 1, V2 1 1, V2 1 0, V2 0 0]-    Rendering f c <- maskRendering win mrs GL_TRIANGLE_FAN vs uvs-    let f' _ = do glActiveTexture GL_TEXTURE0-                  glBindTexture GL_TEXTURE_2D mainTex-                  glActiveTexture GL_TEXTURE1-                  glBindTexture GL_TEXTURE_2D maskTex-        c'    = withArray [mainTex,maskTex] $ glDeleteTextures 2-        f'' _ = do glActiveTexture GL_TEXTURE0-                   glBindTexture GL_TEXTURE_2D 0-                   glActiveTexture GL_TEXTURE1-                   glBindTexture GL_TEXTURE_2D 0-    return $ Rendering (\t -> f' t >> f t >> f'' t) (c >> c')---- | Creates an IO () drawing computation that masks an IO () drawing--- computation with another using a stencil test.-stencilMask :: IO () -> IO () -> IO ()-stencilMask r2 r1  = do-    glClear GL_DEPTH_BUFFER_BIT-    -- Enable stencil testing-    glEnable GL_STENCIL_TEST-    -- Disable writing frame buffer color components-    glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE-    -- Disable writing into the depth buffer-    glDepthMask GL_FALSE-    -- Enable writing to all bits of the stencil mask-    glStencilMask 0xFF-    -- Clear the stencil buffer-    glClear GL_STENCIL_BUFFER_BIT-    glStencilFunc GL_NEVER 0 1-    glStencilOp GL_INVERT GL_INVERT GL_INVERT-    r1--    glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE-    glDepthMask GL_TRUE-    glStencilFunc GL_EQUAL 1 1-    glStencilOp GL_ZERO GL_ZERO GL_ZERO-    r2-    glDisable GL_STENCIL_TEST---transformRendering :: Transform -> Rendering -> Rendering-transformRendering t (Rendering r c) = Rendering (r . (t <>)) c------------------------------------------------------------------------------------ Updating uniforms----------------------------------------------------------------------------------withUniform :: String -> [RenderSource] -> (GLuint -> GLint -> IO ()) -> IO ()-withUniform name srcs f = mapM_ update srcs-    where update (RenderSource p ls) = case lookup name ls of-                                           Nothing -> return ()-                                           Just u  -> do f p u--setOrthoWindowProjection :: Window -> GLuint -> GLint -> IO ()-setOrthoWindowProjection window program pju = do-    pj <- orthoWindowProjection window-    glUseProgram program-    with pj $ glUniformMatrix4fv pju 1 GL_TRUE . castPtr--setModelview :: Transform -> GLuint -> GLint -> IO ()-setModelview (Transform (V2 x y) (V2 w h) r) program uniform = do-    let mv = mat4Translate txy !*! rot !*! mat4Scale sxy :: M44 GLfloat-        sxy = V3 w h 1-        txy = V3 x y 0-        rxy = V3 0 0 1-        rot = if r /= 0 then mat4Rotate r rxy else identity-    glUseProgram program-    with mv $ glUniformMatrix4fv uniform 1 GL_TRUE . castPtr--orthoWindowProjection :: Window -> IO (M44 GLfloat)-orthoWindowProjection window = do-    (ww, wh) <- getWindowSize window-    let (hw,hh) = (fromIntegral ww, fromIntegral wh)-    return $ ortho 0 hw hh 0 0 1------------------------------------------------------------------------------------ Loading resources and things------------------------------------------------------------------------------------- | Loads a new shader program and attributes for rendering geometry.-loadGeomRenderSource :: IO GeomRenderSource-loadGeomRenderSource = do-    let def = RenderDefBS [(vertSourceGeom, GL_VERTEX_SHADER)-                          ,(fragSourceGeom, GL_FRAGMENT_SHADER)-                          ] ["projection", "modelview", "sampler", "hasUV"]-    GRS <$> loadRenderSource def---- | Loads a new shader progarm and attributes for rendering beziers.-loadBezRenderSource :: IO BezRenderSource-loadBezRenderSource = do-    let def = RenderDefBS [(vertSourceBezier, GL_VERTEX_SHADER)-                          ,(fragSourceBezier, GL_FRAGMENT_SHADER)-                          ] ["projection", "modelview", "sampler", "hasUV"]-    BRS <$> loadRenderSource def---- | Loads a new shader program and attributes for masking textures.-loadMaskRenderSource :: IO MaskRenderSource-loadMaskRenderSource = do-    let def = RenderDefBS [(vertSourceMask, GL_VERTEX_SHADER)-                          ,(fragSourceMask, GL_FRAGMENT_SHADER)-                          ] ["projection","modelview","mainTex","maskTex"]-    MRS <$> loadRenderSource def--loadRenderSource :: RenderDef -> IO RenderSource-loadRenderSource (RenderDefBS ss uniforms) = do-    shaders <- mapM (uncurry compileShader) ss-    program <- compileProgram shaders-    glUseProgram program-    locs <- forM uniforms $ \attr -> do-        loc <- withCString attr $ glGetUniformLocation program-        return $ if loc == (-1)-                 then Nothing-                 else Just (attr, loc)-    print locs-    return $ RenderSource program $ catMaybes locs-loadRenderSource (RenderDefFP fps uniforms) = do-    cwd <- getCurrentDirectory-    srcs <- forM fps $ \(fp, shaderType) -> do-        src <- B.readFile $ cwd ++ "/" ++ fp-        return (src, shaderType)-    loadRenderSource $ RenderDefBS srcs uniforms------------------------------------------------------------------------------------ Working with textures.----------------------------------------------------------------------------------loadImageAsTexture :: FilePath -> IO (Maybe GLuint)-loadImageAsTexture fp = do-    eStrOrImg <- readImage fp-    case eStrOrImg of-        Left err -> putStrLn err >> return Nothing-        Right i  -> loadTexture i >>= return . Just--loadTexture :: DynamicImage -> IO GLuint-loadTexture = loadTextureUnit Nothing--loadTextureUnit :: Maybe GLuint -> DynamicImage -> IO GLuint-loadTextureUnit Nothing img = loadTextureUnit (Just GL_TEXTURE0) img-loadTextureUnit (Just u) img = do-    [t] <- allocaArray 1 $ \ptr -> do-        glGenTextures 1 ptr-        peekArray 1 ptr-    glActiveTexture u-    glBindTexture GL_TEXTURE_2D t-    loadJuicy img-    glGenerateMipmap GL_TEXTURE_2D  -- Generate mipmaps now!!!-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST_MIPMAP_NEAREST-    glBindTexture GL_TEXTURE_2D 0-    return t--unloadTexture :: GLuint -> IO ()-unloadTexture t = withArray [t] $ glDeleteTextures 1--loadJuicy :: DynamicImage -> IO ()-loadJuicy (ImageY8 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_BYTE-loadJuicy (ImageY16 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_SHORT-loadJuicy (ImageYF (Image w h d)) = bufferImageData w h d GL_RED GL_FLOAT-loadJuicy (ImageYA8 i) = loadJuicy $ ImageRGB8 $ promoteImage i-loadJuicy (ImageYA16 i) = loadJuicy $ ImageRGBA16 $ promoteImage i-loadJuicy (ImageRGB8 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_BYTE-loadJuicy (ImageRGB16 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_SHORT-loadJuicy (ImageRGBF (Image w h d)) = bufferImageData w h d GL_RGB GL_FLOAT-loadJuicy (ImageRGBA8 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_BYTE-loadJuicy (ImageRGBA16 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_SHORT-loadJuicy (ImageYCbCr8 i) = loadJuicy $ ImageRGB8 $ convertImage i-loadJuicy (ImageCMYK8 i) = loadJuicy $ ImageRGB8 $ convertImage i-loadJuicy (ImageCMYK16 i) = loadJuicy $ ImageRGB16 $ convertImage i---toTexture :: Window -> IO () -> IO GLuint-toTexture = toTextureUnit Nothing--toTextureUnit :: Maybe GLuint -> Window -> IO () -> IO GLuint-toTextureUnit Nothing win r = toTextureUnit (Just GL_TEXTURE0) win r-toTextureUnit (Just u) win r = do-    [fb] <- allocaArray 1 $ \ptr -> do-        glGenFramebuffers 1 ptr-        peekArray 1 ptr-    glBindFramebuffer GL_FRAMEBUFFER fb--    [t] <- allocaArray 1 $ \ptr -> do-        glGenTextures 1 ptr-        peekArray 1 ptr-    glActiveTexture u-    glBindTexture GL_TEXTURE_2D t-    (w,h) <- getWindowSize win-    let [w',h'] = map fromIntegral [w,h]-    glTexImage2D GL_TEXTURE_2D-                 0-                 GL_RGBA-                 w'-                 h'-                 0-                 GL_RGBA-                 GL_UNSIGNED_BYTE-                 nullPtr-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST--    glFramebufferTexture GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 t 0-    withArray [GL_COLOR_ATTACHMENT0] $ glDrawBuffers 1--    status <- glCheckFramebufferStatus GL_FRAMEBUFFER-    if status /= GL_FRAMEBUFFER_COMPLETE-    then putStrLn "incomplete framebuffer!"-    else do glClearColor 0 0 0 0-            glClear GL_COLOR_BUFFER_BIT-            --ww <- (fromIntegral . fst) <$> getWindowSize win--            --let s = floor (fbw/ww :: Double)-            --print s-            glViewport 0 0 w' h' --fbw' fbh'-            r-            glBindFramebuffer GL_FRAMEBUFFER 0-            with fb $ glDeleteFramebuffers 1-            (fbw, fbh) <- getFramebufferSize win-            glViewport 0 0 (fromIntegral fbw) (fromIntegral fbh)-    return t---- | Sub-samples a texture using the given coordinate box and creates a new--- texture. Keep in mind that OpenGL texture coordinates are flipped from--- 'normal' graphics coordinates (y = 0 is the bottom of the texture). That--- fact has bitten the author a number of times while clipping a texture--- created with `toTexture` and `toUnitTexture`.-clipTexture :: GLuint -> ClippingArea -> IO GLuint-clipTexture rtex ((V2 x1 y1), (V2 x2 y2)) = do-    -- Create our framebuffers-    [fbread,fbwrite] <- allocaArray 2 $ \ptr -> do-        glGenFramebuffers 2 ptr-        peekArray 2 ptr-    -- Bind our read frame buffer and attach the input texture to it-    glBindFramebuffer GL_READ_FRAMEBUFFER fbread-    glFramebufferTexture2D GL_READ_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D rtex 0-    clearErrors "clipTexture bind read framebuffer"-    -- Generate a new texture and bind our write framebuffer to it-    [wtex] <- allocaArray 1 $ \ptr -> do-        glGenTextures 1 ptr-        peekArray 1 ptr-    glActiveTexture GL_TEXTURE0-    glBindTexture GL_TEXTURE_2D wtex-    let [x1',y1',x2',y2',w',h'] = map fromIntegral-                                      [x1,y1,x2,y2,(abs $ x2 - x1)-                                                  ,(abs $ y2 - y1)]-    glTexImage2D GL_TEXTURE_2D-                 0-                 GL_RGBA-                 w'-                 h'-                 0-                 GL_RGBA-                 GL_UNSIGNED_BYTE-                 nullPtr-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST-    glBindFramebuffer GL_DRAW_FRAMEBUFFER fbwrite-    glFramebufferTexture2D GL_DRAW_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D wtex 0-    clearErrors "clipTexture bind write framebuffer"-    -- Check our frame buffer stati-    forM_ [GL_READ_FRAMEBUFFER,GL_DRAW_FRAMEBUFFER] $ \fb -> do-        status <- glCheckFramebufferStatus fb-        when (status /= GL_FRAMEBUFFER_COMPLETE) $ do-            putStrLn "incomplete framebuffer!"-            exitFailure-    -- Blit the read framebuffer into the write framebuffer-    glBlitFramebuffer x1' y1' x2' y2' 0 0 w' h' GL_COLOR_BUFFER_BIT GL_NEAREST-    clearErrors "clipTexture blit framebuffers"-    -- Cleanup-    glBindFramebuffer GL_FRAMEBUFFER 0-    withArray [fbread,fbwrite] $ glDeleteFramebuffers 2-    glBindTexture GL_TEXTURE_2D 0-    return wtex--calculateDpi :: IO Dpi-calculateDpi = do-    mMonitor <- getPrimaryMonitor--    -- Calculate the dpi of the primary monitor.-    case mMonitor of-        -- I've choosen 128 as the default DPI because of my macbook 15"-        Nothing -> return 128-        Just m  -> do (w, h) <- getMonitorPhysicalSize m-                      mvmode <- getVideoMode m-                      case mvmode of-                          Nothing -> return 128-                          Just (VideoMode vw vh _ _ _ _) -> do-                              let mm2 = fromIntegral $ w*h :: Double-                                  px  = sqrt $ (fromIntegral vw :: Double)*(fromIntegral vh)-                                  inches = sqrt $ mm2 / (25.4 * 25.4)-                              let dpi = floor $ px / inches-                              return dpi------------------------------------------------------------------------------------ Buffering, Vertex Array Objects, Uniforms, etc.----------------------------------------------------------------------------------bufferImageData :: forall a a1 a2. (Storable a2, Integral a1, Integral a) => a -> a1 -> Vector a2 -> GLenum -> GLenum -> IO ()-bufferImageData w h dat imgfmt pxfmt = unsafeWith dat $ \ptr -> do-    --glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 (fromIntegral w) (fromIntegral h)-    --glTexSubImage2D GL_TEXTURE_2D 0 0 0 (fromIntegral w) (fromIntegral h) GL_RGBA GL_UNSIGNED_BYTE (castPtr ptr)-    glTexImage2D-        GL_TEXTURE_2D-        0-        GL_RGBA-        (fromIntegral w)-        (fromIntegral h)-        0-        imgfmt-        pxfmt-        (castPtr ptr)-    err <- glGetError-    when (err /= 0) $ putStrLn $ "glTexImage2D Error: " ++ show err--withVAO :: (GLuint -> IO b) -> IO b-withVAO f = do-    [vao] <- allocaArray 1 $ \ptr -> do-        glGenVertexArrays 1 ptr-        peekArray 1 ptr-    glBindVertexArray vao-    r <- f vao-    glBindVertexArray vao-    return r--withBuffers :: Int -> ([GLuint] -> IO b) -> IO b-withBuffers n f = do-    bufs <- allocaArray n $ \ptr -> do-        glGenBuffers (fromIntegral n) ptr-        peekArray (fromIntegral n) ptr-    f bufs--bufferAttrib :: Storable a => GLuint -> GLint -> GLuint -> [a] -> IO ()-bufferAttrib loc n buf as = do-    let asize = length as * glFloatSize-    glBindBuffer GL_ARRAY_BUFFER buf-    withArray as $ \ptr ->-        glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW-    glEnableVertexAttribArray loc-    glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr--drawBuffer :: GLuint-           -> GLuint-           -> GLenum-           -> GLsizei-           -> IO ()-drawBuffer program vao mode num = do-    glUseProgram program-    glBindVertexArray vao-    clearErrors "glBindVertex"-    glDrawArrays mode 0 num-    clearErrors "glDrawArrays"--clearErrors :: String -> IO ()-clearErrors str = do-    err' <- glGetError-    when (err' /= 0) $ errorWithStackTrace $ unwords [str, show err']--glFloatSize :: Int-glFloatSize = sizeOf (undefined :: GLfloat)

@@ -1,112 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Gelatin.Core.Rendering.Font (-    compileFontCache,-    fontGeom,-    findFont,-    allFonts,-    withFontAsync,-    withFont,-    concaveTriangles-) where--import Gelatin.Core.Rendering.Types-import Gelatin.Core.Rendering.Geometrical-import Prelude hiding (init)-import Control.Concurrent.Async-import Linear-import Graphics.Text.TrueType-import qualified Data.Vector.Unboxed as UV--compileFontCache :: IO (Async FontCache)-compileFontCache = async $ do-    putStrLn "Loading font cache."-    a <- buildCache-    putStrLn "Font cache loaded."-    return a--findFont :: Async FontCache -> FontDescriptor -> IO (Maybe FilePath)-findFont afCache desc = do-    -- Get the font cache from our async container-    mfCache <- poll afCache-    -- If it has loaded check if the font in question exists-    return $ do efCache <- mfCache-                case efCache of-                    Left _      -> Nothing-                    Right cache -> findFontInCache cache desc--allFonts :: Async FontCache -> IO (Maybe [FontDescriptor])-allFonts afcache = do-    mfcache <- poll afcache-    return $ do efcache <- mfcache-                case efcache of-                    Left _ -> Nothing-                    Right fcache -> Just $ enumerateFonts fcache--withFontAsync :: Async FontCache -> FontDescriptor -> (Font -> IO a) -> IO (Maybe a)-withFontAsync afcache desc f = do-    mPath <- findFont afcache desc-    case mPath of-        Nothing -> return Nothing-        Just path -> do ef <- loadFontFile path-                        case ef of-                            Left err   -> putStrLn err >> return Nothing-                            Right font -> Just `fmap` f font--withFont :: FontCache -> FontDescriptor -> (Font -> IO a) -> IO (Maybe a)-withFont cache desc f = do-    case findFontInCache cache desc of-        Nothing -> return Nothing-        Just fp -> do ef <- loadFontFile fp-                      case ef of-                          Left err   -> putStrLn err >> return Nothing-                          Right font -> Just `fmap` f font-------------------------------------------------------------------------------------- Decomposition into triangles and beziers------------------------------------------------------------------------------------ | Ephemeral types for creating polygons from font outlines.--- Fonty gives us a [[Vector (Float, Float)]] for an entire string, which breaks down to-type Contours = [Bezier (V2 Float)] -- Beziers-type CharacterOutline = [Contours]-type StringOutline = [CharacterOutline]---- | Merges poly a into poly b by "cutting" a and inserting b.---cutMerge :: Poly -> Poly -> Poly---cutMerge as bs = (take (ndx + 1) as) ++ bs ++ [head bs] ++ (drop ndx as)---    where (ndx, _) = head $ sortBy (\a b -> snd a `compare` snd b) $---                         zip [0..] $ map (`distance` (head bs)) as--fontGeom :: Dpi -> FontString -> ([Bezier (V2 Float)], [Triangle (V2 Float)])-fontGeom dpi (FontString font px offset str) =-    let sz  = pixelSizeInPointAtDpi px dpi-        cs  = getStringCurveAtPoint dpi offset [(font, sz, str)]-        bs  = beziers cs-        ts  = concatMap (concatMap (concaveTriangles . onContourPoints)) bs-    in (concat $ concat bs,ts)--fromFonty :: (UV.Unbox b1, Functor f1, Functor f) => ([V2 b1] -> b) -> f (f1 (UV.Vector (b1, b1))) -> f (f1 b)-fromFonty f = fmap $ fmap $ f . UV.toList . UV.map (uncurry V2)--beziers :: [[UV.Vector (Float, Float)]] -> StringOutline-beziers = fromFonty (toBeziers . (fmap (fmap realToFrac)))---- | Turns a polygon into a list of triangles that can be rendered using the--- Concave Polygon Stencil Test--- @see http://www.glprogramming.com/red/chapter14.html#name13-concaveTriangles :: [a] -> [Triangle a]-concaveTriangles [] = []-concaveTriangles (a:as) = tris a as-    where tris p (p':p'':ps) = Triangle p p' p'' : tris p (p'':ps)-          tris _ _ = []---- | Collects the points that lie directly on the contour of the font--- outline.-onContourPoints :: [Bezier a] -> [a]-onContourPoints [] = []-onContourPoints ((Bezier LT a b c):bs) = [a,b,c] ++ onContourPoints bs-onContourPoints ((Bezier _ a _ c):bs) = [a,c] ++ onContourPoints bs

@@ -1,103 +0,0 @@-module Gelatin.Core.Rendering.Geometrical (-    bez,-    toLines,-    toArrows,-    toBeziers,-    trisToComp,-    triPoints,-    transform,-    transformV2,-    transformPoly,-    scale,-    translate,-    rotate,-    mat4Translate,-    mat4Rotate,-    mat4Scale-) where--import Gelatin.Core.Triangulation.Common-import Gelatin.Core.Rendering.Types-import Linear hiding (rotate)--toLines :: [a] -> [Line a]-toLines (a:b:cs) = Line a b : toLines (b:cs)-toLines _ = []--toArrows :: Floating a => [V2 a] -> [Line (V2 a)]-toArrows (a:b:cs) = arrow ++ toArrows (b:cs)-    where arrow = [ Line a b-                  , Line (b - u*l + n * w) b-                  , Line (b - u*l + n * (-w)) b-                  ]-            where n = signorm $ perp $ b - a-                  u = signorm $ b - a-                  l = 5 -- head length-                  w = 3 -- head width-toArrows _ = []--toBeziers :: (Fractional a, Ord a) => [V2 a] -> [Bezier (V2 a)]-toBeziers (a:b:c:ps) = bez a b c : toBeziers (c:ps)-toBeziers _ = []--bez :: (Ord a, Fractional a) => V2 a -> V2 a -> V2 a -> Bezier (V2 a)-bez a b c = Bezier (compare (triangleArea a b c) 0) a b c--trisToComp :: [Triangle (V2 a)] -> [V2 a]-trisToComp = concatMap triPoints--triPoints :: Triangle (V2 a) -> [V2 a]-triPoints (Triangle a b c) = [a, b, c]------------------------------------------------------------------------------------- Transformation helpers----------------------------------------------------------------------------------toM44 :: Transform -> M44 Float-toM44 (Transform (V2 x y) (V2 w h) r) = mv-    where mv = mat4Translate txy !*! rot !*! mat4Scale sxy-          sxy = V3 w h 1-          txy = V3 x y 0-          rxy = V3 0 0 1-          rot = if r /= 0 then mat4Rotate r rxy else identity--transformPoly :: Transform -> Poly -> Poly-transformPoly t p = map (transformV2 t) p--transformV2 :: Transform -> V2 Float -> V2 Float-transformV2 t (V2 x y) = V2 x' y'-    where V3 x' y' _ = transform t $ V3 x y 1--transform :: Transform -> V3 Float -> V3 Float-transform t (V3 x y z) = V3 x' y' z'-    where V4 (V1 x') (V1 y') (V1 z') _ = t' !*! V4 (V1 x) (V1 y) (V1 z) (V1 1)-          t' = toM44 t--scale :: RealFrac a => a -> a -> Transform -> Transform-scale sx sy t@Transform{tfrmScale = V2 x y} =-    t{tfrmScale = V2 (sx'*x) (sy'*y)}-        where [sx',sy'] = map realToFrac [sx,sy]--translate :: RealFrac a => a -> a -> Transform -> Transform-translate tx ty t@Transform{tfrmTranslation = V2 x y} =-    t{tfrmTranslation = V2 (x+tx') (y+ty')}-        where [tx',ty'] = map realToFrac [tx,ty]--rotate :: RealFrac a => a -> Transform -> Transform-rotate r' t@Transform{tfrmRotation = r} = t{tfrmRotation = r + realToFrac r'}------------------------------------------------------------------------------------- Matrix helpers----------------------------------------------------------------------------------mat4Translate :: Num a => V3 a -> M44 a-mat4Translate = mkTransformationMat identity--mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a-mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0)--mat4Scale :: Num a => V3 a -> M44 a-mat4Scale (V3 x y z) =-    V4 (V4 x 0 0 0)-       (V4 0 y 0 0)-       (V4 0 0 z 0)-       (V4 0 0 0 1)-

@@ -1,216 +0,0 @@-module Gelatin.Core.Rendering.Polylines where--import Gelatin.Core.Rendering.Types-import Gelatin.Core.Triangulation.Common (triangleArea)-import Linear hiding (trace)-import Debug.Trace--polygonExpand :: Float -> [V2 Float] -> [V2 Float]-polygonExpand t ps = trace (show (length ps, length vs, length poly)) poly-    where poly  = zipWith f ps vs-          f p v = p + (v ^* t)-          bows  = zip3 ps' (tail ps') (tail $ tail ps')-          vs    = map (\(a,b,c) -> perp $ tangentOf a b c) bows-          ps'   = start ++ ps ++ end-          start = case ps of-                      x:_ -> [x]-                      _   -> []-          end   = case reverse ps of-                      x:_ -> [x]-                      _   -> []---- | The polyline outline of another polyline drawn at a given thickness.-outlinePolyline :: EndCap -> LineJoin -> Float -> [V2 Float] -> [V2 Float]-outlinePolyline c j t ps = scap ++ ptans ++ ecap ++ reverse ntans ++ h-    where js = joints c j t ps-          (ptans,ntans) = both concat $ unzip $ map tangentPoints js-          both f (a,b) = (f a, f b)-          scap = case js of-                     (Cap _ xs:_) -> reverse xs-                     _            -> []-          ecap = case reverse js of-                     (Cap _ xs:_) -> reverse xs-                     _            -> []--          h = case scap of-                  h':_ -> [h']-                  _    -> []--polyline :: EndCap -> LineJoin -> Float -> [V2 Float] -> [Triangle (V2 Float)]-polyline c j t ps = triangulate $ joints c j t ps--triangulate :: [Joint] -> [Triangle (V2 Float)]--- start-triangulate (j@Cap{}:j':js) = cap ++ arm ++ (triangulate $ j':js)-    where cap   = triangulateCap j-          arm   = triangulateArm j j'--- end-triangulate [j, j'@Cap{}] = arm ++ bow ++ cap-    where arm = triangulateArm j j'-          bow = triangulateElbow j-          cap = triangulateCap j'-triangulate (j:j':js) = arm ++ bow ++ (triangulate $ j':js)-    where arm   = triangulateArm j j'-          bow   = triangulateElbow j-triangulate _ = []---- | Returns the points in a joint separated by the line's winding--- direction. Points on the side of the line in the positive tangent direction--- are `fst` and points in the negative tangent direction are `snd`.-tangentPoints :: Joint -> ([V2 Float], [V2 Float])--- There isn't enough info in a cap to provide this.-tangentPoints (Cap _ _) = ([], [])-tangentPoints (Elbow _ (p,n) []) = ([p],[n])-tangentPoints (Elbow Clockwise (p,_) ps) = ([p],ps)-tangentPoints (Elbow CounterCW (_,n) ps) = (ps,[n])--exitLine :: Joint -> (V2 Float, V2 Float)-exitLine (Cap _ ps) = (head ps, head $ reverse ps)-exitLine (Elbow _ l []) = l-exitLine (Elbow Clockwise (p,_) ps) = (p, head $ reverse ps)-exitLine (Elbow CounterCW (_,n) ps) = (head $ reverse ps, n)--entryLine :: Joint -> (V2 Float, V2 Float)-entryLine (Cap _ ps) = (head $ reverse ps, head ps)-entryLine (Elbow _ l []) = l-entryLine (Elbow Clockwise (p,_) ps) = (p, head ps)-entryLine (Elbow CounterCW (_,n) ps) = (head ps, n)--triangulateElbow :: Joint -> [Triangle (V2 Float)]-triangulateElbow (Elbow Clockwise (p,_) ps) = map (uncurry $ Triangle p) $ zip ps $ tail ps-triangulateElbow (Elbow CounterCW (_,n) ps) = map (uncurry $ Triangle n) $ zip ps $ tail ps-triangulateElbow _ = []--triangulateArm :: Joint -> Joint -> [Triangle (V2 Float)]-triangulateArm j j' = [Triangle a b c, Triangle b c d]-    where (a,b) = exitLine j-          (c,d) = entryLine j'--triangulateCap :: Joint -> [Triangle (V2 Float)]--- This is a butt cap so do nothing.-triangulateCap (Cap p ps) = map (uncurry $ Triangle p) $ zip ps $ tail ps-triangulateCap _ = []--joints :: EndCap -> LineJoin -> Float -> [V2 Float] -> [Joint]-joints _ _ _ [] = []-joints _ _ _ [_] = []-joints c j t ps@(a:b:_) = start : mid ++ [end]-    where start = capFunc c t a b-          end   = capFunc c t z y-          mid   = miters j t ps-          [z,y] = take 2 $ reverse ps--capFunc :: EndCap -> Float -> V2 Float -> V2 Float -> Joint-capFunc EndCapButt t a b = Cap a [lp,hp]-    where (lp,hp) = miterLine (capJoin t a b) a-capFunc EndCapBevel t a b = Cap a [lp,p,hp]-    where (lp,hp) = miterLine (capJoin t a b) a-          p       = a + (signorm $ a - b) ^* t-capFunc EndCapSquare t a b = Cap a [lp,p'',p',hp]-    where (lp,hp) = miterLine (capJoin t a b) a-          p       = a + (signorm $ a - b) ^* t-          p'      = p + ((signorm $ hp - a) ^* t)-          p''     = p + ((signorm $ lp - a) ^* t)-capFunc EndCapRound t a b = Cap a ps-    where ps     = map f [(pi/2) + r + (d * pi/180) | d <- [0..180]]-          V2 x y = signorm $ b - a-          r      = atan2 y x-          f th   = a + (V2 (cos th) (sin th) ^* t)--miters :: LineJoin -> Float -> [V2 Float] -> [Joint]-miters j t (a:b:c:ps) = miterFunc j t a b c : (miters j t $ b:c:ps)-miters _ _ _ = []--miterFunc :: LineJoin -> Float -> V2 Float -> V2 Float -> V2 Float -> Joint-miterFunc LineJoinMiter = miterJoint-miterFunc LineJoinBevel = bevelJoint---miterFunc LineJoinRound = roundJoint------roundJoint :: Float -> V2 Float -> V2 Float -> V2 Float -> Joint---roundJoint t a b c =---    if triangleArea a b c > 0---    then Elbow Clockwise (p,n) ps---    else Elbow CounterCW (p,n) $ reverse ps---    where j       = join t a b c---          (p,n)   = miterLine j b---          v'      = t *^ (perp ab)---          v''     = t *^ (perp bc)---          ps     = map f [r + d | d <- [0, pi/2, pi]]---          V2 x y = signorm $ v'' - v'---          r      = atan2 y x---          f th   = b + (V2 (cos th) (sin th) ^* (0.5 * distance v'' v'))---          ab     = signorm $ b - a---          bc     = signorm $ c - b--bevelJoint :: Float -> V2 Float -> V2 Float -> V2 Float -> Joint-bevelJoint t a b c =-    if triangleArea a b c >= 0-    then Elbow Clockwise (p,n) [b - v', b - v'']-    else Elbow CounterCW (p,n) [b + v', b + v'']-    where j       = join t a b c-          (p,n) = miterLine j b-          v'      = t *^ (perp ab)-          v''     = t *^ (perp bc)-          ab      = signorm $ b - a-          bc      = signorm $ c - b--miterJoint :: Float -> V2 Float -> V2 Float -> V2 Float -> Joint-miterJoint t a b c =-    if triangleArea a b c >= 0-    then Elbow Clockwise (ptan,ntan) []-    else Elbow CounterCW (ptan,ntan) []-    where j = join t a b c-          (ptan,ntan) = miterLine j b---- | Finds the miter line through a midpoint for a given join.-miterLine :: Join -> V2 Float -> (V2 Float, V2 Float)-miterLine (Join v l) p = (ptan,ntan)-    -- ptan is the point on the miterline in the direction the-    -- perpendicular tangent is pointing. ntan is in the opposite-    -- direction. This means that for clockwise winding elbows ptan-    -- will lie within the bend, on the inside of the elbow, while-    -- ntan will lie outside. This is reversed for elbows winding-    -- counter-clockwise.-    where ptan = p + v'-          ntan = p - v'-          v'   = (v ^* l)---- | Finds the joint of three points with a thickness.--- A join with a positive angle denotes an elbow that bends--- counter-clockwise. A join with a negative angle denotes an elbow that--- bends clockwise.--- The join with an angle == 0 is the join of two parallel lines.--- The join with an angle == pi is the join of two opposite but parallel--- lines, which is used to denote a line cap.-join :: Float -> V2 Float -> V2 Float -> V2 Float -> Join-join t a b c = Join v ln-    where tgnt = tangentOf a b c-          v = perp tgnt-          ln = min d $ t / (v `dot` n)-          n = signorm $ perp $ b - a-          d = min (distance (c - b) zero) (distance (b - a) zero)---- | Finds the join of a start or end line with a thickness.-capJoin :: Float -> V2 Float -> V2 Float -> Join-capJoin t a b = Join v t-    where v = signorm $ perp $ b - a---- | Finds the tangent of an elbow.-tangentOf :: V2 Float -> V2 Float -> V2 Float -> V2 Float-tangentOf a b c = signorm $ (signorm l2) + (signorm l1)-    where l1 = b - a-          l2 = c - b---- | Finds the angle between two vectors.-angleBetween :: V2 Float -> V2 Float -> Float-angleBetween v1 v2 = a - b-    where V2 x1 y1 = signorm v1-          V2 x2 y2 = signorm v2-          a = atan2 y1 x1-          b = atan2 y2 x2---- | A join is the 'miter line' that runs through the shared point of two lines--- perpendicular to their tangent.-data Join = Join { joinVector :: V2 Float-                 , joinLength :: Float-                 } deriving (Show, Eq)

@@ -1,168 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Gelatin.Core.Rendering.Types (-    Resources(..),-    runRendering,-    cleanRendering,-    Rendering(..),-    RenderDef(..),-    RenderSource(..),-    GeomRenderSource(..),-    BezRenderSource(..),-    MaskRenderSource(..),-    Transform(..),-    UniformUpdates(..),-    ClippingArea,-    Point(..),-    Line(..),-    Bezier(..),-    Triangle(..),-    FontString(..),-    EndCap(..),-    LineJoin(..),-    Joint(..),-    Winding(..),-    Fill(..),-    FillResult(..)-) where--import Linear as J hiding (rotate)-import Prelude hiding (init)-import Graphics.UI.GLFW-import Graphics.GL.Types-import Graphics.Text.TrueType hiding (CompositeScaling(..))-import Data.Time.Clock-import Data.Typeable-import Data.ByteString.Char8 (ByteString)-import Control.Concurrent.Async-import Data.IntMap (IntMap)-import Data.Map (Map)------------------------------------------------------------------------------------- Text----------------------------------------------------------------------------------data FontString = FontString Font Float (Float,Float) String------------------------------------------------------------------------------------ Coloring----------------------------------------------------------------------------------data Fill = FillColor (V2 Float -> V4 Float)-          | FillTexture FilePath (V2 Float -> V2 Float)--data FillResult = FillResultColor [V4 Float]-                | FillResultTexture GLuint [V2 Float]------------------------------------------------------------------------------------ Polylines----------------------------------------------------------------------------------data LineJoin = LineJoinMiter-              | LineJoinBevel-              deriving (Show, Eq)-data EndCap = EndCapButt-            | EndCapBevel-            | EndCapSquare-            | EndCapRound-            deriving (Show, Eq)-data Winding = Clockwise-             | CounterCW-             deriving (Show, Eq)-data Joint = Cap (V2 Float) [V2 Float]-           | Elbow Winding (V2 Float, V2 Float) [V2 Float]-           deriving (Show, Eq)------------------------------------------------------------------------------------ Drawing Primitives----------------------------------------------------------------------------------data Primitive a = PrimitiveBez (Bezier a)-                 | PrimitiveTri (Triangle a)-                 deriving (Show, Eq)--instance Functor Triangle where-    fmap f (Triangle a b c) = Triangle (f a ) (f b) (f c)--instance Functor Bezier where-    fmap f (Bezier o a b c) = Bezier o (f a) (f b) (f c)--instance Functor Line where-    fmap f (Line a b) = Line (f a) (f b)--instance Functor Point where-    fmap f (Point v) = Point $ f v--data Bezier a = Bezier Ordering a a a deriving (Show, Eq)-data Triangle a = Triangle a a a deriving (Show, Eq)-data Line a = Line a a deriving (Show, Eq)-data Point a = Point a------------------------------------------------------------------------------------ Application Resources----------------------------------------------------------------------------------data Resources = Resources { rsrcFonts     :: Async FontCache-                           , rsrcRenderings :: RenderCache-                           , rsrcSources   :: RenderSources-                           , rsrcWindow    :: Window-                           , rsrcDpi       :: Dpi-                           , rsrcUTC       :: UTCTime-                           } deriving (Typeable)------------------------------------------------------------------------------------ Special Rendering----------------------------------------------------------------------------------type ClippingArea = (V2 Int, V2 Int)------------------------------------------------------------------------------------ General Rendering----------------------------------------------------------------------------------type RenderCache = IntMap Rendering--runRendering :: Transform -> Rendering -> IO ()-runRendering t (Rendering f _) = f t--cleanRendering :: Rendering -> IO ()-cleanRendering (Rendering _ c) = c--instance Monoid Rendering where-    mempty = Rendering (const $ return ()) (return ())-    (Rendering ar ac) `mappend` (Rendering br bc) =-        Rendering (\t -> ar t >> br t) (ac >> bc)--data Rendering = Rendering RenderFunction CleanupFunction-type RenderFunction = Transform -> IO ()--type CleanupFunction = IO ()--data GeomRenderSource = GRS RenderSource-data BezRenderSource = BRS RenderSource-data MaskRenderSource = MRS RenderSource-type RenderSources = Map RenderDef RenderSource--data RenderSource = RenderSource { rsProgram    :: ShaderProgram-                                 , rsAttributes :: [(String, GLint)]-                                 } deriving (Show)--data RenderDef = RenderDefFP { rdShaderPaths :: [(String, GLuint)]-                             -- ^ [("path/to/shader.vert", GL_VERTEX_SHADER)]-                             , rdUniforms :: [String]-                             -- ^ ["projection", "modelview", ..]-                             }-               | RenderDefBS { rdShaderSrcs :: [(ByteString, GLuint)]-                             , rdUniforms :: [String]-                             } deriving (Show, Eq, Ord)------------------------------------------------------------------------------------ Affine Transformation----------------------------------------------------------------------------------instance Monoid Transform where-    mempty = Transform zero (V2 1 1) 0-    (Transform t1 s1 r1) `mappend` (Transform t2 s2 r2) = Transform (t1 + t2) (s1 * s2) (r1 + r2)--data Transform = Transform { tfrmTranslation :: Position-                           , tfrmScale       :: Scale-                           , tfrmRotation    :: Rotation-                           } deriving (Show, Typeable)--type Position = V2 Float-type Scale = V2 Float-type Rotation = Float------------------------------------------------------------------------------------ OpenGL----------------------------------------------------------------------------------type ShaderProgram = GLuint--data UniformUpdates = UniformUpdates { uuProjection :: Maybe GLint-                                     , uuModelview  :: Maybe GLint-                                     , uuSampler    :: (GLint, GLint)-                                     , uuHasUV      :: (GLint, GLint)-                                     }

@@ -1,115 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-module Gelatin.Core.Shader (-    positionLoc,-    colorLoc,-    uvLoc,-    bezLoc,-    compileShader,-    compileProgram,-    vertSourceGeom,-    fragSourceGeom,-    vertSourceBezier,-    fragSourceBezier,-    vertSourceMask,-    fragSourceMask-) where--import Prelude hiding (init)-import Prelude as P-import Graphics.GL.Core33-import Graphics.GL.Types-import Control.Monad-import System.Exit-import Foreign.Ptr-import Foreign.C.String-import Foreign.Marshal.Array-import Foreign.Marshal.Utils-import Foreign.Storable-import Data.ByteString.Char8 as B-import Data.FileEmbed--positionLoc :: GLuint-positionLoc = 0--colorLoc :: GLuint-colorLoc = 1--uvLoc :: GLuint-uvLoc = 2--bezLoc :: GLuint-bezLoc = 3--compileShader :: ByteString -> GLuint -> IO GLuint-compileShader src sh = do-    shader <- glCreateShader sh-    when (shader == 0) $ do-        B.putStrLn "could not create shader"-        exitFailure--    withCString (B.unpack src) $ \ptr ->-       with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr--    glCompileShader shader-    success <- with (0 :: GLint) $ \ptr -> do-        glGetShaderiv shader GL_COMPILE_STATUS ptr-        peek ptr--    when (success == GL_FALSE) $ do-        B.putStrLn "could not compile shader:\n"-        B.putStrLn src-        infoLog <- with (0 :: GLint) $ \ptr -> do-            glGetShaderiv shader GL_INFO_LOG_LENGTH ptr-            logsize <- peek ptr-            allocaArray (fromIntegral logsize) $ \logptr -> do-                glGetShaderInfoLog shader logsize nullPtr logptr-                peekArray (fromIntegral logsize) logptr-        P.putStrLn $ P.map (toEnum . fromEnum) infoLog-        exitFailure--    return shader--compileProgram :: [GLuint] -> IO GLuint-compileProgram shaders = do-    program <- glCreateProgram--    forM_ shaders (glAttachShader program)-    glLinkProgram program--    success <- with (0 :: GLint) $ \ptr -> do-        glGetProgramiv program GL_LINK_STATUS ptr-        peek ptr--    when (success == GL_FALSE) $ do-        B.putStrLn "could not link program"-        infoLog <- with (0 :: GLint) $ \ptr -> do-            glGetProgramiv program GL_INFO_LOG_LENGTH ptr-            logsize <- peek ptr-            allocaArray (fromIntegral logsize) $ \logptr -> do-                glGetProgramInfoLog program logsize nullPtr logptr-                peekArray (fromIntegral logsize) logptr-        P.putStrLn $ P.map (toEnum . fromEnum) infoLog-        exitFailure--    forM_ shaders glDeleteShader-    return program---vertSourceGeom :: ByteString-vertSourceGeom = $(embedFile "shaders/2d.vert")--fragSourceGeom :: ByteString-fragSourceGeom = $(embedFile "shaders/2d.frag")--vertSourceBezier :: ByteString-vertSourceBezier = $(embedFile "shaders/bezier.vert")--fragSourceBezier :: ByteString-fragSourceBezier = $(embedFile "shaders/bezier.frag")--vertSourceMask :: ByteString-vertSourceMask = $(embedFile "shaders/mask.vert")--fragSourceMask :: ByteString-fragSourceMask = $(embedFile "shaders/mask.frag")

@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Strokes are used for defining lines and drawing them.+module Gelatin.Core.Stroke where++import           Data.Maybe   (fromMaybe)+import           GHC.Generics (Generic)++data LineCap = LineCapNone+             | LineCapButt+             | LineCapSquare+             | LineCapRound+             | LineCapTriOut+             | LineCapTriIn+             deriving (Show, Ord, Eq, Enum, Generic)++data Stroke = Stroke { strokeWidth    :: Float+                     , strokeFeather  :: Float+                     , strokeLineCaps :: (LineCap,LineCap)+                     } deriving (Show, Eq, Generic)++data StrokeAttr = StrokeNone+                | StrokeWidth Float+                | StrokeFeather Float+                | StrokeCaps (LineCap,LineCap)+                deriving (Show, Eq, Generic)++defaultStroke :: Stroke+defaultStroke = Stroke 1 1 (LineCapRound,LineCapRound)++strokeAttr :: Maybe Stroke -> StrokeAttr -> Maybe Stroke+strokeAttr _ StrokeNone               = Nothing+strokeAttr Nothing c                  = strokeAttr (Just defaultStroke) c+strokeAttr (Just s) (StrokeWidth w)   = Just $ s {strokeWidth = w}+strokeAttr (Just s) (StrokeFeather t) = Just $ s {strokeFeather = t}+strokeAttr (Just s) (StrokeCaps cs)   = Just $ s {strokeLineCaps = cs}++strokeWith :: [StrokeAttr] -> Stroke+strokeWith atts = fromMaybe defaultStroke $ foldl strokeAttr Nothing atts

@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Limited spatial transformations in 2 and 3 dimensions.+module Gelatin.Core.Transform where++import           Data.Foldable (foldl')+import           Linear        (Epsilon (..), M44, V1 (..), V2 (..),+                                V3 (..), V4 (..), axisAngle, identity,+                                mkTransformation, mkTransformationMat, (!*!))+--------------------------------------------------------------------------------+-- Affine Transformation+--------------------------------------------------------------------------------+data Affine a r = Translate a+                | Scale a+                | Rotate r+                deriving (Show, Eq)++type Affine2 a = Affine (V2 a) a++type Affine3 a = Affine (V3 a) (a, V3 a)++-- | Promotes a point in R2 to a point in R3 by setting the z coord to '0'.+promoteV2 :: Num a => V2 a -> V3 a+promoteV2 (V2 x y) = V3 x y 0++-- | Demotes a point in R3 to a point in R2 by discarding the z coord.+demoteV3 :: V3 a -> V2 a+demoteV3 (V3 x y _) = V2 x y++-- | Promotes an affine transformation in R2 to one in R3 by using `promoteV2`+-- in case of translation or scaling, and promotes rotation as a rotation about+-- the z axis.+promoteAffine2 :: Num a => Affine2 a -> Affine3 a+promoteAffine2 (Translate v2) = Translate $ promoteV2 v2+promoteAffine2 (Scale v2)     = Scale $ promoteV2 v2+promoteAffine2 (Rotate r)     = Rotate (r, V3 0 0 1)++affine3Modelview :: (Num a, Real a, Floating a, Epsilon a)+                 => Affine3 a -> M44 a+affine3Modelview (Translate v)     = mat4Translate v+affine3Modelview (Scale v)         = mat4Scale v+affine3Modelview (Rotate (r,axis)) = mat4Rotate r axis++affine2Modelview :: (Num a, Real a, Floating a, Epsilon a)+                 => Affine2 a -> M44 a+affine2Modelview = affine3Modelview . promoteAffine2++affine2sModelview :: (Num a, Real a, Floating a, Epsilon a)+                => [Affine2 a] -> M44 a+affine2sModelview = foldl' f identity+    where f mv a = (mv !*!) $ affine2Modelview a++transformV2 :: Num a => M44 a -> V2 a ->  V2 a+transformV2 mv = demoteV3 . m41ToV3 . (mv !*!) . v3ToM41 . promoteV2++transformPoly :: M44 Float -> [V2 Float] -> [V2 Float]+transformPoly t = map (transformV2 t)++transformV3 :: RealFloat a => M44 a -> V3 a -> V3 a+transformV3 t v = m41ToV3 $ t !*! v3ToM41 v++v3ToM41 :: Num a => V3 a -> V4 (V1 a)+v3ToM41 (V3 x y z) = V4 (V1 x) (V1 y) (V1 z) (V1 1)++m41ToV3 :: V4 (V1 a) -> V3 a+m41ToV3 (V4 (V1 x) (V1 y) (V1 z) _) = V3 x y z++rotateAbout :: (Num a, Epsilon a, Floating a) => V3 a -> a -> V3 a -> V3 a+rotateAbout axis phi = m41ToV3 . (mat4Rotate phi axis !*!) . v3ToM41+--------------------------------------------------------------------------------+-- Matrix helpers+--------------------------------------------------------------------------------+mat4Translate :: Num a => V3 a -> M44 a+mat4Translate = mkTransformationMat identity++mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a+mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0)++mat4Scale :: Num a => V3 a -> M44 a+mat4Scale (V3 x y z) =+    V4 (V4 x 0 0 0)+       (V4 0 y 0 0)+       (V4 0 0 z 0)+       (V4 0 0 0 1)

@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+module Gelatin.Core.Triangle where++import           Data.Vector.Unboxed (Unbox, Vector)+import qualified Data.Vector.Unboxed as V+import           Gelatin.Core.Bezier+import           Gelatin.Core.Bounds+import           Linear++type Triangle a = (a,a,a)++trisToComp :: Unbox a => Vector (Triangle (V2 a)) -> Vector (V2 a)+trisToComp = V.concatMap triPoints++triPoints :: Unbox a => Triangle (V2 a) -> Vector (V2 a)+triPoints (a,b,c) = V.fromList [a, b, c]++bezToTri :: Bezier a -> Triangle a+bezToTri (_,a,b,c) = (a,b,c)++triToPath :: Unbox a => Triangle a -> Vector a+triToPath (a,b,c) = V.fromList [a,b,c]++fmapTriangle :: (t -> t1) -> (t, t, t) -> (t1, t1, t1)+fmapTriangle f (a,b,c) = (f a, f b, f c)++triBounds :: Triangle (V2 Float) -> BBox+triBounds (a,b,c) = boundingBox $ V.fromList [a,b,c]+--------------------------------------------------------------------------------+-- Decomposing things into triangles+--------------------------------------------------------------------------------+sizeToTris :: V2 Float -> Vector (Triangle (V2 Float))+sizeToTris (V2 w h) = V.fromList [(a,b,c), (a,c,d)]+    where [a,b,c,d] = [V2 (-hw) (-hh), V2 hw (-hh), V2 hw hh, V2 (-hw) hh]+          (hw,hh) = (w/2,h/2)

@@ -1,61 +0,0 @@-module Gelatin.Core.Triangulation.Common where--import Linear-import Control.Lens--type Poly = [V2 Float]--signedArea :: Num a => [V2 a] -> a-signedArea = signedAreaOfPoints--signedAreaOfPoints :: Num a => [V2 a] -> a-signedAreaOfPoints lst =-  sum [x1 * y2 - x2 * y1 | (V2 x1 y1, V2 x2 y2) <- zip lst $ rotateLeft lst]--rotateLeft :: [a] -> [a]-rotateLeft [] = []-rotateLeft (x:xs) = xs ++ [x]---- | returns True iff the first point of the first polygon is inside the second poylgon-insidePoly :: Poly -> Poly -> Bool-insidePoly poly1 poly2 | null poly1 = False-                       | null poly2 = False-                       | otherwise  = and $ map (`pointInside` poly2) poly1---- | A point is inside a polygon if it has an odd number of intersections with the boundary (Jordan Curve theorem)-pointInside :: (V2 Float) -> Poly -> Bool-pointInside = flip pathHasPoint---- | Determine if a point lies within a polygon path using the even/odd--- rule.-pathHasPoint :: (R1 f, R2 f, Ord a, Fractional a) => [f a] -> f a -> Bool-pathHasPoint [] _ = False-pathHasPoint poly@(p1':_) p' = pointInPath' False p' (poly ++ [p1'])-    where pointInPath' :: (R1 f, R2 f, Ord a, Fractional a) => Bool -> f a -> [f a] -> Bool-          pointInPath' c _ []  = c-          pointInPath' c _ [_] = c-          pointInPath' c p (p1:p2:ps) = pointInPath' (test p p1 p2 $ c) p (p2:ps)-          test :: (R2 f, Ord a, Fractional a) => f a -> f a -> f a -> (Bool -> Bool)-          test p p1 p2 = if t1 p p1 p2 && t2 p p1 p2 then not else id-          t1 :: (R2 f, Ord a) => f a -> f a -> f a -> Bool-          t1 p p1 p2 = (y p2 > y p) /= (y p1 > y p)-          t2 :: (R1 f, R2 f, Ord a, Fractional a) => f a -> f a -> f a -> Bool-          t2 p p1 p2 = x p < (x p1 - x p2) * (y p - y p2) / (y p1 - y p2) + x p2-          x v = v ^. _x-          y v = v ^. _y----- |return a list containing lists of every element with its neighbour--- i.e. [e1,e2,e3] -> [ [e1,e2], [e2,e3], [e3, e1] ]-cycleNeighbours :: [a] -> [[a]]-cycleNeighbours xs | null xs = []-                   | otherwise = cycleN (head xs) xs--cycleN :: a -> [a] -> [[a]]-cycleN f xs | length xs >= 2 = cons ([head xs, head (tail xs)]) (cycleN f (tail xs))-            | otherwise      = [[head xs, f]] -- if the upper doesn't match close cycle---triangleArea :: Fractional a => V2 a -> V2 a -> V2 a -> a-triangleArea (V2 x2 y2) (V2 x0 y0) (V2 x1 y1) = (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)-

@@ -1,35 +0,0 @@-module Gelatin.Core.Triangulation.EarClipping where--import Gelatin.Core.Rendering.Types-import Gelatin.Core.Triangulation.Common-import Linear--triangulate :: [V2 Float] -> [Triangle (V2 Float)]-triangulate ps = triangulate' [] $ clean ps-    where triangulate' ts ps'-              | (p1:p2:p3:[]) <- ps' = Triangle p1 p2 p3 :ts-              | (p1:p2:p3:rest) <- ps' =-                  let isReflex = area p1 p2 p3 >= 0-                  in if isReflex && (not $ any (`pointInside` [p1,p2,p3]) rest)-                     then triangulate' (ts ++ [Triangle p1 p2 p3]) $ p1:p3:rest-                     -- Cycle through and check the next triangle-                     else triangulate' ts $ p2:p3:rest ++ [p1]-              | otherwise = ts-          clean = removeHeadTail . removeColinears--removeHeadTail :: Eq a => [a] -> [a]-removeHeadTail [] = []-removeHeadTail xs = if head xs == last xs then Prelude.init xs else xs--removeColinears :: (Fractional a, Eq a) => [V2 a] -> [V2 a]-removeColinears (a:b:c:ds) = if area a b c == 0-                             then a: (removeColinears $ c:ds)-                             else a:b: (removeColinears $ c:ds)-removeColinears vs = vs--area :: Fractional a => V2 a -> V2 a -> V2 a -> a-area (V2 ax ay) (V2 bx by) (V2 cx cy) =-    0.5 * det33 (V3 (V3 ax ay 1)-                    (V3 bx by 1)-                    (V3 cx cy 1))-

@@ -1,77 +0,0 @@--- |--- Module    : Triangulation.KET--- Copyright :(C) 1997, 1998, 2008 Joern Dinkla, www.dinkla.net------ Updates by Schell Scivally------ Triangulation of simple polygons after Kong, Everett, Toussaint 91--- with some changes by T.Vogt: return indices instead of coordinates of triangles and Data.Vector instead of lists------ see---     Joern Dinkla, Geometrische Algorithmen in Haskell, Diploma Thesis,---     University of Bonn, Germany, 1998.-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-module Gelatin.Core.Triangulation.KET (triangulate) where--import Linear-import Data.Vector (Vector)-import qualified Data.Vector as V-import Data.List ( (\\) )--type V2i = (V2 Float,Int)--toV2 = V.map (\(x,_) -> x)--triangulate :: RealFrac a => [V2 a] -> [(V2 a, V2 a, V2 a)]-triangulate vs = map (\(a,b,c) -> ((vec' V.! a), (vec' V.! b), (vec' V.! c))) ndxs-    where vec' = V.map (fmap realToFrac) vec-          vec  = V.fromList $ map (fmap realToFrac) vs-          ndxs = triangulation vec--triangulation :: Vector (V2 Float) -> [(Int,Int,Int)]-triangulation points | (V.length vertices) > 3 = scan vs stack rs-              | otherwise = []-  where vertices = V.zip points (V.generate (V.length points) id)-        [p1,p2,p3] = V.toList (V.take 3 vertices)-        qs         = V.drop 3 vertices-        vs         = qs V.++ (V.singleton p1)-        stack      = V.fromList [p3, p2, p1, V.last vertices]-        rs         = reflexVertices (angles vertices)--scan :: Vector V2i -> Vector V2i -> Vector V2i -> [(Int,Int,Int)]-scan vs stack rs | V.null vs            = []-                 | V.length vs == 1     = [(snd (V.head stack), snd (V.head (V.tail stack)), snd (V.head vs))]-                 | V.length stack == 3  = scan (V.tail vs) (V.cons (V.head vs) stack) rs-                 | isEar rs x_m x_i x_p = (snd x_p, snd x_i, snd x_m) : (scan vs (V.cons x_p ss') rs')-                 | otherwise            = scan (V.tail vs) (V.cons (V.head vs) stack) rs-  where [x_p, x_i, x_m] = V.toList (V.take 3 stack)-        ss' = V.drop 2 stack-        rs'   = V.fromList $ (V.toList rs) \\ (isConvex x_m x_p (V.head vs) ++-                                               isConvex (V.head (V.tail ss')) x_m x_p)-        isConvex (im,_) (i,ii) (ip,_) = if isLeftTurn im i ip then [(i,ii)] else []--isEar :: Vector V2i -> V2i -> V2i -> V2i -> Bool-isEar rs (m,_) (x,_) (p,_) | V.null rs = True-                           | otherwise = isLeftTurn m x p && not (V.any ( (m,x,p) `containsBNV`) (toV2 rs))--reflexVertices  :: Vector (V2i,V2i,V2i) -> Vector V2i-reflexVertices as | V.null as             = V.empty-                  | isRightTurnOrOn m x p = V.cons (x,xi) $ reflexVertices (V.tail as)-                  | otherwise             =                 reflexVertices (V.tail as)-  where ((m,_),(x,xi),(p,_)) = V.head as--containsBNV (s,t,v) p    = (a==b && b==c)-  where a                = isLeftTurn s t p-        b                = isLeftTurn t v p-        c                = isLeftTurn v s p--angles :: Vector a -> Vector (a,a,a)-angles xs = V.zip3 (rotateR xs) xs (rotateL xs)--rotateL xs = (V.tail xs) V.++ (V.singleton (V.head xs))-rotateR xs = (V.singleton (V.last xs)) V.++ (V.init xs)--isRightTurnOrOn m x p = (area2 m x p) <= 0-isLeftTurn :: (V2 Float) -> (V2 Float) -> (V2 Float) -> Bool-isLeftTurn      m x p = (area2 m x p) > 0-area2 (V2 x2 y2) (V2 x0 y0) (V2 x1 y1) = (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)

@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+module Gelatin.Core.Utils where++import           Data.Vector.Unboxed (Unbox, Vector)+import qualified Data.Vector.Unboxed as V+import           Linear++-- | Determine if a point lies within a polygon path using the even/odd+-- rule.+-- A point is inside a path if it has an odd number of intersections with+-- the boundary (Jordan Curve theorem)+pathHasPoint :: (Ord a, Fractional a, Unbox a) => Vector (V2 a) -> V2 a -> Bool+pathHasPoint vs v = V.foldr' (\s a -> if s then not a else a) False $+  V.zipWith3 f vv vs (V.drop 1 vs)+  where vv = V.replicate (V.length vs) v+        f a b c = t1 a b c && t2 a b c+        t1 p p1 p2 = (y p2 > y p) /= (y p1 > y p)+        t2 p p1 p2 = x p < (x p1 - x p2) * (y p - y p2) / (y p1 - y p2) + x p2+        x (V2 a _) = a+        y (V2 _ b) = b

@@ -0,0 +1,59 @@+module Gelatin.Picture (+  -- * Defining Vertex Data+    VerticesT(..)+  , runVerticesT+  , Vertices+  , runVertices+  , tri+  , bez+  , to+  , addVertexList+  , segment+  , mapVertices+  -- * Making shapes+  , module S+  -- * Defining Geometry (Vertex Data + Drawing Operation)+  , RawGeometry(..)+  , mapRawGeometry+  , GeometryT(..)+  , runGeometryT+  , Geometry+  , runGeometry+  , triangles+  , beziers+  , strip+  , fan+  , line+  , mapGeometry+  -- * The Picture API+  , PictureT+  , runPictureT+  , Picture+  , runPicture+  , setRawGeometry+  , getRawGeometry+  , setGeometry+  , setStroke+  , getStroke+  , setTextures+  , getTextures+  , setRenderingOptions+  , getRenderingOptions+  -- * Measuring Pictures (2d)+  , mapToSpaceVec+  , pictureBounds2+  , pictureSize2+  , pictureOrigin2+  , pictureCenter2+  -- * Measuring Pictures (3d)+  , pictureBounds3+  , pictureSize3+  , pictureOrigin3+  , pictureCenter3+  -- * Underlying PictureData Exported for renderers+  , RenderingOption(..)+  , PictureData(..)+) where++import           Gelatin.Picture.Internal+import           Gelatin.Picture.Shapes   as S

@@ -0,0 +1,279 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Gelatin.Picture.Internal where++import           Control.Arrow+import           Control.Lens               hiding (to)+import           Control.Monad.IO.Class+import           Control.Monad.State.Strict+import qualified Data.Vector                as B+import           Data.Vector.Unboxed        (Unbox, Vector)+import qualified Data.Vector.Unboxed        as V+import           Gelatin.Core+import           Linear                     hiding (rotate)++--------------------------------------------------------------------------------+-- A Monad for defining vertex data+--------------------------------------------------------------------------------+newtype VerticesT a m b = Vertices { unVertices :: StateT (Vector a) m b }+type Vertices a = VerticesT a Identity ()++instance Functor m => Functor (VerticesT a m) where+  fmap f (Vertices s) = Vertices $ fmap f s++instance Monad m => Applicative (VerticesT a m) where+  pure = Vertices . pure+  (Vertices f) <*> (Vertices x) = Vertices $ f <*> x++instance Monad m => Monad (VerticesT a m) where+  return = pure+  (Vertices m) >>= f = Vertices $ m >>= unVertices . f++instance MonadTrans (VerticesT a) where+  lift = Vertices . lift++instance MonadIO m => MonadIO (VerticesT a m) where+  liftIO = lift . liftIO+--------------------------------------------------------------------------------+-- Pretty General Operators+--------------------------------------------------------------------------------+snoc3 :: Unbox a => Vector a -> a -> a -> a -> Vector a+snoc3 v a b = V.snoc (V.snoc (V.snoc v a) b)++tri :: (Monad m, Unbox a) => a -> a -> a -> VerticesT a m ()+tri a b c = Vertices $ modify $ \v -> snoc3 v a b c++bez :: (Monad m, Unbox a) => a -> a -> a -> VerticesT a m ()+bez = tri++to :: (Monad m, Unbox a) => a -> VerticesT a m ()+to = Vertices . modify . flip V.snoc++segment :: (Monad m, Unbox a) => a -> a -> VerticesT a m ()+segment a b = to a >> to b++addVertexList :: (Monad m, Unbox a) => [a] -> VerticesT a m ()+addVertexList ys = Vertices $ do+  xs <- get+  put $ xs V.++ V.fromList ys++runVerticesT :: (Monad m, Unbox a) => VerticesT a m b -> m (Vector a)+runVerticesT = flip execStateT V.empty . unVertices++runVertices :: Unbox a => Vertices a -> Vector a+runVertices = runIdentity . runVerticesT++mapVertices :: (Monad m, Unbox a, Unbox c)+            => (a -> c) -> VerticesT a m b -> VerticesT c m ()+mapVertices f s = Vertices $ do+  vs <- lift $ runVerticesT s+  put $ V.map f vs+--------------------------------------------------------------------------------+-- Mixing drawing types and transforming them+--------------------------------------------------------------------------------+data RawGeometry a = RawTriangles (Vector a)+                   | RawBeziers (Vector a)+                   | RawTriangleStrip (Vector a)+                   | RawTriangleFan (Vector a)+                   | RawLine (Vector a)++mapRawGeometry :: (Unbox a, Unbox b) => (a -> b) -> RawGeometry a -> RawGeometry b+mapRawGeometry f (RawTriangles vs)     = RawTriangles $ V.map f vs+mapRawGeometry f (RawBeziers vs)       = RawBeziers $ V.map f vs+mapRawGeometry f (RawTriangleStrip vs) = RawTriangleStrip $ V.map f vs+mapRawGeometry f (RawTriangleFan vs)   = RawTriangleFan $ V.map f vs+mapRawGeometry f (RawLine vs)          = RawLine $ V.map f vs+--------------------------------------------------------------------------------+-- A Monad for defining geometry+--------------------------------------------------------------------------------+newtype GeometryT a m b =+  Geometry { unGeometry :: StateT (B.Vector (RawGeometry a)) m b}+type Geometry a = GeometryT a Identity ()++instance Functor m => Functor (GeometryT a m) where+  fmap f (Geometry s) = Geometry $ fmap f s++instance Monad m => Applicative (GeometryT a m) where+  pure = Geometry . pure+  (Geometry f) <*> (Geometry x) = Geometry $ f <*> x++instance Monad m => Monad (GeometryT a m) where+  return = pure+  (Geometry m) >>= f = Geometry $ m >>= unGeometry . f++instance MonadTrans (GeometryT a) where+  lift = Geometry . lift++instance MonadIO m => MonadIO (GeometryT a m) where+  liftIO = lift . liftIO++add :: Monad m => RawGeometry a -> StateT (B.Vector (RawGeometry a)) m ()+add a = modify (`B.snoc` a)++triangles :: (Unbox a, Monad m) => VerticesT a m () -> GeometryT a m ()+triangles vs = Geometry $ do+  v <- lift $ runVerticesT vs+  add $ RawTriangles v++beziers :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m ()+beziers vs = Geometry $ do+  v <- lift $ runVerticesT vs+  add $ RawBeziers v++strip :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m ()+strip vs = Geometry $ do+  v <- lift $ runVerticesT vs+  add $ RawTriangleStrip v++fan :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m ()+fan vs = Geometry $ do+  v <- lift $ runVerticesT vs+  add $ RawTriangleFan v++line :: (Monad m, Unbox a) => VerticesT a m () -> GeometryT a m ()+line vs = Geometry $ do+  v <- lift $ runVerticesT vs+  add $ RawLine v++runGeometryT :: Monad m => GeometryT a m b -> m (B.Vector (RawGeometry a))+runGeometryT = flip execStateT B.empty . unGeometry++runGeometry :: Geometry a -> B.Vector (RawGeometry a)+runGeometry = runIdentity . runGeometryT++mapGeometry :: (Monad m, Unbox a, Unbox c)+            => (a -> c) -> GeometryT a m b -> GeometryT c m ()+mapGeometry f s = Geometry $ do+  gs <- lift $ runGeometryT s+  put $ B.map (mapRawGeometry f) gs++vertexData :: RawGeometry v -> Vector v+vertexData (RawTriangles vs)     = vs+vertexData (RawBeziers vs)       = vs+vertexData (RawTriangleStrip vs) = vs+vertexData (RawTriangleFan vs)   = vs+vertexData (RawLine vs)          = vs+--------------------------------------------------------------------------------+-- Special Rendering Options+--------------------------------------------------------------------------------+data RenderingOption = StencilMaskOption+--------------------------------------------------------------------------------+-- Picture Data+--------------------------------------------------------------------------------+data PictureData texture vertex =+  PictureData { _picDataGeometry :: B.Vector (RawGeometry vertex)+              -- ^ This picture's vertex data.+              , _picDataStroke   :: [StrokeAttr]+              -- ^ The stroke attributes to use for drawing lines.+              , _picDataTextures :: [texture]+              -- ^ All the textures needed to render this picture's vertex data.+              , _picDataOptions  :: [RenderingOption]+              -- ^ Any special drawing options to apply when rendering this+              -- picture.+              }+makeLenses ''PictureData+--------------------------------------------------------------------------------+-- Helpers for Common Picture Types+--------------------------------------------------------------------------------+emptyPictureData :: PictureData t v+emptyPictureData =+    PictureData { _picDataGeometry   = B.empty+                , _picDataStroke    = []+                , _picDataTextures  = []+                , _picDataOptions   = []+                }++bothToFrac :: (Real a, Fractional b) => (V2 a, V2 a) -> (V2 b, V2 b)+bothToFrac= second (fmap realToFrac) . first (fmap realToFrac)+--------------------------------------------------------------------------------+-- Picture Construction+--------------------------------------------------------------------------------+type PictureT tex vert = StateT (PictureData tex vert)++runPictureT :: PictureT t v m a -> m (a, PictureData t v)+runPictureT = flip runStateT emptyPictureData+--------------------------------------------------------------------------------+-- Identity Parameterized Pictures+--------------------------------------------------------------------------------+type Picture t v = PictureT t v Identity++runPicture :: Picture t v a -> (a, PictureData t v)+runPicture = runIdentity . runPictureT++setRawGeometry :: Monad m => B.Vector (RawGeometry v) -> PictureT t v m ()+setRawGeometry vs = picDataGeometry .= vs++getRawGeometry :: Monad m => PictureT t v m (B.Vector (RawGeometry v))+getRawGeometry = use picDataGeometry++setGeometry :: Monad m => GeometryT v m () -> PictureT t v m ()+setGeometry = (setRawGeometry =<<) . lift . runGeometryT++setStroke :: Monad m => [StrokeAttr] -> PictureT t v m ()+setStroke = (picDataStroke .=)++getStroke :: Monad m => PictureT t v m [StrokeAttr]+getStroke = use picDataStroke++setTextures :: Monad m => [t] -> PictureT t v m ()+setTextures = (picDataTextures .=)++getTextures :: Monad m => PictureT t v m [t]+getTextures = use picDataTextures++setRenderingOptions :: Monad m => [RenderingOption] -> PictureT t v m ()+setRenderingOptions = (picDataOptions .=)++getRenderingOptions :: Monad m => PictureT t v m [RenderingOption]+getRenderingOptions = use picDataOptions+--------------------------------------------------------------------------------+-- Measuring pictures+--------------------------------------------------------------------------------+mapToSpaceVec :: (Monad m, Unbox v, Unbox s)+               => (v -> s) -> PictureT t v m (V.Vector s)+mapToSpaceVec vertToSpace = do+  gs <- use picDataGeometry+  let f = V.map vertToSpace . vertexData . (gs B.!)+  return $ V.concatMap f $ V.enumFromTo 0 (B.length gs - 1)++pictureBounds2 :: (Monad m, Unbox v)+               => (v -> V2 Float) -> PictureT t v m (V2 Float, V2 Float)+pictureBounds2 = (boundingBox <$>) . mapToSpaceVec++pictureBounds3 :: (Monad m, Unbox v)+               => (v -> V3 Float) -> PictureT t v m BCube+pictureBounds3 = (boundingCube <$>) . mapToSpaceVec++pictureSize2 :: (Monad m, Unbox v)+             => (v -> V2 Float) -> PictureT t v m (V2 Float)+pictureSize2 = pictureBounds2 >=> (return . uncurry (flip (-)))++pictureSize3 :: (Monad m, Unbox v)+             => (v -> V3 Float) -> PictureT t v m (V3 Float)+pictureSize3 = pictureBounds3 >=> (return . uncurry (flip (-)))++pictureOrigin2 :: (Monad m, Unbox v)+               => (v -> V2 Float) -> PictureT t v m (V2 Float)+pictureOrigin2 = (fst <$>) . pictureBounds2++pictureOrigin3 :: (Monad m, Unbox v)+               => (v -> V3 Float) -> PictureT t v m (V3 Float)+pictureOrigin3 = (fst <$>) . pictureBounds3++pictureCenter2 :: (Monad m, Unbox v)+               => (v -> V2 Float) -> PictureT t v m (V2 Float)+pictureCenter2 vertToSpace = do+  (tl,br) <- pictureBounds2 vertToSpace+  return $ tl + (br - tl)/2++pictureCenter3 :: (Monad m, Unbox v)+               => (v -> V3 Float) -> PictureT t v m (V3 Float)+pictureCenter3 vertToSpace = do+  (tl,br) <- pictureBounds3 vertToSpace+  return $ tl + (br - tl)/2

@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Gelatin.Picture.Shapes where++import           Control.Monad.State.Strict+import           Data.Vector.Unboxed        (Unbox)+import qualified Data.Vector.Unboxed        as V+import           Gelatin.Core+import           Gelatin.Picture.Internal+import           Linear                     hiding (rotate)+--------------------------------------------------------------------------------+-- Shapes (at the level of Vertices)+--------------------------------------------------------------------------------+curve :: (RealFloat a, Unbox a, Monad m)+      => V2 a -> V2 a -> V2 a+      -> VerticesT (V2 a) m ()+curve a b c =+  let vs  = subdivideAdaptive 100 0 $ bez3 a b c+  in Vertices $ modify (V.++ vs)++corner :: (RealFloat a, Unbox a, Monad m)+      => a -> a -> VerticesT (V2 a) m ()+corner xr yr =+  let vs = cleanSeqDupes $ V.concatMap (subdivideAdaptive 100 0) $ cornerBez3 xr yr+  in Vertices $ modify (V.++ vs)++arc :: (Unbox a, Epsilon a, RealFloat a, Monad m)+    => a -> a -> a -> a -> VerticesT (V2 a) m ()+arc w h start stop =+  let vs = cleanSeqDupes $ V.concatMap (subdivideAdaptive 100 0) $ arcBez3 w h start stop+  in Vertices $ modify (V.++ vs)++rectangle :: (Unbox a, Monad m)+          => V2 a -> V2 a -> VerticesT (V2 a) m ()+rectangle tl@(V2 tlx tly) br@(V2 brx bry) = do+  to tl+  to $ V2 brx tly+  to br+  to $ V2 tlx bry