diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/app/Example.hs b/app/Example.hs new file mode 100644 --- /dev/null +++ b/app/Example.hs @@ -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" diff --git a/docimages/demoteCubic.png b/docimages/demoteCubic.png new file mode 100644 Binary files /dev/null and b/docimages/demoteCubic.png differ diff --git a/gelatin.cabal b/gelatin.cabal --- a/gelatin.cabal +++ b/gelatin.cabal @@ -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 diff --git a/shaders/2d.frag b/shaders/2d.frag deleted file mode 100644 --- a/shaders/2d.frag +++ /dev/null @@ -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; - } -} diff --git a/shaders/2d.vert b/shaders/2d.vert deleted file mode 100644 --- a/shaders/2d.vert +++ /dev/null @@ -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); -} diff --git a/shaders/bezier.frag b/shaders/bezier.frag deleted file mode 100644 --- a/shaders/bezier.frag +++ /dev/null @@ -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); -} diff --git a/shaders/bezier.vert b/shaders/bezier.vert deleted file mode 100644 --- a/shaders/bezier.vert +++ /dev/null @@ -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); -} diff --git a/shaders/mask.frag b/shaders/mask.frag deleted file mode 100644 --- a/shaders/mask.frag +++ /dev/null @@ -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); -} diff --git a/shaders/mask.vert b/shaders/mask.vert deleted file mode 100644 --- a/shaders/mask.vert +++ /dev/null @@ -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); -} diff --git a/src/Example.hs b/src/Example.hs deleted file mode 100644 --- a/src/Example.hs +++ /dev/null @@ -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 diff --git a/src/Gelatin.hs b/src/Gelatin.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin.hs @@ -0,0 +1,27 @@ +-- | +-- Module: Gelatin +-- Copyright: (c) 2017 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- [@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) diff --git a/src/Gelatin/Compiler.hs b/src/Gelatin/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Compiler.hs @@ -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. +-------------------------------------------------------------------------------- + diff --git a/src/Gelatin/Core.hs b/src/Gelatin/Core.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core.hs @@ -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 diff --git a/src/Gelatin/Core/Bezier.hs b/src/Gelatin/Core/Bezier.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core/Bezier.hs @@ -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. +-- +-- <> +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 diff --git a/src/Gelatin/Core/Bounds.hs b/src/Gelatin/Core/Bounds.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core/Bounds.hs @@ -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] diff --git a/src/Gelatin/Core/Color.hs b/src/Gelatin/Core/Color.hs --- a/src/Gelatin/Core/Color.hs +++ b/src/Gelatin/Core/Color.hs @@ -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 diff --git a/src/Gelatin/Core/Polyline.hs b/src/Gelatin/Core/Polyline.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core/Polyline.hs @@ -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 diff --git a/src/Gelatin/Core/Rendering.hs b/src/Gelatin/Core/Rendering.hs deleted file mode 100644 --- a/src/Gelatin/Core/Rendering.hs +++ /dev/null @@ -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) diff --git a/src/Gelatin/Core/Rendering/Font.hs b/src/Gelatin/Core/Rendering/Font.hs deleted file mode 100644 --- a/src/Gelatin/Core/Rendering/Font.hs +++ /dev/null @@ -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 diff --git a/src/Gelatin/Core/Rendering/Geometrical.hs b/src/Gelatin/Core/Rendering/Geometrical.hs deleted file mode 100644 --- a/src/Gelatin/Core/Rendering/Geometrical.hs +++ /dev/null @@ -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) - diff --git a/src/Gelatin/Core/Rendering/Polylines.hs b/src/Gelatin/Core/Rendering/Polylines.hs deleted file mode 100644 --- a/src/Gelatin/Core/Rendering/Polylines.hs +++ /dev/null @@ -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) diff --git a/src/Gelatin/Core/Rendering/Types.hs b/src/Gelatin/Core/Rendering/Types.hs deleted file mode 100644 --- a/src/Gelatin/Core/Rendering/Types.hs +++ /dev/null @@ -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) - } diff --git a/src/Gelatin/Core/Shader.hs b/src/Gelatin/Core/Shader.hs deleted file mode 100644 --- a/src/Gelatin/Core/Shader.hs +++ /dev/null @@ -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") diff --git a/src/Gelatin/Core/Stroke.hs b/src/Gelatin/Core/Stroke.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core/Stroke.hs @@ -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 diff --git a/src/Gelatin/Core/Transform.hs b/src/Gelatin/Core/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core/Transform.hs @@ -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) diff --git a/src/Gelatin/Core/Triangle.hs b/src/Gelatin/Core/Triangle.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core/Triangle.hs @@ -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) diff --git a/src/Gelatin/Core/Triangulation/Common.hs b/src/Gelatin/Core/Triangulation/Common.hs deleted file mode 100644 --- a/src/Gelatin/Core/Triangulation/Common.hs +++ /dev/null @@ -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) - diff --git a/src/Gelatin/Core/Triangulation/EarClipping.hs b/src/Gelatin/Core/Triangulation/EarClipping.hs deleted file mode 100644 --- a/src/Gelatin/Core/Triangulation/EarClipping.hs +++ /dev/null @@ -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)) - diff --git a/src/Gelatin/Core/Triangulation/KET.hs b/src/Gelatin/Core/Triangulation/KET.hs deleted file mode 100644 --- a/src/Gelatin/Core/Triangulation/KET.hs +++ /dev/null @@ -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) diff --git a/src/Gelatin/Core/Utils.hs b/src/Gelatin/Core/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Core/Utils.hs @@ -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 diff --git a/src/Gelatin/Picture.hs b/src/Gelatin/Picture.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Picture.hs @@ -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 diff --git a/src/Gelatin/Picture/Internal.hs b/src/Gelatin/Picture/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Picture/Internal.hs @@ -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 diff --git a/src/Gelatin/Picture/Shapes.hs b/src/Gelatin/Picture/Shapes.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/Picture/Shapes.hs @@ -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