gelatin (empty) → 0.0.0.0
raw patch · 14 files changed
+2148/−0 lines, 14 filesdep +FontyFruitydep +GLFW-bdep +JuicyPixelssetup-changed
Dependencies added: FontyFruity, GLFW-b, JuicyPixels, async, base, bytestring, containers, directory, file-embed, gelatin-core, gl, lens, linear, time, vector
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- gelatin.cabal +119/−0
- src/Example.hs +30/−0
- src/Gelatin/Core/Color.hs +447/−0
- src/Gelatin/Core/Rendering.hs +642/−0
- src/Gelatin/Core/Rendering/Font.hs +112/−0
- src/Gelatin/Core/Rendering/Geometrical.hs +103/−0
- src/Gelatin/Core/Rendering/Polylines.hs +216/−0
- src/Gelatin/Core/Rendering/Types.hs +169/−0
- src/Gelatin/Core/Shader.hs +115/−0
- src/Gelatin/Core/Triangulation/Common.hs +61/−0
- src/Gelatin/Core/Triangulation/EarClipping.hs +35/−0
- src/Gelatin/Core/Triangulation/KET.hs +77/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Schell Scivally++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gelatin.cabal view
@@ -0,0 +1,119 @@+-- 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.0++-- 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.2.++-- The license under which the package is released.+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:++category: Graphics++build-type: Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+-- extra-source-files:++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/schell/gelatin++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++ -- 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++ -- 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-core -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++ default-language: Haskell2010
+ src/Example.hs view
@@ -0,0 +1,30 @@+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
+ src/Gelatin/Core/Color.hs view
@@ -0,0 +1,447 @@+module Gelatin.Core.Color where++import Linear+import Data.Bits+import Gelatin.Core.Rendering.Types (Fill(..))++solid :: V4 Float -> Fill+solid = FillColor . const++maroon :: (Num a, Fractional a) => V4 a+maroon = V4 (128/255) (0/255) (0/255) 1++red :: (Num a, Fractional a) => V4 a+red = V4 (255/255) (0/255) (0/255) 1++orange :: (Num a, Fractional a) => V4 a+orange = V4 (255/255) (165/255) (0/255) 1++yellow :: (Num a, Fractional a) => V4 a+yellow = V4 (255/255) (255/255) (0/255) 1++olive :: (Num a, Fractional a) => V4 a+olive = V4 (128/255) (128/255) (0/255) 1++green :: (Num a, Fractional a) => V4 a+green = V4 0 (128/255) (0/255) 1++purple :: (Num a, Fractional a) => V4 a+purple = V4 (128/255) (0/255) (128/255) 1++fuchsia :: (Num a, Fractional a) => V4 a+fuchsia = V4 (255/255) (0/255) (255/255) 1++lime :: (Num a, Fractional a) => V4 a+lime = V4 0 (255/255) (0/255) 1++teal :: (Num a, Fractional a) => V4 a+teal = V4 0 (128/255) (128/255) 1++aqua :: (Num a, Fractional a) => V4 a+aqua = V4 0 (255/255) (255/255) 1++blue :: (Num a, Fractional a) => V4 a+blue = V4 0 (0/255) (255/255) 1++navy :: (Num a, Fractional a) => V4 a+navy = V4 0 (0/255) (128/255) 1++black :: (Num a, Fractional a) => V4 a+black = V4 0 (0/255) (0/255) 1++gray :: (Num a, Fractional a) => V4 a+gray = V4 (128/255) (128/255) (128/255) 1++grey :: (Num a, Fractional a) => V4 a+grey = gray++silver :: (Num a, Fractional a) => V4 a+silver = V4 (192/255) (192/255) (192/255) 1++white :: (Num a, Fractional a) => V4 a+white = V4 (255/255) (255/255) (255/255) 1++indianRed :: (Num a, Fractional a) => V4 a+indianRed = V4 (205/255) (92/255) (92/255) 1++lightCoral :: (Num a, Fractional a) => V4 a+lightCoral = V4 (240/255) (128/255) (128/255) 1++salmon :: (Num a, Fractional a) => V4 a+salmon = V4 (250/255) (128/255) (114/255) 1++darkSalmon :: (Num a, Fractional a) => V4 a+darkSalmon = V4 (233/255) (150/255) (122/255) 1++lightSalmon :: (Num a, Fractional a) => V4 a+lightSalmon = V4 (255/255) (160/255) (122/255) 1++crimson :: (Num a, Fractional a) => V4 a+crimson = V4 (220/255) (20/255) (60/255) 1++fireBrick :: (Num a, Fractional a) => V4 a+fireBrick = V4 (178/255) (34/255) (34/255) 1++darkRed :: (Num a, Fractional a) => V4 a+darkRed = V4 (139/255) (0/255) (0/255) 1++pink :: (Num a, Fractional a) => V4 a+pink = V4 (255/255) (192/255) (203/255) 1++lightPink :: (Num a, Fractional a) => V4 a+lightPink = V4 (255/255) (182/255) (193/255) 1++hotPink :: (Num a, Fractional a) => V4 a+hotPink = V4 (255/255) (105/255) (180/255) 1++deepPink :: (Num a, Fractional a) => V4 a+deepPink = V4 (255/255) (20/255) (147/255) 1++mediumVioletRed :: (Num a, Fractional a) => V4 a+mediumVioletRed = V4 (199/255) (21/255) (133/255) 1++paleVioletRed :: (Num a, Fractional a) => V4 a+paleVioletRed = V4 (219/255) (112/255) (147/255) 1++coral :: (Num a, Fractional a) => V4 a+coral = V4 (255/255) (127/255) (80/255) 1++tomato :: (Num a, Fractional a) => V4 a+tomato = V4 (255/255) (99/255) (71/255) 1++orangeRed :: (Num a, Fractional a) => V4 a+orangeRed = V4 (255/255) (69/255) (0/255) 1++darkOrange :: (Num a, Fractional a) => V4 a+darkOrange = V4 (255/255) (140/255) (0/255) 1++gold :: (Num a, Fractional a) => V4 a+gold = V4 (255/255) (215/255) (0/255) 1++lightYellow :: (Num a, Fractional a) => V4 a+lightYellow = V4 (255/255) (255/255) (224/255) 1++lemonChiffon :: (Num a, Fractional a) => V4 a+lemonChiffon = V4 (255/255) (250/255) (205/255) 1++lightGoldenrodYellow :: (Num a, Fractional a) => V4 a+lightGoldenrodYellow = V4 (250/255) (250/255) (210/255) 1++papayaWhip :: (Num a, Fractional a) => V4 a+papayaWhip = V4 (255/255) (239/255) (213/255) 1++moccasin :: (Num a, Fractional a) => V4 a+moccasin = V4 (255/255) (228/255) (181/255) 1++peachPuff :: (Num a, Fractional a) => V4 a+peachPuff = V4 (255/255) (218/255) (185/255) 1++paleGoldenrod :: (Num a, Fractional a) => V4 a+paleGoldenrod = V4 (238/255) (232/255) (170/255) 1++khaki :: (Num a, Fractional a) => V4 a+khaki = V4 (240/255) (230/255) (140/255) 1++darkKhaki :: (Num a, Fractional a) => V4 a+darkKhaki = V4 (189/255) (183/255) (107/255) 1++lavender :: (Num a, Fractional a) => V4 a+lavender = V4 (230/255) (230/255) (250/255) 1++thistle :: (Num a, Fractional a) => V4 a+thistle = V4 (216/255) (191/255) (216/255) 1++plum :: (Num a, Fractional a) => V4 a+plum = V4 (221/255) (160/255) (221/255) 1++violet :: (Num a, Fractional a) => V4 a+violet = V4 (238/255) (130/255) (238/255) 1++orchid :: (Num a, Fractional a) => V4 a+orchid = V4 (218/255) (112/255) (214/255) 1++magenta :: (Num a, Fractional a) => V4 a+magenta = V4 (255/255) (0/255) (255/255) 1++mediumOrchid :: (Num a, Fractional a) => V4 a+mediumOrchid = V4 (186/255) (85/255) (211/255) 1++mediumPurple :: (Num a, Fractional a) => V4 a+mediumPurple = V4 (147/255) (112/255) (219/255) 1++amethyst :: (Num a, Fractional a) => V4 a+amethyst = V4 (153/255) (102/255) (204/255) 1++blueViolet :: (Num a, Fractional a) => V4 a+blueViolet = V4 (138/255) (43/255) (226/255) 1++darkViolet :: (Num a, Fractional a) => V4 a+darkViolet = V4 (148/255) (0/255) (211/255) 1++darkOrchid :: (Num a, Fractional a) => V4 a+darkOrchid = V4 (153/255) (50/255) (204/255) 1++darkMagenta :: (Num a, Fractional a) => V4 a+darkMagenta = V4 (139/255) (0/255) (139/255) 1++indigo :: (Num a, Fractional a) => V4 a+indigo = V4 (75/255) (0/255) (130/255) 1++slateBlue :: (Num a, Fractional a) => V4 a+slateBlue = V4 (106/255) (90/255) (205/255) 1++darkSlateBlue :: (Num a, Fractional a) => V4 a+darkSlateBlue = V4 (72/255) (61/255) (139/255) 1++mediumSlateBlue :: (Num a, Fractional a) => V4 a+mediumSlateBlue = V4 (123/255) (104/255) (238/255) 1++greenYellow :: (Num a, Fractional a) => V4 a+greenYellow = V4 (173/255) (255/255) (47/255) 1++chartreuse :: (Num a, Fractional a) => V4 a+chartreuse = V4 (127/255) (255/255) (0/255) 1++lawnGreen :: (Num a, Fractional a) => V4 a+lawnGreen = V4 (124/255) (252/255) (0/255) 1++limeGreen :: (Num a, Fractional a) => V4 a+limeGreen = V4 (50/255) (205/255) (50/255) 1++paleGreen :: (Num a, Fractional a) => V4 a+paleGreen = V4 (152/255) (251/255) (152/255) 1++lightGreen :: (Num a, Fractional a) => V4 a+lightGreen = V4 (144/255) (238/255) (144/255) 1++mediumSpringGreen :: (Num a, Fractional a) => V4 a+mediumSpringGreen = V4 0 (250/255) (154/255) 1++springGreen :: (Num a, Fractional a) => V4 a+springGreen = V4 0 (255/255) (127/255) 1++mediumSeaGreen :: (Num a, Fractional a) => V4 a+mediumSeaGreen = V4 (60/255) (179/255) (113/255) 1++seaGreen :: (Num a, Fractional a) => V4 a+seaGreen = V4 (46/255) (139/255) (87/255) 1++forestGreen :: (Num a, Fractional a) => V4 a+forestGreen = V4 (34/255) (139/255) (34/255) 1++darkGreen :: (Num a, Fractional a) => V4 a+darkGreen = V4 0 (100/255) (0/255) 1++yellowGreen :: (Num a, Fractional a) => V4 a+yellowGreen = V4 (154/255) (205/255) (50/255) 1++oliveDrab :: (Num a, Fractional a) => V4 a+oliveDrab = V4 (107/255) (142/255) (35/255) 1++darkOliveGreen :: (Num a, Fractional a) => V4 a+darkOliveGreen = V4 (85/255) (107/255) (47/255) 1++mediumAquamarine :: (Num a, Fractional a) => V4 a+mediumAquamarine = V4 (102/255) (205/255) (170/255) 1++darkSeaGreen :: (Num a, Fractional a) => V4 a+darkSeaGreen = V4 (143/255) (188/255) (143/255) 1++lightSeaGreen :: (Num a, Fractional a) => V4 a+lightSeaGreen = V4 (32/255) (178/255) (170/255) 1++darkCyan :: (Num a, Fractional a) => V4 a+darkCyan = V4 0 (139/255) (139/255) 1++cyan :: (Num a, Fractional a) => V4 a+cyan = V4 0 (255/255) (255/255) 1++lightCyan :: (Num a, Fractional a) => V4 a+lightCyan = V4 (224/255) (255/255) (255/255) 1++paleTurquoise :: (Num a, Fractional a) => V4 a+paleTurquoise = V4 (175/255) (238/255) (238/255) 1++aquamarine :: (Num a, Fractional a) => V4 a+aquamarine = V4 (127/255) (255/255) (212/255) 1++turquoise :: (Num a, Fractional a) => V4 a+turquoise = V4 (64/255) (224/255) (208/255) 1++mediumTurquoise :: (Num a, Fractional a) => V4 a+mediumTurquoise = V4 (72/255) (209/255) (204/255) 1++darkTurquoise :: (Num a, Fractional a) => V4 a+darkTurquoise = V4 0 (206/255) (209/255) 1++cadetBlue :: (Num a, Fractional a) => V4 a+cadetBlue = V4 (95/255) (158/255) (160/255) 1++steelBlue :: (Num a, Fractional a) => V4 a+steelBlue = V4 (70/255) (130/255) (180/255) 1++lightSteelBlue :: (Num a, Fractional a) => V4 a+lightSteelBlue = V4 (176/255) (196/255) (222/255) 1++powderBlue :: (Num a, Fractional a) => V4 a+powderBlue = V4 (176/255) (224/255) (230/255) 1++lightBlue :: (Num a, Fractional a) => V4 a+lightBlue = V4 (173/255) (216/255) (230/255) 1++skyBlue :: (Num a, Fractional a) => V4 a+skyBlue = V4 (135/255) (206/255) (235/255) 1++lightSkyBlue :: (Num a, Fractional a) => V4 a+lightSkyBlue = V4 (135/255) (206/255) (250/255) 1++deepSkyBlue :: (Num a, Fractional a) => V4 a+deepSkyBlue = V4 0 (191/255) (255/255) 1++dodgerBlue :: (Num a, Fractional a) => V4 a+dodgerBlue = V4 (30/255) (144/255) (255/255) 1++cornflowerBlue :: (Num a, Fractional a) => V4 a+cornflowerBlue = V4 (100/255) (149/255) (237/255) 1++royalBlue :: (Num a, Fractional a) => V4 a+royalBlue = V4 (65/255) (105/255) (225/255) 1++mediumBlue :: (Num a, Fractional a) => V4 a+mediumBlue = V4 0 (0/255) (205/255) 1++darkBlue :: (Num a, Fractional a) => V4 a+darkBlue = V4 0 (0/255) (139/255) 1++midnightBlue :: (Num a, Fractional a) => V4 a+midnightBlue = V4 (25/255) (25/255) (112/255) 1++cornsilk :: (Num a, Fractional a) => V4 a+cornsilk = V4 (255/255) (248/255) (220/255) 1++blanchedAlmond :: (Num a, Fractional a) => V4 a+blanchedAlmond = V4 (255/255) (235/255) (205/255) 1++bisque :: (Num a, Fractional a) => V4 a+bisque = V4 (255/255) (228/255) (196/255) 1++navajoWhite :: (Num a, Fractional a) => V4 a+navajoWhite = V4 (255/255) (222/255) (173/255) 1++wheat :: (Num a, Fractional a) => V4 a+wheat = V4 (245/255) (222/255) (179/255) 1++burlyWood :: (Num a, Fractional a) => V4 a+burlyWood = V4 (222/255) (184/255) (135/255) 1++tan :: (Num a, Fractional a) => V4 a+tan = V4 (210/255) (180/255) (140/255) 1++rosyBrown :: (Num a, Fractional a) => V4 a+rosyBrown = V4 (188/255) (143/255) (143/255) 1++sandyBrown :: (Num a, Fractional a) => V4 a+sandyBrown = V4 (244/255) (164/255) (96/255) 1++goldenrod :: (Num a, Fractional a) => V4 a+goldenrod = V4 (218/255) (165/255) (32/255) 1++darkGoldenrod :: (Num a, Fractional a) => V4 a+darkGoldenrod = V4 (184/255) (134/255) (11/255) 1++peru :: (Num a, Fractional a) => V4 a+peru = V4 (205/255) (133/255) (63/255) 1++chocolate :: (Num a, Fractional a) => V4 a+chocolate = V4 (210/255) (105/255) (30/255) 1++saddleBrown :: (Num a, Fractional a) => V4 a+saddleBrown = V4 (139/255) (69/255) (19/255) 1++sienna :: (Num a, Fractional a) => V4 a+sienna = V4 (160/255) (82/255) (45/255) 1++brown :: (Num a, Fractional a) => V4 a+brown = V4 (165/255) (42/255) (42/255) 1++snow :: (Num a, Fractional a) => V4 a+snow = V4 (255/255) (250/255) (250/255) 1++honeydew :: (Num a, Fractional a) => V4 a+honeydew = V4 (240/255) (255/255) (240/255) 1++mintCream :: (Num a, Fractional a) => V4 a+mintCream = V4 (245/255) (255/255) (250/255) 1++azure :: (Num a, Fractional a) => V4 a+azure = V4 (240/255) (255/255) (255/255) 1++aliceBlue :: (Num a, Fractional a) => V4 a+aliceBlue = V4 (240/255) (248/255) (255/255) 1++ghostWhite :: (Num a, Fractional a) => V4 a+ghostWhite = V4 (248/255) (248/255) (255/255) 1++whiteSmoke :: (Num a, Fractional a) => V4 a+whiteSmoke = V4 (245/255) (245/255) (245/255) 1++seashell :: (Num a, Fractional a) => V4 a+seashell = V4 (255/255) (245/255) (238/255) 1++beige :: (Num a, Fractional a) => V4 a+beige = V4 (245/255) (245/255) (220/255) 1++oldLace :: (Num a, Fractional a) => V4 a+oldLace = V4 (253/255) (245/255) (230/255) 1++floralWhite :: (Num a, Fractional a) => V4 a+floralWhite = V4 (255/255) (250/255) (240/255) 1++ivory :: (Num a, Fractional a) => V4 a+ivory = V4 (255/255) (255/255) (240/255) 1++antiqueWhite :: (Num a, Fractional a) => V4 a+antiqueWhite = V4 (250/255) (235/255) (215/255) 1++linen :: (Num a, Fractional a) => V4 a+linen = V4 (250/255) (240/255) (230/255) 1++lavenderBlush :: (Num a, Fractional a) => V4 a+lavenderBlush = V4 (255/255) (240/255) (245/255) 1++mistyRose :: (Num a, Fractional a) => V4 a+mistyRose = V4 (255/255) (228/255) (225/255) 1++gainsboro :: (Num a, Fractional a) => V4 a+gainsboro = V4 (220/255) (220/255) (220/255) 1++lightGrey :: (Num a, Fractional a) => V4 a+lightGrey = V4 (211/255) (211/255) (211/255) 1++darkGray :: (Num a, Fractional a) => V4 a+darkGray = V4 (169/255) (169/255) (169/255) 1++dimGray :: (Num a, Fractional a) => V4 a+dimGray = V4 (105/255) (105/255) (105/255) 1++lightSlateGray :: (Num a, Fractional a) => V4 a+lightSlateGray = V4 (119/255) (136/255) (153/255) 1++slateGray :: (Num a, Fractional a) => V4 a+slateGray = V4 (112/255) (128/255) (144/255) 1++darkSlateGray :: (Num a, Fractional a) => V4 a+darkSlateGray = V4 (47/255) (79/255) (79/255) 1++transparent :: (Num a, 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++hex :: (Num b, Fractional b) => Int -> V4 b+hex n = fmap ((/255) . fromIntegral) $ V4 r g b a+ where r = n `shiftR` 24+ g = n `shiftR` 16 .&. 0xFF+ b = n `shiftR` 8 .&. 0xFF+ a = n .&. 0xFF
+ src/Gelatin/Core/Rendering.hs view
@@ -0,0 +1,642 @@+{-# 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)
+ src/Gelatin/Core/Rendering/Font.hs view
@@ -0,0 +1,112 @@+{-# 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
+ src/Gelatin/Core/Rendering/Geometrical.hs view
@@ -0,0 +1,103 @@+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)+
+ src/Gelatin/Core/Rendering/Polylines.hs view
@@ -0,0 +1,216 @@+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)
+ src/Gelatin/Core/Rendering/Types.hs view
@@ -0,0 +1,169 @@+{-# 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+ -- | LineJoinRound+ 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)+ }
+ src/Gelatin/Core/Shader.hs view
@@ -0,0 +1,115 @@+{-# 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")
+ src/Gelatin/Core/Triangulation/Common.hs view
@@ -0,0 +1,61 @@+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)+
+ src/Gelatin/Core/Triangulation/EarClipping.hs view
@@ -0,0 +1,35 @@+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))+
+ src/Gelatin/Core/Triangulation/KET.hs view
@@ -0,0 +1,77 @@+-- |+-- 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)