├── .gitignore ├── .sosrc ├── .travis.yml ├── LICENSE ├── README.md ├── cabal.project ├── gelatin-example ├── .sosrc ├── LICENSE ├── README.md ├── Setup.hs ├── assets │ ├── Neuton-Regular.ttf │ ├── OFL.txt │ └── tex.jpg ├── gelatin-example.cabal └── src │ └── Main.hs ├── gelatin-freetype2 ├── LICENSE ├── Setup.hs ├── app │ └── Main.hs ├── gelatin-freetype2.cabal ├── sosrc-dev ├── src │ └── Gelatin │ │ ├── FreeType2.hs │ │ └── FreeType2 │ │ ├── Internal.hs │ │ └── Utils.hs └── test │ └── Spec.hs ├── gelatin-fruity ├── LICENSE ├── Setup.hs ├── gelatin-fruity.cabal ├── sosrc-dev └── src │ └── Gelatin │ └── Fruity.hs ├── gelatin-gl ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Example.hs ├── gelatin-gl.cabal ├── sosrc-dev ├── src │ └── Gelatin │ │ ├── GL.hs │ │ └── GL │ │ ├── Common.hs │ │ ├── Compiler.hs │ │ ├── Renderer.hs │ │ ├── Shader.hs │ │ └── TH.hs └── stack80-ghcjs.yaml ├── gelatin-glfw ├── .sosrc ├── LICENSE ├── README.md ├── Setup.hs ├── gelatin-glfw.cabal └── src │ └── Gelatin │ └── GLFW.hs ├── gelatin-sdl2 ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── gelatin-sdl2.cabal ├── img │ └── lava.png ├── sosrc-dev └── src │ └── Gelatin │ └── SDL2.hs ├── gelatin-shaders ├── LICENSE ├── Setup.hs ├── gelatin-shaders.cabal ├── shaders │ ├── simple2d.frag │ ├── simple2d.vert │ ├── simple2dwebgl.frag │ ├── simple2dwebgl.vert │ ├── simple3d.frag │ └── simple3d.vert ├── sosrc-dev └── src │ └── Gelatin │ ├── Shaders.hs │ └── Shaders │ ├── Common.hs │ ├── Simple2D.hs │ ├── System.hs │ ├── TypeLevel.hs │ └── ` ├── gelatin-webgl ├── .sosrc ├── LICENSE ├── Setup.hs ├── app │ ├── ImageData.hs │ └── Main.hs ├── gelatin-webgl.cabal ├── src │ ├── Gelatin │ │ ├── WebGL.hs │ │ └── WebGL │ │ │ ├── Common.hs │ │ │ ├── Renderer.hs │ │ │ └── Shaders.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── gelatin ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Example.hs ├── docimages │ ├── demoteCubic.png │ └── twobeziers.png ├── gelatin.cabal ├── sosrc-dev ├── src │ ├── Gelatin.hs │ └── Gelatin │ │ ├── Compiler.hs │ │ ├── Core.hs │ │ ├── Core │ │ ├── Bezier.hs │ │ ├── Bounds.hs │ │ ├── Color.hs │ │ ├── CommonOld.hs │ │ ├── Font.hs │ │ ├── Polyline.hs │ │ ├── Stroke.hs │ │ ├── Transform.hs │ │ ├── Triangle.hs │ │ └── Utils.hs │ │ ├── Picture.hs │ │ └── Picture │ │ ├── Internal.hs │ │ └── Shapes.hs └── stack80-ghcjs.yaml ├── screenshot.png └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist* 2 | *.hi 3 | *.o 4 | *.sqlite3 5 | .cabal-sandbox 6 | cabal.sandbox.config 7 | cabal.config 8 | */.stack-work/ 9 | .stack-work/ 10 | *.sw[a-z] 11 | *.hp 12 | *.prof 13 | *.tags 14 | *.out 15 | *.tmp 16 | .DS_Store 17 | .projectile 18 | TAGS 19 | *.#* 20 | -------------------------------------------------------------------------------- /.sosrc: -------------------------------------------------------------------------------- 1 | #- patterns: 2 | # - ([^\/]*)\/(.*\.hs)$ 3 | # commands: 4 | # - stack build --fast --executable-profiling --library-profiling --ghc-options="-fprof-auto -fprof-cafs" 5 | # - stack exec hlint \0 6 | # - cd gelatin-example; stack exec gelatin-example -- +RTS -hc -p -sstderr -xc -N 7 | ## - ./pack-profiling.sh gelatin-example/gelatin-example 8 | #- patterns: 9 | # - .*\.vert$ 10 | # - .*\.frag$ 11 | # commands: 12 | # - stack build --fast --executable-profiling --library-profiling --ghc-options="-fprof-auto -fprof-cafs" 13 | # - cd gelatin-example; stack exec gelatin-example -- +RTS -hc -p -sstderr -xc -N 14 | # - ./pack-profiling.sh gelatin-example/gelatin-example 15 | #- patterns: 16 | # - ([^\/]*)\/(.*\.cabal)$ 17 | # commands: 18 | # - stack build --fast --executable-profiling --library-profiling --ghc-options="-fprof-auto -fprof-cafs" 19 | # - stack exec hlint \0 20 | 21 | # Stackage/Hackage preparation 22 | - patterns: 23 | - .*\.l?hs$ 24 | - .*\.cabal$ 25 | commands: 26 | #- cd gelatin-example; stack --resolver lts-1 --install-ghc build --fast # for ghc 7.6 27 | #- cd gelatin-example; stack --resolver lts-2 --install-ghc build --fast # for ghc 7.8 28 | - cd gelatin-example; stack --resolver lts-3 --install-ghc build --fast # for ghc 7.10.2 29 | #- cd gelatin-example; stack --resolver lts-5 --install-ghc build --fast # for ghc 7.10.3 30 | #- cd gelatin-example; stack --resolver nightly --install-ghc build --fast 31 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.ghc 11 | - $HOME/.cabal 12 | - $HOME/.stack 13 | - $HOME/.stack-work 14 | 15 | # The different configurations we want to test. We have BUILD=cabal which uses 16 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 17 | # of those below. 18 | # 19 | # We set the compiler values here to tell Travis to use a different 20 | # cache file per set of arguments. 21 | # 22 | # If you need to have different apt packages for each combination in the 23 | # matrix, you can use a line such as: 24 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 25 | matrix: 26 | include: 27 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 28 | # https://github.com/hvr/multi-ghc-travis 29 | # Quick metadata check 30 | - env: BUILD=meta CABALVER=2.2 31 | compiler: ": #cabal" 32 | addons: {apt: {packages: [cabal-install-2.2], sources: [hvr-ghc]}} 33 | 34 | # build with cabal new-build 35 | # TODO: Fix build errors on GHC cabal new-build 36 | # Once the errors are fixed we can put these back in un-allowed failures 37 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 38 | compiler: ": #GHC 7.10.3" 39 | addons: 40 | apt: 41 | update: true 42 | packages: [cabal-install-2.2,ghc-7.10.3,happy-1.19.5,alex-3.1.7] 43 | sources: [hvr-ghc] 44 | - env: BUILD=cabal GHCVER=8.0.1 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 45 | compiler: ": #GHC 8.0.1" 46 | addons: 47 | apt: 48 | packages: [cabal-install-2.2,ghc-8.0.1,happy-1.19.5,alex-3.1.7] 49 | sources: [hvr-ghc] 50 | update: true 51 | - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 52 | compiler: ": #GHC 8.2.2" 53 | addons: 54 | apt: 55 | packages: [cabal-install-2.2,ghc-8.2.2,happy-1.19.5,alex-3.1.7] 56 | sources: [hvr-ghc] 57 | update: true 58 | - env: BUILD=cabal GHCVER=8.4.3 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 59 | compiler: ": #GHC 8.4.3" 60 | addons: 61 | apt: 62 | packages: [cabal-install-2.2,ghc-8.4.3,happy-1.19.5,alex-3.1.7] 63 | sources: [hvr-ghc] 64 | update: true 65 | 66 | # Build with the newest GHC and cabal-install. This is an accepted failure, 67 | # see below. 68 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 69 | compiler: ": #GHC HEAD" 70 | addons: 71 | apt: 72 | packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7] 73 | sources: [hvr-ghc] 74 | update: true 75 | 76 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 77 | # variable, such as using --stack-yaml to point to a different file. 78 | - env: BUILD=stack ARGS="" 79 | compiler: ": #stack default" 80 | addons: 81 | apt: 82 | packages: [ghc-7.10.3] 83 | sources: [hvr-ghc] 84 | update: true 85 | 86 | # Build on OS X in addition to Linux 87 | - env: BUILD=stack ARGS="" 88 | compiler: ": #stack default osx" 89 | os: osx 90 | - env: BUILD=cabal 91 | compiler: ": #GHC default osx" 92 | os: osx 93 | 94 | allow_failures: 95 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 96 | - env: BUILD=stack ARGS="" 97 | os: linux 98 | 99 | before_install: 100 | # Using compiler above sets CC to an invalid value, so unset it 101 | - unset CC 102 | 103 | # We want to always allow newer versions of packages when building on GHC HEAD 104 | - CABALARGS="" 105 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 106 | 107 | # Download and unpack the stack executable 108 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 109 | - mkdir -p ~/.local/bin 110 | - | 111 | if [ `uname` = "Darwin" ] 112 | then 113 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 114 | travis_retry brew update 115 | brew install ghc cabal-install sdl2 116 | else 117 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 118 | fi 119 | 120 | # Download, make and install SDL2-2.0.8 (stable) 121 | - | 122 | travis_retry curl -L https://www.libsdl.org/release/SDL2-2.0.8.tar.gz | tar xz 123 | cd SDL2-2.0.8 124 | ./configure 125 | make 126 | sudo make install 127 | 128 | - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 129 | 130 | install: 131 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 132 | - if [ -f configure.ac ]; then autoreconf -i; fi 133 | - | 134 | set -ex 135 | case "$BUILD" in 136 | stack) 137 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 138 | ;; 139 | meta) 140 | cabal --version 141 | ;; 142 | cabal) 143 | cabal --version 144 | travis_retry cabal update 145 | cabal new-build --only-dependencies $CABALARGS all 146 | ;; 147 | esac 148 | set +ex 149 | 150 | script: 151 | - | 152 | set -ex 153 | case "$BUILD" in 154 | stack) 155 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 156 | ;; 157 | meta) 158 | for dir in $PACKAGES 159 | do 160 | pushd $dir 161 | cabal check 162 | cabal sdist 163 | popd 164 | done 165 | ;; 166 | cabal) 167 | cabal new-build $CABALARGS all 168 | cabal new-test $CABALARGS all 169 | # cabal new-bench $CABALARGS all # uncomment when/if we add benchmarks 170 | ;; 171 | esac 172 | set +ex 173 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | gelatin 2 | ======= 3 | [![Build Status](https://travis-ci.org/schell/gelatin.svg?branch=master)](https://travis-ci.org/schell/gelatin) 4 | 5 | This is a mega-repo for a real-time graphics renderer in Haskell. 6 | 7 | ![Screenshot](screenshot.png) 8 | 9 | 10 | libraries 11 | --------- 12 | 13 | ### [gelatin (core)](https://github.com/schell/gelatin/tree/master/gelatin) 14 | * Backend definitions 15 | * Primitives for drawing 16 | * triangles 17 | * triangle strips 18 | * triangle fans 19 | * beziers (fill below curve) + inverted beziers (fill above curve) 20 | * thick, feathered stroked lines and for creating new backends. 21 | * Definitions and functions for post compilation affine transformation, 22 | color multiply, red channel replacement (for font textures) 23 | 24 | ### [gelatin-gl](https://github.com/schell/gelatin/tree/master/gelatin-gl) 25 | Backend for compiling `gelatin` pictures using OpenGL. 26 | 27 | ### [gelatin-freetype2](https://github.com/schell/gelatin/tree/master/gelatin-freetype2) 28 | `freetype2` text using character atlases and word maps for fast rendering. Use 29 | this if your text changes frequently but does not often get resized. It is fast to 30 | compile renderings but unless the text is rendered with a large character size, scaling up 31 | the rendering will show pixels. 32 | 33 | ### [gelatin-fruity](https://github.com/schell/gelatin/tree/master/gelatin-fruity) 34 | Functions for extracting truetype font geometry as `gelatin` primitives. Use this 35 | if your text resizes frequently but otherwise does not change. It is slow to compile 36 | renderings but once compiled those renderings can be displayed at any scale. 37 | 38 | ### [gelatin-sdl2](https://github.com/schell/gelatin/tree/master/gelatin-sdl2) 39 | SDL2 initialization and windowing. 40 | 41 | ### [gelatin-webgl](https://github.com/schell/gelatin/tree/master/gelatin-webgl) 42 | WebGL backend via ghcjs (experimental) 43 | 44 | 45 | examples 46 | -------- 47 | For examples please see 48 | [gelatin-example](https://github.com/schell/gelatin/tree/master/gelatin-example) 49 | and 50 | [odin](https://github.com/schell/odin) 51 | 52 | 53 | install 54 | ------- 55 | `gelatin` depends on 56 | 57 | * [sdl2](http://libsdl.org) 58 | * [freetype2](https://www.freetype.org/index.html) 59 | 60 | You can install them with the following platform specific steps. 61 | 62 | ### Mac OS X 63 | 64 | Using [homebrew](https://brew.sh/)... 65 | 66 | brew install freetype 67 | brew install sdl2 68 | 69 | ### Ubuntu 70 | First install freetype2 71 | 72 | apt-get install libfreetype6 73 | 74 | The [sdl2 bindings](https://github.com/haskell-game/sdl2) require an sdl2 75 | install >= 2.0.4, or for special instructions to be followed. Assuming you're 76 | on `Ubuntu >= 16.04`, you can simply run 77 | 78 | apt-get install libsdl2-dev 79 | 80 | otherwise please visit the link above and install via their README. 81 | 82 | ### Windows 10 with MSYS2/MINGW 83 | 84 | pacman -S mingw-w64-x86_64-pkg-config mingw-w64-x86_64-freetype mingw-w64-x86_64-SDL2 85 | 86 | 87 | building source 88 | --------------- 89 | The easiest way to get up and running on the Haskell toolchain is to download 90 | [stack](https://docs.haskellstack.org/en/stable/README/). All of gelatin's projects 91 | are spec'd out with stack.yaml build files, so picking the correct versions of 92 | libraries is not needed if you follow the stack path. 93 | 94 | git clone https://github.com/schell/gelatin.git 95 | 96 | cd gelatin 97 | 98 | If you just installed stack, run 99 | 100 | stack setup 101 | 102 | Go make some ☕ and then... 103 | 104 | stack build 105 | 106 | Note on Windows that if you run into [this error](https://github.com/commercialhaskell/stack/issues/3492) 107 | 108 | ghc-pkg.EXE: C:\sr\snapshots\3c4ad812\pkgdb\package.cache: you don't have 109 | permission to modify this file 110 | 111 | You can simply run `stack build` over and over until the thing finally compiles. 112 | _facepalm_ - this will be fixed with ghc 8.2. 113 | 114 | Drink your ☕, take a walk and rejoice... 115 | 116 | 117 | contributions 118 | ------------- 119 | I welcome any and all contributions. Feel free to [tackle an issue (or a TODO)](https://github.com/schell/gelatin/issues) by making a pull request! 120 | 121 | If you'd like to make a donation you can do so [through patreon](https://www.patreon.com/schell). 122 | 123 | This library will always be free. 124 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | gelatin 3 | gelatin-shaders 4 | gelatin-gl 5 | gelatin-sdl2 6 | gelatin-fruity 7 | gelatin-freetype2 8 | gelatin-example 9 | 10 | -------------------------------------------------------------------------------- /gelatin-example/.sosrc: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - ([^\/]*)\/(.*\.hs)$ 3 | commands: 4 | # - stack build --trace --fast --ghc-options="-fprof-cafs -fprof-auto" 5 | - stack build --fast 6 | - stack exec hlint \0 7 | # - stack exec gelatin-example -- +RTS -p -hy -sstderr 8 | - stack exec gelatin-example 9 | - patterns: 10 | - ([^\/]*)\/(.*\.cabal)$ 11 | commands: 12 | - stack exec hlint \0 13 | -------------------------------------------------------------------------------- /gelatin-example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Schell Scivally 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /gelatin-example/README.md: -------------------------------------------------------------------------------- 1 | gelatin-example 2 | =============== 3 | 4 | Simple example to get you started with 5 | [gelatin](http://hackage.haskell.org/package/gelatin). 6 | 7 | This uses [sdl2](https://hackage.haskell.org/package/sdl2), and the 8 | [gelatin-sdl2](https://github.com/schell/gelatin/tree/master/gelatin-sdl2) 9 | bindings, to intialize the window and access events. 10 | -------------------------------------------------------------------------------- /gelatin-example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin-example/assets/Neuton-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/schell/gelatin/04c1c83d4297eac4f4cc5e8e5c805b1600b3ee98/gelatin-example/assets/Neuton-Regular.ttf -------------------------------------------------------------------------------- /gelatin-example/assets/OFL.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, 2011, Brian Zick (artistenator@gmail.com www.21326.info), 2 | with Reserved Font Name "Neuton" "Neuton Italic" "Neuton Cursive" 3 | 4 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 5 | This license is copied below, and is also available with a FAQ at: 6 | http://scripts.sil.org/OFL 7 | 8 | 9 | ----------------------------------------------------------- 10 | SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 11 | ----------------------------------------------------------- 12 | 13 | PREAMBLE 14 | The goals of the Open Font License (OFL) are to stimulate worldwide 15 | development of collaborative font projects, to support the font creation 16 | efforts of academic and linguistic communities, and to provide a free and 17 | open framework in which fonts may be shared and improved in partnership 18 | with others. 19 | 20 | The OFL allows the licensed fonts to be used, studied, modified and 21 | redistributed freely as long as they are not sold by themselves. The 22 | fonts, including any derivative works, can be bundled, embedded, 23 | redistributed and/or sold with any software provided that any reserved 24 | names are not used by derivative works. The fonts and derivatives, 25 | however, cannot be released under any other type of license. The 26 | requirement for fonts to remain under this license does not apply 27 | to any document created using the fonts or their derivatives. 28 | 29 | DEFINITIONS 30 | "Font Software" refers to the set of files released by the Copyright 31 | Holder(s) under this license and clearly marked as such. This may 32 | include source files, build scripts and documentation. 33 | 34 | "Reserved Font Name" refers to any names specified as such after the 35 | copyright statement(s). 36 | 37 | "Original Version" refers to the collection of Font Software components as 38 | distributed by the Copyright Holder(s). 39 | 40 | "Modified Version" refers to any derivative made by adding to, deleting, 41 | or substituting -- in part or in whole -- any of the components of the 42 | Original Version, by changing formats or by porting the Font Software to a 43 | new environment. 44 | 45 | "Author" refers to any designer, engineer, programmer, technical 46 | writer or other person who contributed to the Font Software. 47 | 48 | PERMISSION & CONDITIONS 49 | Permission is hereby granted, free of charge, to any person obtaining 50 | a copy of the Font Software, to use, study, copy, merge, embed, modify, 51 | redistribute, and sell modified and unmodified copies of the Font 52 | Software, subject to the following conditions: 53 | 54 | 1) Neither the Font Software nor any of its individual components, 55 | in Original or Modified Versions, may be sold by itself. 56 | 57 | 2) Original or Modified Versions of the Font Software may be bundled, 58 | redistributed and/or sold with any software, provided that each copy 59 | contains the above copyright notice and this license. These can be 60 | included either as stand-alone text files, human-readable headers or 61 | in the appropriate machine-readable metadata fields within text or 62 | binary files as long as those fields can be easily viewed by the user. 63 | 64 | 3) No Modified Version of the Font Software may use the Reserved Font 65 | Name(s) unless explicit written permission is granted by the corresponding 66 | Copyright Holder. This restriction only applies to the primary font name as 67 | presented to the users. 68 | 69 | 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font 70 | Software shall not be used to promote, endorse or advertise any 71 | Modified Version, except to acknowledge the contribution(s) of the 72 | Copyright Holder(s) and the Author(s) or with their explicit written 73 | permission. 74 | 75 | 5) The Font Software, modified or unmodified, in part or in whole, 76 | must be distributed entirely under this license, and must not be 77 | distributed under any other license. The requirement for fonts to 78 | remain under this license does not apply to any document created 79 | using the Font Software. 80 | 81 | TERMINATION 82 | This license becomes null and void if any of the above conditions are 83 | not met. 84 | 85 | DISCLAIMER 86 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 87 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF 88 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT 89 | OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE 90 | COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 91 | INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 92 | DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 93 | FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM 94 | OTHER DEALINGS IN THE FONT SOFTWARE. 95 | -------------------------------------------------------------------------------- /gelatin-example/assets/tex.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/schell/gelatin/04c1c83d4297eac4f4cc5e8e5c805b1600b3ee98/gelatin-example/assets/tex.jpg -------------------------------------------------------------------------------- /gelatin-example/gelatin-example.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-example 2 | version: 0.1.0.0 3 | synopsis: A simple gelatin example. 4 | description: A simple gelatin example. Please see README.md 5 | homepage: https://github.com/schell/gelatin#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Schell Scivally 9 | maintainer: schell@synapsegroup.com 10 | copyright: 2016 Schell Scivally 11 | category: Graphics 12 | build-type: Simple 13 | data-files: assets/*.jpg, assets/*.ttf, assets/*.txt 14 | cabal-version: >=1.10 15 | stability: experimental 16 | 17 | executable gelatin-example 18 | hs-source-dirs: src 19 | main-is: Main.hs 20 | other-modules: Paths_gelatin_example 21 | ghc-options: -rtsopts 22 | build-depends: base >=4.8 && < 4.12 23 | , bytestring >=0.10 && <0.11 24 | , directory >=1.2 && <1.4 25 | , filepath >=1.4 && <1.5 26 | , FontyFruity >=0.5 && <0.6 27 | , gelatin >=0.1 && <0.2 28 | , gelatin-freetype2 >=0.1 && <0.2 29 | , gelatin-fruity >=0.1 && <0.2 30 | , gelatin-sdl2 >=0.1 && <0.2 31 | , lens >=4.15 && <4.17 32 | , linear >=1.20 && <1.21 33 | , mtl >= 2.2 && < 2.3 34 | , sdl2 >=2.4.0.1 && <2.5 35 | , text >=1.2 && <1.3 36 | , vector >=0.12 && <0.13 37 | , transformers >=0.4 && <0.6 38 | default-language: Haskell2010 39 | 40 | source-repository head 41 | type: git 42 | location: https://github.com/schell/gelatin 43 | -------------------------------------------------------------------------------- /gelatin-example/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | import Control.Arrow 3 | import Control.Concurrent (threadDelay) 4 | import Control.Monad (forever, when) 5 | import Control.Monad.Except (runExceptT) 6 | import Control.Monad.IO.Class (liftIO) 7 | import qualified Data.Vector as B 8 | import Gelatin.FreeType2 9 | import Gelatin.Fruity 10 | import Gelatin.SDL2 11 | import Paths_gelatin_example 12 | import SDL 13 | import System.Exit (exitFailure, exitSuccess) 14 | import System.FilePath (()) 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Regular pure pictures 18 | -------------------------------------------------------------------------------- 19 | colorGeometry :: Geometry (V2 Float, V4 Float) 20 | colorGeometry = do 21 | triangles tris 22 | beziers $ mapVertices (first (+ V2 100 0)) tris 23 | line $ mapVertices (first (+V2 200 0)) tris 24 | line $ mapVertices (first (+V2 300 0)) bcurve 25 | line $ mapVertices (first ((+V2 300 100) . (*V2 1 (-1)))) bcurve 26 | line $ mapVertices (first (+V2 350 50)) circle 27 | where tris = do tri (0, red) (V2 100 0, green) (100, blue) 28 | tri (0, magenta) (V2 0 100, canary) (100, cyan) 29 | bcurve = mapVertices (\v -> (v,white)) $ 30 | curve (V2 0 100) (V2 50 (-50)) 100 31 | circle = mapVertices (\v -> (v,white)) $ arc 50 50 0 (2*pi) 32 | 33 | colorPicture :: ColorPicture () 34 | colorPicture = do 35 | setStroke [StrokeWidth 3, StrokeFeather 1] 36 | setGeometry colorGeometry 37 | 38 | bezierPicture :: ColorPicture () 39 | bezierPicture = setGeometry $ beziers $ do 40 | bez (V2 0 0, white) (V2 200 0, blue) (V2 200 200, green) 41 | bez (V2 400 200, white) (V2 400 0, blue) (V2 200 0, green) 42 | 43 | texturePicture :: GLuint -> V2 Int -> TexturePicture () 44 | texturePicture tex (V2 w h) = do 45 | setStroke [StrokeWidth 3, StrokeFeather 1] 46 | setTextures [tex] 47 | setGeometry $ mapGeometry toUV colorGeometry 48 | where toUV (V2 x y, _) = (V2 x y, V2 (x/fromIntegral w) (y/fromIntegral h)) 49 | 50 | outlinedTextPicture :: Font -> ColorPicture () 51 | outlinedTextPicture font = do 52 | let outline = B.map (mapRawGeometry (\v -> (v, white))) $ 53 | stringOutline font 100 128 "Outlined Strings" 54 | setRawGeometry outline 55 | setStroke [StrokeWidth 3, StrokeFeather 1] 56 | 57 | isQuit :: Event -> Bool 58 | isQuit (Event _ payload) = isKeyQ payload || payload == QuitEvent 59 | where 60 | isKeyQ (KeyboardEvent (KeyboardEventData _ _ _ (Keysym _ KeycodeQ _))) = True 61 | isKeyQ _ = False 62 | -------------------------------------------------------------------------------- 63 | -- Main stuff, including actual font outline text and freetype2 text. 64 | -------------------------------------------------------------------------------- 65 | main :: IO () 66 | main = do 67 | ttfName <- getDataFileName $ "assets" "Neuton-Regular.ttf" 68 | imgName <- getDataFileName $ "assets" "tex.jpg" 69 | font <- loadFontFile ttfName >>= \case 70 | Left err -> putStrLn err >> exitFailure 71 | Right f -> return f 72 | 73 | runExceptT (startupSDL2Backends 1000 600 "gelatin-example" True) >>= \case 74 | Left err -> putStrLn err 75 | Right (SDL2Backends glv2v4 glv2v2) -> do 76 | Just (sz, tex) <- loadImage imgName 77 | 78 | (_, colorPicRender) <- compilePicture glv2v4 colorPicture 79 | (_, bezPicRender) <- compilePicture glv2v4 bezierPicture 80 | (_, texPicRender) <- compilePicture glv2v2 $ texturePicture tex sz 81 | -- Font outlines filled with white 82 | colorTextRender <- coloredString glv2v4 font 100 128 "Colored Strings" $ 83 | const white 84 | -- Font outlines filled with texture 85 | texTextRender <- 86 | texturedString glv2v2 font 100 128 "Textured Strings" tex $ 87 | \(V2 x y) -> V2 (x/200) ((y+128)/200) 88 | -- Font outline, outlined in white 89 | (_, outlineRender) <- compilePicture glv2v4 $ outlinedTextPicture font 90 | -- Colored freetype2 text with kerning and newline support 91 | Just atlas <- allocAtlas ttfName (PixelSize 32 32) asciiChars 92 | (ft2r,_,_) <- freetypeRenderer2 glv2v2 atlas white 93 | "Hello freetype,\nThanks for everything.\n - gelatin" 94 | 95 | forever $ do 96 | threadDelay 1 97 | events <- getEvents glv2v4 98 | when (any isQuit events) exitSuccess 99 | clearWindow glv2v4 100 | snd colorPicRender [] 101 | snd texPicRender [move 0 100] 102 | snd bezPicRender [move 400 100] 103 | snd colorTextRender [move 0 400] 104 | snd texTextRender [move 0 500] 105 | snd outlineRender [move 0 600] 106 | snd ft2r [move 500 50] 107 | updateWindow glv2v4 108 | -------------------------------------------------------------------------------- /gelatin-freetype2/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Schell Scivally (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Schell Scivally nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /gelatin-freetype2/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin-freetype2/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Main where 4 | 5 | import Gelatin 6 | import Gelatin.GL 7 | import Gelatin.SDL2 hiding (ek) 8 | import Gelatin.FreeType2.Internal 9 | import SDL hiding (glBindTexture) 10 | import Control.Monad 11 | import Halive.Utils 12 | import System.Exit (exitSuccess) 13 | 14 | isQuit :: Event -> Bool 15 | isQuit (Event _ payload) = isKeyQ payload || payload == QuitEvent 16 | where 17 | isKeyQ (KeyboardEvent (KeyboardEventData _ _ _ (Keysym _ KeycodeQ _))) = True 18 | isKeyQ _ = False 19 | 20 | main :: IO () 21 | main = do 22 | let fnt = "/Library/Fonts/Arial.ttf" 23 | (rez,window) <- reacquire 0 $ startupSDL2Backend 800 600 "gelatin-freetype2" True 24 | Just glrAtlas <- allocAtlas fnt (PixelSize 64 64) asciiChars 25 | (glr,_,_) <- freetypeGLRenderer rez glrAtlas white "Straight to gl\n(for retina - 2x)" 26 | 27 | Just (atlasPic,stringPic) <- withAtlas fnt (PixelSize 32 32) asciiChars $ \atlas -> do 28 | let V2 w h = fromIntegral <$> atlasTextureSize atlas 29 | 30 | (_,atlasPic) <- compileTexturePicture rez $ do 31 | setTextures [atlasTexture atlas] 32 | setGeometry $ triangles $ do 33 | tri (0, 0) (V2 w 0, V2 1 0) (V2 w h, V2 1 1) 34 | tri (0, 0) (V2 w h, V2 1 1) (V2 0 h, V2 0 1) 35 | (_,stringPic) <- compileTexturePictureT rez $ do 36 | let lineHeight = 32 37 | move $ V2 0 (h + lineHeight) 38 | embed $ freetypePicture atlas white "Here is a string written" 39 | embed $ do 40 | move $ V2 0 lineHeight 41 | freetypePicture atlas white "with gelatin-freetype2! :)" 42 | embed $ do 43 | move $ V2 0 $ lineHeight * 2 44 | freetypePicture atlas green "Yo, we have good kerning!" 45 | embed $ do 46 | move $ V2 0 $ lineHeight * 3 47 | freetypePicture atlas blue "ToYoTa" 48 | return (atlasPic,stringPic) 49 | 50 | forever $ do 51 | events <- pollEvents 52 | renderWithSDL2 window rez $ do 53 | atlasPic [] 54 | stringPic [] 55 | snd glr [Spatial $ Translate $ V2 100 100] 56 | when (any isQuit events) exitSuccess 57 | -------------------------------------------------------------------------------- /gelatin-freetype2/gelatin-freetype2.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-freetype2 2 | version: 0.1.0.0 3 | synopsis: FreeType2 based text rendering for the gelatin realtime 4 | rendering system. 5 | description: gelatin-freetype2 is a text rendering engine. It's fast enough 6 | to render frequently changing, long form text in realtime. It 7 | exposes a familiar gelatin based API. It uses word and font 8 | level maps (atlases) along with freetype2 to achieve reliable 9 | performance. 10 | For rendering text as scalable vector graphics, see gelatin-fruity. 11 | homepage: https://github.com/schell/gelatin/gelatin-freetype2#readme 12 | license: BSD3 13 | license-file: LICENSE 14 | author: Schell Scivally 15 | maintainer: schell@zyghost.com 16 | copyright: Schell Scivally 17 | category: Web 18 | build-type: Simple 19 | -- extra-source-files: 20 | cabal-version: >=1.10 21 | stability: experimental 22 | 23 | library 24 | hs-source-dirs: src 25 | exposed-modules: Gelatin.FreeType2.Internal 26 | , Gelatin.FreeType2.Utils 27 | , Gelatin.FreeType2 28 | 29 | build-depends: base >=4.8 && < 4.12 30 | , containers >=0.5 && <0.6 31 | , freetype2 >=0.1 && <0.2 32 | , gelatin >=0.1 && <0.2 33 | , gelatin-gl >=0.1 && <0.2 34 | , mtl >=2.2 && <2.3 35 | , transformers >=0.4 && <0.6 36 | 37 | default-language: Haskell2010 38 | 39 | --executable gelatin-freetype2-exe 40 | -- hs-source-dirs: app 41 | -- main-is: Main.hs 42 | -- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 43 | -- build-depends: base >=4.8 && < 4.12 44 | -- , gelatin 45 | -- , gelatin-freetype2 46 | -- , gelatin-sdl2 47 | -- , gelatin-gl 48 | -- , freetype2 49 | -- , sdl2 50 | -- , halive 51 | -- , transformers 52 | -- , mtl 53 | -- , containers 54 | -- , pretty-show 55 | -- , vector 56 | -- 57 | -- default-language: Haskell2010 58 | 59 | test-suite gelatin-freetype2-test 60 | type: exitcode-stdio-1.0 61 | hs-source-dirs: test 62 | main-is: Spec.hs 63 | build-depends: base >=4.8 && < 4.12 64 | , gelatin-freetype2 65 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 66 | default-language: Haskell2010 67 | 68 | source-repository head 69 | type: git 70 | location: https://github.com/schell/gelatin-freetype2 71 | -------------------------------------------------------------------------------- /gelatin-freetype2/sosrc-dev: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - .*\.cabal$ 4 | commands: 5 | - stack build --fast 6 | - stack exec hlint \0 7 | -------------------------------------------------------------------------------- /gelatin-freetype2/src/Gelatin/FreeType2.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Gelatin.GL 3 | -- Copyright: (c) 2017 Schell Scivally 4 | -- License: MIT 5 | -- Maintainer: Schell Scivally 6 | -- 7 | -- This module provides font string rendering through the legendary freetype2. 8 | -- It automatically manages a texture atlas and word atlas to speed up rendering. 9 | module Gelatin.FreeType2 10 | (-- * Getting straight to rendering 11 | freetypeRenderer2 12 | -- * Creating a gelatin picture 13 | , freetypePicture 14 | -- * Creating an Atlas 15 | , allocAtlas 16 | , asciiChars 17 | , freeAtlas 18 | , loadWords 19 | , unloadMissingWords 20 | , Atlas(..) 21 | -- * Going deeper 22 | -- ** Glyphs 23 | , GlyphSize(..) 24 | , glyphWidth 25 | , glyphHeight 26 | -- ** Measuring glyphs 27 | , GlyphMetrics(..) 28 | ) where 29 | 30 | import Gelatin.FreeType2.Internal 31 | -------------------------------------------------------------------------------- /gelatin-freetype2/src/Gelatin/FreeType2/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TupleSections #-} 3 | module Gelatin.FreeType2.Utils ( 4 | module FT 5 | , FreeTypeT 6 | , FreeTypeIO 7 | , getAdvance 8 | , getCharIndex 9 | , getLibrary 10 | , getKerning 11 | , glyphFormatString 12 | , hasKerning 13 | , loadChar 14 | , loadGlyph 15 | , newFace 16 | , setCharSize 17 | , setPixelSizes 18 | , withFreeType 19 | , runFreeType 20 | ) where 21 | 22 | import Control.Monad.IO.Class (MonadIO, liftIO) 23 | import Control.Monad.Trans.Except 24 | import Control.Monad.Trans.Class 25 | import Control.Monad.Trans.State.Strict 26 | import Control.Monad (unless) 27 | import Graphics.Rendering.FreeType.Internal as FT 28 | import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as FT 29 | import Graphics.Rendering.FreeType.Internal.Library as FT 30 | import Graphics.Rendering.FreeType.Internal.FaceType as FT 31 | import Graphics.Rendering.FreeType.Internal.Face as FT hiding (generic) 32 | import Graphics.Rendering.FreeType.Internal.GlyphSlot as FT 33 | import Graphics.Rendering.FreeType.Internal.Bitmap as FT 34 | import Graphics.Rendering.FreeType.Internal.Vector as FT 35 | import Foreign as FT 36 | import Foreign.C.String as FT 37 | 38 | type FreeTypeT m = ExceptT String (StateT FT_Library m) 39 | type FreeTypeIO = FreeTypeT IO 40 | 41 | glyphFormatString :: FT_Glyph_Format -> String 42 | glyphFormatString fmt 43 | | fmt == ft_GLYPH_FORMAT_COMPOSITE = "ft_GLYPH_FORMAT_COMPOSITE" 44 | | fmt == ft_GLYPH_FORMAT_OUTLINE = "ft_GLYPH_FORMAT_OUTLINE" 45 | | fmt == ft_GLYPH_FORMAT_PLOTTER = "ft_GLYPH_FORMAT_PLOTTER" 46 | | fmt == ft_GLYPH_FORMAT_BITMAP = "ft_GLYPH_FORMAT_BITMAP" 47 | | otherwise = "ft_GLYPH_FORMAT_NONE" 48 | 49 | liftE :: MonadIO m => IO (Either FT_Error a) -> FreeTypeT m a 50 | liftE f = (liftIO f) >>= \case 51 | Left e -> fail $ "FreeType2 error:" ++ (show e) 52 | Right a -> return a 53 | 54 | runIOErr :: MonadIO m => IO FT_Error -> FreeTypeT m () 55 | runIOErr f = do 56 | e <- liftIO f 57 | unless (e == 0) $ fail $ "FreeType2 error:" ++ (show e) 58 | 59 | runFreeType :: MonadIO m => FreeTypeT m a -> m (Either String (a, FT_Library)) 60 | runFreeType f = do 61 | (e,lib) <- liftIO $ alloca $ \p -> do 62 | e <- ft_Init_FreeType p 63 | lib <- peek p 64 | return (e,lib) 65 | if e /= 0 66 | then do 67 | _ <- liftIO $ ft_Done_FreeType lib 68 | return $ Left $ "Error initializing FreeType2:" ++ show e 69 | else (fmap (,lib)) <$> evalStateT (runExceptT f) lib 70 | 71 | withFreeType :: MonadIO m => Maybe FT_Library -> FreeTypeT m a -> m (Either String a) 72 | withFreeType Nothing f = runFreeType f >>= \case 73 | Left e -> return $ Left e 74 | Right (a,lib) -> do 75 | _ <- liftIO $ ft_Done_FreeType lib 76 | return $ Right a 77 | withFreeType (Just lib) f = evalStateT (runExceptT f) lib 78 | 79 | getLibrary :: MonadIO m => FreeTypeT m FT_Library 80 | getLibrary = lift get 81 | 82 | newFace :: MonadIO m => FilePath -> FreeTypeT m FT_Face 83 | newFace fp = do 84 | ft <- lift get 85 | liftE $ withCString fp $ \str -> 86 | alloca $ \ptr -> ft_New_Face ft str 0 ptr >>= \case 87 | 0 -> Right <$> peek ptr 88 | e -> return $ Left e 89 | 90 | setCharSize :: (MonadIO m, Integral i) => FT_Face -> i -> i -> i -> i -> FreeTypeT m () 91 | setCharSize ff w h dpix dpiy = runIOErr $ 92 | ft_Set_Char_Size ff (fromIntegral w) (fromIntegral h) 93 | (fromIntegral dpix) (fromIntegral dpiy) 94 | 95 | setPixelSizes :: (MonadIO m, Integral i) => FT_Face -> i -> i -> FreeTypeT m () 96 | setPixelSizes ff w h = 97 | runIOErr $ ft_Set_Pixel_Sizes ff (fromIntegral w) (fromIntegral h) 98 | 99 | getCharIndex :: (MonadIO m, Integral i) 100 | => FT_Face -> i -> FreeTypeT m FT_UInt 101 | getCharIndex ff ndx = liftIO $ ft_Get_Char_Index ff $ fromIntegral ndx 102 | 103 | loadGlyph :: MonadIO m => FT_Face -> FT_UInt -> FT_Int32 -> FreeTypeT m () 104 | loadGlyph ff fg flags = runIOErr $ ft_Load_Glyph ff fg flags 105 | 106 | loadChar :: MonadIO m => FT_Face -> FT_ULong -> FT_Int32 -> FreeTypeT m () 107 | loadChar ff char flags = runIOErr $ ft_Load_Char ff char flags 108 | 109 | hasKerning :: MonadIO m => FT_Face -> FreeTypeT m Bool 110 | hasKerning = liftIO . ft_HAS_KERNING 111 | 112 | getKerning :: MonadIO m => FT_Face -> FT_UInt -> FT_UInt -> FT_Kerning_Mode -> FreeTypeT m (Int,Int) 113 | getKerning ff prevNdx curNdx flags = liftE $ alloca $ \ptr -> do 114 | ft_Get_Kerning ff prevNdx curNdx (fromIntegral flags) ptr >>= \case 115 | 0 -> do FT_Vector x y <- peek ptr 116 | return $ Right (fromIntegral x, fromIntegral y) 117 | e -> return $ Left e 118 | 119 | getAdvance :: MonadIO m => FT_GlyphSlot -> FreeTypeT m (Int,Int) 120 | getAdvance slot = do 121 | FT_Vector x y <- liftIO $ peek $ advance slot 122 | liftIO $ print ("v",x,y) 123 | return (fromIntegral x, fromIntegral y) 124 | -------------------------------------------------------------------------------- /gelatin-freetype2/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /gelatin-fruity/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Schell Scivally (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Schell Scivally nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /gelatin-fruity/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin-fruity/gelatin-fruity.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-fruity 2 | version: 0.1.0.0 3 | synopsis: Gelatin's support for rendering TTF outlines, using FontyFruity. 4 | description: Gelatin's support for rendering TTF outlines, using FontyFruity. 5 | Using FontyFruity gelatin can render smooth font geometry without 6 | freetype. This smooth font geometry can be scaled arbitrarily. 7 | The process of extracting outlines and triangulating is a bit CPU 8 | intensive so if your application requires frequent text updates it 9 | is recommended you use gelatin-freetype2, which is much faster at 10 | the cost of scalability. 11 | homepage: https://github.com/schell/gelatin-fruity#readme 12 | license: BSD3 13 | license-file: LICENSE 14 | author: Schell Scivally 15 | maintainer: schell@takt.com 16 | copyright: Schell Scivally 17 | category: Graphics 18 | build-type: Simple 19 | cabal-version: >=1.10 20 | stability: experimental 21 | 22 | library 23 | ghc-options: -Wall 24 | hs-source-dirs: src 25 | exposed-modules: Gelatin.Fruity 26 | 27 | build-depends: base >=4.8 && < 4.12 28 | , gelatin >=0.1 && <0.2 29 | , FontyFruity >=0.5 && <0.6 30 | , vector >=0.12 && <0.13 31 | , linear >=1.20 && <1.21 32 | 33 | default-language: Haskell2010 34 | 35 | source-repository head 36 | type: git 37 | location: https://github.com/schell/gelatin-fruity 38 | -------------------------------------------------------------------------------- /gelatin-fruity/sosrc-dev: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - .*\.cabal$ 4 | commands: 5 | - stack build 6 | - stack exec hlint \0 7 | -------------------------------------------------------------------------------- /gelatin-fruity/src/Gelatin/Fruity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- | 3 | -- Module: Gelatin.Fruity 4 | -- Copyright: (c) 2017 Schell Scivally 5 | -- License: MIT 6 | -- Maintainer: Schell Scivally 7 | -- 8 | -- Provides two high-level functions that create gelatin renderers: 9 | -- 10 | -- ['coloredString']: font strings filled with color 11 | -- 12 | -- ['texturedString']: font strings filled with a texture mapping 13 | -- 14 | -- 15 | -- Provides one mid-level function for extracting a font outline: 16 | -- 17 | -- ['stringOutline']: raw geometry of a font string 18 | -- 19 | -- 20 | -- For help obtaining a 'Font' within your program, check out 21 | -- 'loadFontFile'. 22 | module Gelatin.Fruity ( 23 | module TT, 24 | coloredString, 25 | texturedString, 26 | stringOutline 27 | ) where 28 | 29 | import Gelatin 30 | import Graphics.Text.TrueType as TT 31 | import Data.Vector.Unboxed (Vector, Unbox) 32 | import qualified Data.Vector.Unboxed as V 33 | import qualified Data.Vector as B 34 | import Control.Arrow (first,second) 35 | -------------------------------------------------------------------------------- 36 | -- Font decomposition into triangles and beziers 37 | -------------------------------------------------------------------------------- 38 | -- | Ephemeral types for creating polygons from font outlines. 39 | -- Fonty gives us a [[Vector (Float, Float)]] for an entire string, which 40 | -- breaks down to 41 | type Contour = Vector (V2 Float) -- Beziers 42 | type CharacterOutline = [Contour] 43 | type StringOutline = [CharacterOutline] 44 | 45 | fromFonty :: (Unbox b1, Functor f1, Functor f) 46 | => (Vector (V2 b1) -> b) -> f (f1 (Vector (b1, b1))) -> f (f1 b) 47 | fromFonty f = fmap $ fmap $ f . V.map (uncurry V2) 48 | 49 | -- | Turn a polyline into a list of bezier points. 50 | toBeziers :: (Fractional a, Ord a, Unbox a) 51 | => Vector (V2 a) -> Vector (Bezier (V2 a)) 52 | toBeziers vs = 53 | V.fromList $ map (\(a,b,c) -> bezier (vs V.! a) (vs V.! b) (vs V.! c)) ndxs 54 | where ndxs = map f [0 .. nt $ V.length vs -1] 55 | nt n = max 0 $ ceiling $ (fromIntegral n - 3) / (2 :: Double) 56 | f i = let a = i * 2 57 | b = a + 1 58 | c = a + 2 59 | in (a,b,c) 60 | 61 | unBeziers :: (Fractional a, Ord a, Unbox a) 62 | => Vector (Bezier a) 63 | -> Vector a 64 | unBeziers = V.concatMap (\(_,a,b,c) -> V.fromList [a,b,c]) 65 | 66 | fruityBeziers :: [[Vector (Float, Float)]] -> StringOutline 67 | fruityBeziers = fromFonty (unBeziers . toBeziers . V.map (fmap realToFrac)) 68 | 69 | -- | Collects the points that lie directly on the contour of the font 70 | -- outline. 71 | onContourPoints :: Unbox a => Vector (Bezier a) -> Vector a 72 | onContourPoints = V.concatMap f 73 | where f (False,a,b,c) = V.fromList [a,b,c] 74 | f (_,a,_,c) = V.fromList [a,c] 75 | --onContourPoints = V.foldl' f mempty 76 | -- where f bs (False,a,b,c) = bs V.++ V.fromList [a,b,c] 77 | -- f bs (_,a,_,c) = bs V.++ V.fromList [a,c] 78 | 79 | stringCurve :: Font -> Int -> Float -> String -> [[Vector (Float, Float)]] 80 | stringCurve font dpi px str = getStringCurveAtPoint dpi (0,0) [(font, sz, str)] 81 | where --sz = pixelSizeInPointAtDpi px dpi 82 | sz = PointSize px 83 | 84 | -- | Extract the outlines of a given string using a font. Returns a 85 | -- vector of 'RawBeziers' and 'RawTriangles'. 86 | stringOutline 87 | :: Font 88 | -- ^ The font to extract geometry from. 89 | -> Int 90 | -- ^ The dpi to read the font at. 91 | -> Float 92 | -- ^ The target pixel width of the resulting geometry. 93 | -> String 94 | -- ^ The string to construct and extract the geometry with. 95 | -> B.Vector (RawGeometry (V2 Float)) 96 | stringOutline font dpi px str = 97 | B.fromList $ map RawLine $ concat $ 98 | fromFonty (cleanSeqDupes . V.concatMap divide . toBeziers . V.map (fmap realToFrac)) $ 99 | stringCurve font dpi px str 100 | where divide (_,a,b,c) = subdivideAdaptive 100 0 $ bez3 a b c 101 | 102 | fontBezAndTris :: Font -> Int -> Float -> String 103 | -> (RawGeometry (V2 Float), B.Vector (RawGeometry (V2 Float))) 104 | fontBezAndTris font dpi px str = 105 | let cs = stringCurve font dpi px str 106 | bs = fruityBeziers cs 107 | ts = concatMap (fmap onContourPoints) $ fromFonty (toBeziers . V.map (fmap realToFrac)) cs 108 | in ( RawBeziers $ V.concat $ concat bs 109 | , B.map RawTriangleFan $ B.fromList ts 110 | ) 111 | 112 | -- | Creates a gelatin Renderer that renders the given string in 2d space. 113 | coloredString 114 | :: Backend t e (V2 Float, V4 Float) (V2 Float) Float s 115 | -- ^ A backend for rendering geometry with 'V2V4' vertices. 116 | -> Font 117 | -- ^ The font to use. 118 | -> Int 119 | -- ^ The dpi to use for reading the font geometry. 120 | -> Float 121 | -- ^ Your target pixel width. 122 | -> String 123 | -- ^ The string to render. 124 | -> (V2 Float -> V4 Float) 125 | -- ^ A function from font geometry/space to color. 126 | -> IO (Renderer (V2 Float) Float s) 127 | coloredString b font dpi px str fill = do 128 | let g = mapRawGeometry h 129 | h v = (v, fill v) 130 | (bs, ts) = second (B.map g) $ first g $ fontBezAndTris font dpi px str 131 | 132 | (_, r1) <- compilePicture b $ do 133 | setRawGeometry ts 134 | setRenderingOptions [StencilMaskOption] 135 | 136 | (_, r2) <- compilePicture b $ setRawGeometry $ B.singleton bs 137 | 138 | return $ r1 `mappend` r2 139 | 140 | -- | Creates a gelatin Renderer that renders the given string in 2d space, 141 | -- using a given texture. 142 | texturedString 143 | :: Backend t e (V2 Float, V2 Float) (V2 Float) Float s 144 | -- ^ A backend for rendering geometry with 'V2V2' vertices. 145 | -> Font 146 | -- ^ The font to use. 147 | -> Int 148 | -- ^ The dpi to use for reading the font geometry. 149 | -> Float 150 | -- ^ Your target pixel width. 151 | -> String 152 | -- ^ The string to render. 153 | -> t 154 | -- ^ The texture. 155 | -> (V2 Float -> V2 Float) 156 | -- ^ A function from font geometry/space to texture mapping (uv coords). 157 | -> IO (Renderer (V2 Float) Float s) 158 | texturedString b font dpi px str t fill = do 159 | let g = mapRawGeometry h 160 | h v = (v, fill v) 161 | (bs, ts) = second (B.map g) $ first g $ fontBezAndTris font dpi px str 162 | 163 | (_, r1) <- compilePicture b $ do 164 | setRawGeometry ts 165 | setRenderingOptions [StencilMaskOption] 166 | setTextures [t] 167 | 168 | (_, r2) <- compilePicture b $ do 169 | setRawGeometry $ B.singleton bs 170 | setTextures [t] 171 | 172 | return $ r1 `mappend` r2 173 | -------------------------------------------------------------------------------- /gelatin-gl/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Schell Scivally 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /gelatin-gl/README.md: -------------------------------------------------------------------------------- 1 | gelatin-gl 2 | ============ 3 | OpenGL rendering routines to help with building OpenGL based backends for `gelatin`. 4 | This repo currently supports the [gelatin-glfw](https://github.com/schell/gelatin/tree/master/gelatin-glfw) 5 | and [gelatin-sdl2](https://github.com/schell/gelatin/tree/master/gelatin-sdl2) backends. 6 | -------------------------------------------------------------------------------- /gelatin-gl/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin-gl/app/Example.hs: -------------------------------------------------------------------------------- 1 | import Gelatin 2 | import Gelatin.GL 3 | import Linear as L 4 | import qualified Data.Vector as B 5 | import qualified Data.Vector.Unboxed as V 6 | import Control.Lens 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Example 10 | -------------------------------------------------------------------------------- 11 | main :: IO () 12 | main = putStrLn "Hello" 13 | -------------------------------------------------------------------------------- /gelatin-gl/gelatin-gl.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-gl 2 | version: 0.1.0.0 3 | synopsis: OpenGL rendering routines for the gelatin-picture graphics 4 | EDSL. 5 | description: This package provides most of a backend to 6 | gelatin-picture, a DSL for decribing two dimensional 7 | pictures. 8 | homepage: https://github.com/schell/gelatin/gelatin-gl 9 | license: MIT 10 | license-file: LICENSE 11 | author: Schell Scivally 12 | maintainer: schell.scivally@synapsegroup.com 13 | category: Graphics 14 | build-type: Simple 15 | cabal-version: >=1.10 16 | stability: experimental 17 | 18 | library 19 | ghc-options: -Wall 20 | exposed-modules: Gelatin.GL, 21 | Gelatin.GL.Renderer, 22 | Gelatin.GL.Compiler, 23 | Gelatin.GL.Shader, 24 | Gelatin.GL.Common, 25 | Gelatin.GL.TH 26 | build-depends: base >=4.8 && < 4.12 27 | , bytestring >=0.10 && <0.11 28 | , containers >=0.5 && <0.6 29 | , directory >=1.2 && <1.4 30 | , filepath >=1.4 && <1.5 31 | , gelatin >=0.1 && <0.2 32 | , gelatin-shaders >=0.1 && <0.2 33 | , gl >=0.7 && <0.9 34 | , JuicyPixels >=3.2 && <3.3 35 | , lens >=4.14 && <4.17 36 | , linear >=1.20 && <1.21 37 | , mtl >=2.2 && <2.3 38 | , transformers >=0.4 && <0.6 39 | , template-haskell >=2.10 && <2.14 40 | , vector >=0.12 && <0.13 41 | 42 | hs-source-dirs: src 43 | default-language: Haskell2010 44 | 45 | executable gelatin-gl-example 46 | ghc-options: -Wall 47 | 48 | build-depends: base >=4.8 && < 4.12 49 | , gelatin >=0.1 && <0.2 50 | , gelatin-gl 51 | , linear >=1.20 && <1.21 52 | , lens >=4.14 && <4.17 53 | , mtl >=2.2 && <2.3 54 | , vector >=0.12 && <0.13 55 | 56 | hs-source-dirs: app 57 | main-is: Example.hs 58 | default-language: Haskell2010 59 | -------------------------------------------------------------------------------- /gelatin-gl/sosrc-dev: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - .*\.cabal$ 4 | commands: 5 | - stack build --fast 6 | - stack exec hlint \0 7 | # - stack build --fast --stack-yaml=stack80-ghcjs.yaml 8 | # - stack exec hlint \0 --stack-yaml=stack80-ghcjs.yaml 9 | -------------------------------------------------------------------------------- /gelatin-gl/src/Gelatin/GL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TupleSections #-} 5 | -- | 6 | -- Module: Gelatin.GL 7 | -- Copyright: (c) 2017 Schell Scivally 8 | -- License: MIT 9 | -- Maintainer: Schell Scivally 10 | -- 11 | -- ["Gelatin.GL.Renderer"] 12 | -- Rendering specific geometries in IO. 13 | -- 14 | -- ["Gelatin.GL.Compiler"] 15 | -- Compiling and marshaling general geometries to the renderer. 16 | -- 17 | -- ["Gelatin.GL.Shader"] 18 | -- Loading and compiling the OpenGL shaders needed to run the renderer. 19 | -- 20 | -- ["Gelatin.GL.Common"] 21 | -- Some shared stuff. 22 | -- 23 | 24 | 25 | module Gelatin.GL 26 | ( module Gelatin.GL.Renderer 27 | , module Gelatin.GL.Shader 28 | , module Gelatin.GL.Common 29 | , module Gelatin.GL.Compiler 30 | -- * Re-exports 31 | , module Gelatin 32 | , module Graphics.GL.Types 33 | , module Graphics.GL.Core33 34 | ) where 35 | 36 | import Gelatin.GL.Renderer 37 | import Gelatin.GL.Shader 38 | import Gelatin.GL.Common 39 | import Gelatin.GL.Compiler 40 | import Gelatin 41 | import Graphics.GL.Types 42 | import Graphics.GL.Core33 43 | -------------------------------------------------------------------------------- /gelatin-gl/src/Gelatin/GL/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | module Gelatin.GL.Common where 4 | 5 | import Gelatin 6 | import Gelatin.GL.Shader 7 | 8 | orthoContextProjection :: Context -> IO (M44 Float) 9 | orthoContextProjection window = do 10 | (ww, wh) <- ctxWindowSize window 11 | let (hw,hh) = (fromIntegral ww, fromIntegral wh) 12 | return $ ortho 0 hw hh 0 0 1 13 | -------------------------------------------------------------------------------- 14 | -- GL helper types 15 | -------------------------------------------------------------------------------- 16 | data Context = Context { ctxFramebufferSize :: IO (Int,Int) 17 | , ctxWindowSize :: IO (Int,Int) 18 | --, ctxScreenDpi :: IO Int 19 | } 20 | 21 | data Rez = Rez { rezShader :: Simple2DShader 22 | , rezContext :: Context 23 | } 24 | -------------------------------------------------------------------------------- /gelatin-gl/src/Gelatin/GL/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | module Gelatin.GL.Compiler where 8 | 9 | import Control.Lens hiding (op) 10 | import Control.Monad ((>=>)) 11 | import Data.Bits ((.|.)) 12 | import qualified Data.Vector.Unboxed as V 13 | import Graphics.GL.Core33 14 | import Graphics.GL.Types 15 | import Linear as L 16 | 17 | import Gelatin 18 | import Gelatin.GL.Common 19 | import Gelatin.GL.Renderer 20 | -------------------------------------------------------------------------------- 21 | -- Concrete Picture Types 22 | -------------------------------------------------------------------------------- 23 | type V2V4 = (V2 Float, V4 Float) 24 | type ColorPictureData = PictureData GLuint (V2 Float, V4 Float) 25 | type ColorPictureT = PictureT GLuint (V2 Float, V4 Float) 26 | type ColorPicture = ColorPictureT Identity 27 | 28 | type V2V2 = (V2 Float, V2 Float) 29 | type TexturePictureData = PictureData GLuint (V2 Float, V2 Float) 30 | type TexturePictureT = PictureT GLuint (V2 Float, V2 Float) 31 | type TexturePicture = TexturePictureT Identity 32 | 33 | rgbaCompiler :: Rez 34 | -> GeometryCompiler V2V4 (V2 Float) Float Raster 35 | rgbaCompiler Rez{..} = GeometryCompiler s l 36 | where s VertexTriangles = 37 | uncurry (colorRenderer rezContext rezShader GL_TRIANGLES) . V.unzip 38 | s VertexStrip = 39 | uncurry (colorRenderer rezContext rezShader GL_TRIANGLE_STRIP) . V.unzip 40 | s VertexFan = 41 | uncurry (colorRenderer rezContext rezShader GL_TRIANGLE_FAN) . V.unzip 42 | s VertexBeziers = 43 | uncurry (colorBezRenderer rezContext rezShader) . V.unzip 44 | l Stroke{..} = 45 | uncurry (colorPolylineRenderer rezContext rezShader strokeWidth 46 | strokeFeather strokeLineCaps) . V.unzip 47 | 48 | uvCompiler :: Rez -> GeometryCompiler V2V2 (V2 Float) Float Raster 49 | uvCompiler Rez{..} = GeometryCompiler s l 50 | where s VertexTriangles = 51 | uncurry (textureRenderer rezContext rezShader GL_TRIANGLES) . V.unzip 52 | s VertexStrip = 53 | uncurry (textureRenderer rezContext rezShader GL_TRIANGLE_STRIP) . V.unzip 54 | s VertexFan = 55 | uncurry (textureRenderer rezContext rezShader GL_TRIANGLE_FAN) . V.unzip 56 | s VertexBeziers = 57 | uncurry (textureBezRenderer rezContext rezShader) . V.unzip 58 | l Stroke{..} = 59 | uncurry (texPolylineRenderer rezContext rezShader strokeWidth 60 | strokeFeather strokeLineCaps) . V.unzip 61 | 62 | applyOption :: (c, rs -> IO ()) -> RenderingOption -> (c, rs -> IO ()) 63 | applyOption (c, r) StencilMaskOption = (c, \rs -> stencilMask (r rs) (r rs)) 64 | 65 | glV2V4Compiler :: Rez -> BackendCompiler V2V4 (V2 Float) Float Raster 66 | glV2V4Compiler rz = BackendComp 67 | { backendCompApplyOption = applyOption 68 | , backendCompCompiler = rgbaCompiler rz 69 | } 70 | 71 | glV2V2Compiler :: Rez -> BackendCompiler V2V2 (V2 Float) Float Raster 72 | glV2V2Compiler rz = BackendComp 73 | { backendCompApplyOption = applyOption 74 | , backendCompCompiler = uvCompiler rz 75 | } 76 | 77 | glOps :: Rez -> IO () -> IO [a] -> BackendOps GLuint a 78 | glOps Rez{..} windowUpdate getEvents = BackendOps 79 | { backendOpGetFramebufferSize = uncurry V2 <$> ctxFramebufferSize rezContext 80 | , backendOpGetWindowSize = uncurry V2 <$> ctxWindowSize rezContext 81 | , backendOpClearWindow = do 82 | (fbw,fbh) <- ctxFramebufferSize rezContext 83 | glViewport 0 0 (fromIntegral fbw) (fromIntegral fbh) 84 | glClear $ GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT 85 | , backendOpUpdateWindow = windowUpdate 86 | , backendOpSetClearColor = \(V4 r g b a) -> glClearColor r g b a 87 | , backendOpAllocTexture = loadImage >=> \case 88 | Nothing -> return Nothing 89 | Just (sz, tex) -> return $ Just (tex, sz) 90 | , backendOpBindTextures = bindTexsAround 91 | , backendOpGetEvents = getEvents 92 | } 93 | -------------------------------------------------------------------------------- /gelatin-gl/src/Gelatin/GL/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE TypeSynonymInstances #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | {-# OPTIONS_GHC -fprint-explicit-kinds #-} 13 | module Gelatin.GL.Shader ( 14 | -- * Compiling and loading shaders 15 | Simple2DShader 16 | , compileOGLShader 17 | , compileOGLProgram 18 | , loadSourcePaths 19 | , compileSources 20 | , compileProgram 21 | , loadSimple2DShader 22 | ) where 23 | 24 | import Control.Exception (assert) 25 | import Control.Monad 26 | import Control.Monad.Except (MonadError, throwError) 27 | import Control.Monad.IO.Class (MonadIO, liftIO) 28 | import Data.ByteString.Char8 as B 29 | import qualified Data.Foldable as F 30 | import Data.Proxy (Proxy (..)) 31 | import qualified Data.Vector.Storable as S 32 | import Data.Vector.Unboxed (Unbox, Vector) 33 | import qualified Data.Vector.Unboxed as V 34 | import Foreign.C.String 35 | import Foreign.Marshal.Array 36 | import Foreign.Marshal.Utils 37 | import Foreign.Ptr 38 | import Foreign.Storable 39 | import GHC.TypeLits (KnownNat, KnownSymbol, natVal) 40 | import Graphics.GL.Core33 41 | import Graphics.GL.Types 42 | import Prelude hiding (init) 43 | import Prelude as P 44 | 45 | import Gelatin 46 | import Gelatin.GL.TH 47 | import Gelatin.Shaders 48 | 49 | 50 | type Simple2DShader = GLuint 51 | -------------------------------------------------------------------------------- 52 | -- IsShaderType instances 53 | -------------------------------------------------------------------------------- 54 | instance IsShaderType VertexShader GLenum where 55 | getShaderType _ = GL_VERTEX_SHADER 56 | 57 | instance IsShaderType FragmentShader GLenum where 58 | getShaderType _ = GL_FRAGMENT_SHADER 59 | -------------------------------------------------------------------------------- 60 | -- Uniform marshaling functions 61 | -------------------------------------------------------------------------------- 62 | $(genUniform [t|Bool|] [| \loc bool -> 63 | glUniform1i loc $ if bool then 1 else 0 |]) 64 | 65 | $(genUniform [t|Int|] [| \loc enum -> 66 | glUniform1i loc $ fromIntegral $ fromEnum enum |]) 67 | 68 | $(genUniform [t|PrimType|] [| \loc enum -> 69 | glUniform1i loc $ fromIntegral $ fromEnum enum |]) 70 | 71 | $(genUniform [t|Float|] [| \loc float -> 72 | glUniform1f loc $ realToFrac float |]) 73 | 74 | $(genUniform [t|V2 Float|] [| \loc v -> 75 | let V2 x y = fmap realToFrac v 76 | in glUniform2f loc x y |]) 77 | 78 | $(genUniform [t|V3 Float|] [| \loc v -> 79 | let V3 x y z = fmap realToFrac v 80 | in glUniform3f loc x y z|]) 81 | 82 | $(genUniform [t|V4 Float|] [| \loc v -> 83 | let (V4 r g b a) = realToFrac <$> v 84 | in glUniform4f loc r g b a |]) 85 | 86 | $(genUniform [t|M44 Float|] [| \loc val -> 87 | with val $ glUniformMatrix4fv loc 1 GL_TRUE . castPtr |]) 88 | 89 | $(genUniform [t|(Int,Int)|] [| \loc (a, b) -> 90 | let [x,y] = P.map fromIntegral [a, b] 91 | in glUniform2i loc x y |]) 92 | 93 | $(genUniform [t|(LineCap,LineCap)|] [| \loc (a, b) -> 94 | let [x,y] = P.map (fromIntegral . fromEnum) [a, b] 95 | in glUniform2f loc x y |]) 96 | 97 | $(genUniform [t|V2 Int|] [| \loc v -> 98 | let V2 x y = fmap fromIntegral v 99 | in glUniform2i loc x y |]) 100 | -------------------------------------------------------------------------------- 101 | -- Attribute buffering and toggling 102 | -------------------------------------------------------------------------------- 103 | convertVec 104 | :: (Unbox (f Float), Foldable f) => Vector (f Float) -> S.Vector GLfloat 105 | convertVec = 106 | S.convert . V.map realToFrac . V.concatMap (V.fromList . F.toList) 107 | 108 | instance 109 | ( KnownNat loc, KnownSymbol name 110 | , Foldable f 111 | , Unbox (f Float), Storable (f Float) 112 | ) => HasGenFunc (AttributeBuffering (Attribute name (f Float) loc)) where 113 | 114 | type GenFunc (AttributeBuffering (Attribute name (f Float) loc)) = 115 | GLint -> GLuint -> Vector (f Float) -> IO () 116 | genFunction _ n buf as = do 117 | let loc = fromIntegral $ natVal (Proxy :: Proxy loc) 118 | asize = V.length as * sizeOf (V.head as) 119 | glBindBuffer GL_ARRAY_BUFFER buf 120 | S.unsafeWith (convertVec as) $ \ptr -> 121 | glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW 122 | glEnableVertexAttribArray loc 123 | glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr 124 | err <- glGetError 125 | when (err /= 0) $ do 126 | print err 127 | assert False $ return () 128 | 129 | instance (KnownNat loc, KnownSymbol name) 130 | => HasGenFunc (AttributeToggling (Attribute name val loc)) where 131 | type GenFunc (AttributeToggling (Attribute name val loc)) = (IO (), IO ()) 132 | genFunction _ = 133 | let aloc = fromIntegral $ natVal (Proxy :: Proxy loc) 134 | in (glEnableVertexAttribArray aloc, glDisableVertexAttribArray aloc) 135 | -------------------------------------------------------------------------------- 136 | -- OpenGL shader only stuff 137 | -------------------------------------------------------------------------------- 138 | compileOGLShader :: (MonadIO m, MonadError String m) 139 | => ByteString 140 | -- ^ The shader source 141 | -> GLenum 142 | -- ^ The shader type (vertex, frag, etc) 143 | -> m GLuint 144 | -- ^ Either an error message or the generated shader handle. 145 | compileOGLShader src shType = do 146 | shader <- liftIO $ glCreateShader shType 147 | if shader == 0 148 | then throwError "Could not create shader" 149 | else do 150 | success <- liftIO $ do 151 | withCString (B.unpack src) $ \ptr -> 152 | with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr 153 | 154 | glCompileShader shader 155 | with (0 :: GLint) $ \ptr -> do 156 | glGetShaderiv shader GL_COMPILE_STATUS ptr 157 | peek ptr 158 | 159 | if success == GL_FALSE 160 | then do 161 | err <- liftIO $ do 162 | infoLog <- with (0 :: GLint) $ \ptr -> do 163 | glGetShaderiv shader GL_INFO_LOG_LENGTH ptr 164 | logsize <- peek ptr 165 | allocaArray (fromIntegral logsize) $ \logptr -> do 166 | glGetShaderInfoLog shader logsize nullPtr logptr 167 | peekArray (fromIntegral logsize) logptr 168 | 169 | return $ P.unlines [ "Could not compile shader:" 170 | , B.unpack src 171 | , P.map (toEnum . fromEnum) infoLog 172 | ] 173 | throwError err 174 | else return shader 175 | 176 | compileOGLProgram :: (MonadIO m, MonadError String m) 177 | => [(String, Integer)] -> [GLuint] -> m GLuint 178 | compileOGLProgram attribs shaders = do 179 | (program, success) <- liftIO $ do 180 | program <- glCreateProgram 181 | forM_ shaders (glAttachShader program) 182 | forM_ attribs $ \(name, loc) -> 183 | withCString name $ glBindAttribLocation program $ fromIntegral loc 184 | glLinkProgram program 185 | 186 | success <- with (0 :: GLint) $ \ptr -> do 187 | glGetProgramiv program GL_LINK_STATUS ptr 188 | peek ptr 189 | return (program, success) 190 | 191 | if success == GL_FALSE 192 | then do 193 | err <- liftIO $ with (0 :: GLint) $ \ptr -> do 194 | glGetProgramiv program GL_INFO_LOG_LENGTH ptr 195 | logsize <- peek ptr 196 | infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do 197 | glGetProgramInfoLog program logsize nullPtr logptr 198 | peekArray (fromIntegral logsize) logptr 199 | return $ P.unlines [ "Could not link program" 200 | , P.map (toEnum . fromEnum) infoLog 201 | ] 202 | throwError err 203 | else do 204 | liftIO $ forM_ shaders glDeleteShader 205 | return program 206 | -------------------------------------------------------------------------------- 207 | -- Loading shaders and compiling a program. 208 | -------------------------------------------------------------------------------- 209 | loadSourcePaths :: MonadIO m 210 | => ShaderSteps (ts :: [*]) FilePath 211 | -> m (ShaderSteps ts ByteString) 212 | loadSourcePaths = (ShaderSteps <$>) . mapM (liftIO . B.readFile) . unShaderSteps 213 | 214 | compileSources 215 | :: forall m ts. (MonadIO m, MonadError String m, IsShaderType ts [GLenum]) 216 | => ShaderSteps (ts :: [*]) ByteString 217 | -> m (ShaderSteps ts GLuint) 218 | compileSources = 219 | (ShaderSteps <$>) . zipWithM (flip compileOGLShader) types . unShaderSteps 220 | where types = getShaderType (Proxy :: Proxy ts) 221 | 222 | compileProgram 223 | :: (MonadIO m, MonadError String m, GetLits as [(String, Integer)]) 224 | => Proxy (as :: [*]) 225 | -> ShaderSteps (ts :: [*]) GLuint 226 | -> m GLuint 227 | compileProgram p = compileOGLProgram (getSymbols p) . unShaderSteps 228 | 229 | -- | Compile all shader programs and return a "sum renderer". 230 | loadSimple2DShader :: (MonadIO m, MonadError String m) => m Simple2DShader 231 | loadSimple2DShader = do 232 | vertName <- liftIO simple2dVertFilePath 233 | fragName <- liftIO simple2dFragFilePath 234 | let paths :: ShaderSteps '[VertexShader, FragmentShader] FilePath 235 | paths = ShaderSteps [vertName, fragName] 236 | sources <- loadSourcePaths paths 237 | shaders <- compileSources sources 238 | compileProgram (Proxy :: Proxy Simple2DAttribs) shaders 239 | -------------------------------------------------------------------------------- /gelatin-gl/src/Gelatin/GL/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | 11 | module Gelatin.GL.TH where 12 | 13 | import Control.Exception (assert) 14 | import Data.Proxy (Proxy (..)) 15 | import Foreign.C.String (withCString) 16 | import GHC.TypeLits (KnownSymbol, symbolVal) 17 | import Graphics.GL 18 | import Language.Haskell.TH 19 | 20 | import Gelatin.Shaders 21 | 22 | genUniform 23 | :: TypeQ 24 | -- ^ The type of the uniform value. 25 | -- Most likely 'Bool', 'Float', 'V3', 'M44', etc. 26 | -> ExpQ 27 | -- ^ The function that marshals the value to the shader. 28 | -> DecsQ 29 | genUniform typ func = 30 | [d| 31 | instance KnownSymbol name => HasGenFunc (Uniform name $typ) where 32 | type GenFunc (Uniform name $typ) = GLuint -> $typ -> IO () 33 | genFunction _ program val = do 34 | let ident = symbolVal (Proxy :: Proxy name) 35 | loc <- withCString ident $ glGetUniformLocation program 36 | $func loc val 37 | glGetError >>= \case 38 | 0 -> return () 39 | e -> do 40 | putStrLn $ unwords [ "Could not update uniform" 41 | , ident 42 | , "with value" 43 | , show val 44 | , ", encountered error (" ++ show e ++ ")" 45 | , show (GL_INVALID_OPERATION :: Integer, "invalid operation" :: String) 46 | , show (GL_INVALID_VALUE :: Integer, "invalid value" :: String) 47 | ] 48 | assert False $ return () 49 | 50 | |] 51 | -------------------------------------------------------------------------------- /gelatin-gl/stack80-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2016-09-08 2 | compiler: ghcjs-0.2.0.820160908_ghc-8.0.1 3 | compiler-check: match-exact 4 | setup-info: 5 | ghcjs: 6 | source: 7 | ghcjs-0.2.0.820160908_ghc-8.0.1: 8 | url: "http://tolysz.org/ghcjs/untested/ghc-8.0-2016-09-08-nightly-2016-09-08-820160908.tar.gz" 9 | sha1: 68ab94c735ba5173603fb24fa7804541600750e1 10 | allow-newer: true 11 | 12 | packages: 13 | - . 14 | - ../gelatin 15 | 16 | extra-deps: [] 17 | -------------------------------------------------------------------------------- /gelatin-glfw/.sosrc: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - stack.yaml$ 4 | - .*\.cabal$ 5 | commands: 6 | - stack build 7 | - stack exec hlint \0 8 | -------------------------------------------------------------------------------- /gelatin-glfw/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Schell Scivally 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /gelatin-glfw/README.md: -------------------------------------------------------------------------------- 1 | gelatin-glfw 2 | ============ 3 | A [GLFW-b][1] based backend for the gelatin renderer. 4 | 5 | [1]: https://github.com/bsl/glfw-b 6 | -------------------------------------------------------------------------------- /gelatin-glfw/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin-glfw/gelatin-glfw.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-glfw 2 | version: 0.0.0.1 3 | synopsis: A GLFW backend for the gelatin-picture graphics DSL. 4 | description: Using GLFW this package provides a backend to 5 | gelatin-picture, a DSL for decribing two dimensional 6 | pictures. For writing full blown graphical applications 7 | please see jello-glfw. 8 | homepage: https://github.com/schell/gelatin 9 | license: MIT 10 | license-file: LICENSE 11 | author: Schell Scivally 12 | maintainer: schell.scivally@synapsegroup.com 13 | category: Graphics 14 | build-type: Simple 15 | cabal-version: >=1.10 16 | stability: experimental 17 | 18 | library 19 | exposed-modules: Gelatin.GLFW 20 | build-depends: base >=4.8 && < 4.12 21 | , linear >=1.20 && <1.21 22 | , GLFW-b >=1.4 && <1.5 23 | , gelatin-gl >=0.0 && <0.1 24 | , bytestring >=0.10 && <0.11 25 | , vector >=0.11 && <0.13 26 | , directory >=1.2 && <1.4 27 | , hashable >=1.2 && <1.3 28 | hs-source-dirs: src 29 | default-language: Haskell2010 30 | -------------------------------------------------------------------------------- /gelatin-glfw/src/Gelatin/GLFW.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | module Gelatin.GLFW ( 5 | Rez(..), 6 | -- * Startup 7 | startupGLFWBackend, 8 | newWindow, 9 | -- * Rendering 10 | renderWithGLFW, 11 | updateWindowGLFW, 12 | -- * Re-exports 13 | module GL, 14 | module GLFW 15 | ) where 16 | 17 | import Gelatin.GL as GL 18 | import Control.Monad 19 | import Control.Arrow (second) 20 | import Data.Hashable 21 | import Data.Bits ((.|.)) 22 | import Graphics.UI.GLFW as GLFW 23 | import Linear hiding (rotate) 24 | import System.Exit 25 | import System.IO 26 | import GHC.Generics 27 | 28 | -- | Creates a window. This can only be called after initializing with 29 | -- `initGelatin`. 30 | newWindow :: Int -- ^ Width 31 | -> Int -- ^ Height 32 | -> String -- ^ Title 33 | -> Maybe Monitor -- ^ The monitor to fullscreen into. 34 | -> Maybe Window -- ^ A window to share OpenGL contexts with. 35 | -> IO Window 36 | newWindow ww wh ws mmon mwin = do 37 | defaultWindowHints 38 | windowHint $ WindowHint'OpenGLDebugContext True 39 | windowHint $ WindowHint'OpenGLProfile OpenGLProfile'Core 40 | windowHint $ WindowHint'OpenGLForwardCompat True 41 | windowHint $ WindowHint'ContextVersionMajor 3 42 | windowHint $ WindowHint'ContextVersionMinor 3 43 | windowHint $ WindowHint'DepthBits 16 44 | mwin' <- createWindow ww wh ws mmon mwin 45 | makeContextCurrent mwin' 46 | case mwin' of 47 | Nothing -> do putStrLn "could not create window" 48 | exitFailure 49 | Just win -> return win 50 | 51 | calculateDpi :: Window -> IO Int 52 | calculateDpi win = do 53 | mMonitor <- getPrimaryMonitor 54 | -- Calculate the dpi of the primary monitor. 55 | case mMonitor of 56 | -- I've choosen 128 as the default DPI because of my macbook 15" 57 | -- -Schell 58 | Nothing -> return 128 59 | Just m -> do (w, h) <- getMonitorPhysicalSize m 60 | mvmode <- getVideoMode m 61 | case mvmode of 62 | Nothing -> return 128 63 | Just (VideoMode vw vh _ _ _ _) -> do 64 | let mm2 = fromIntegral $ w*h :: Double 65 | px = sqrt $ (fromIntegral vw :: Double) 66 | * fromIntegral vh 67 | inches = sqrt $ mm2 / (25.4 * 25.4) 68 | let dpi = floor $ px / inches 69 | return dpi 70 | 71 | -- | Completes all initialization, creates a new window and returns 72 | -- the resource record and the new window. If any part of the process fails the 73 | -- program will exit with failure. 74 | startupGLFWBackend :: Int -- ^ Window width 75 | -> Int -- ^ Window height 76 | -> String -- ^ Window title 77 | -> Maybe Monitor -- ^ The monitor to fullscreen into 78 | -> Maybe Window -- ^ A window to share OpenGL contexts with 79 | -> IO (Rez, Window) 80 | startupGLFWBackend ww wh ws mmon mwin = do 81 | setErrorCallback $ Just $ \_ -> hPutStrLn stderr 82 | initd <- GLFW.init 83 | unless initd $ do putStrLn "could not initialize glfw" 84 | exitFailure 85 | w <- newWindow ww wh ws mmon mwin 86 | sh <- loadSumShader 87 | 88 | glEnable GL_BLEND 89 | glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA 90 | 91 | let ctx = Context { ctxFramebufferSize = getFramebufferSize w 92 | , ctxWindowSize = getWindowSize w 93 | , ctxScreenDpi = calculateDpi w 94 | } 95 | return (Rez sh ctx, w) 96 | 97 | updateWindowGLFW :: Window -> IO () 98 | updateWindowGLFW = swapBuffers 99 | 100 | renderWithGLFW :: Window -> Rez -> Cache IO PictureTransform 101 | -> Picture GLuint () -> IO (Cache IO PictureTransform) 102 | renderWithGLFW window rez cache pic = do 103 | clearFrame rez 104 | (r, newCache) <- compilePictureRenderer rez cache pic 105 | snd r mempty 106 | updateWindowGLFW window 107 | cleanPictureRendererCache newCache pic 108 | -------------------------------------------------------------------------------- /gelatin-sdl2/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Schell Scivally 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /gelatin-sdl2/README.md: -------------------------------------------------------------------------------- 1 | gelatin-sdl2 2 | ============ 3 | A [SDL2][1] based backend for the gelatin renderer. 4 | 5 | [1]: https://github.com/haskell-game/sdl2 6 | -------------------------------------------------------------------------------- /gelatin-sdl2/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin-sdl2/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | import Control.Arrow 3 | import Control.Concurrent (threadDelay) 4 | import Control.Monad (forM_, forever, when) 5 | import Control.Monad.Trans.Except (runExceptT) 6 | import Gelatin.SDL2 7 | import Paths_gelatin_sdl2 8 | import SDL 9 | import System.Exit (exitFailure, exitSuccess) 10 | import System.FilePath (()) 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Regular pure pictures 14 | -------------------------------------------------------------------------------- 15 | colorGeometry :: Geometry (V2 Float, V4 Float) 16 | colorGeometry = do 17 | triangles tris 18 | beziers $ mapVertices (first (+ V2 100 0)) tris 19 | line $ mapVertices (first (+V2 200 0)) tris 20 | line $ mapVertices (first (+V2 300 0)) bcurve 21 | line $ mapVertices (first ((+V2 300 100) . (*V2 1 (-1)))) bcurve 22 | line $ mapVertices (first (+V2 350 50)) circle 23 | where tris = do tri (0, red) (V2 100 0, green) (100, blue) 24 | tri (0, magenta) (V2 0 100, canary) (100, cyan) 25 | bcurve = mapVertices (\v -> (v,white)) $ 26 | curve (V2 0 100) (V2 50 (-50)) 100 27 | circle = mapVertices (\v -> (v,white)) $ arc 50 50 0 (2*pi) 28 | 29 | colorPicture :: ColorPicture () 30 | colorPicture = do 31 | setStroke [StrokeWidth 3, StrokeFeather 1] 32 | setGeometry colorGeometry 33 | 34 | bezierPicture :: ColorPicture () 35 | bezierPicture = setGeometry $ beziers $ do 36 | bez (V2 0 0, white) (V2 200 0, blue) (V2 200 200, green) 37 | bez (V2 400 200, white) (V2 400 0, blue) (V2 200 0, green) 38 | 39 | texturePicture :: GLuint -> V2 Int -> TexturePicture () 40 | texturePicture tex (V2 w h) = do 41 | setStroke [StrokeWidth 3, StrokeFeather 1] 42 | setTextures [tex] 43 | setGeometry $ mapGeometry toUV colorGeometry 44 | where toUV (V2 x y, _) = (V2 x y, V2 (x/fromIntegral w) (y/fromIntegral h)) 45 | 46 | isQuit :: Event -> Bool 47 | isQuit (Event _ payload) = isKeyQ payload || payload == QuitEvent 48 | where 49 | isKeyQ (KeyboardEvent (KeyboardEventData _ _ _ (Keysym _ KeycodeQ _))) = True 50 | isKeyQ _ = False 51 | 52 | -- Start up our backend(s) and go! 53 | main :: IO () 54 | main = 55 | runExceptT (startupSDL2Backends 920 420 "gelatin-sdl2-example" True) >>= \case 56 | Left err -> putStrLn err >> exitFailure 57 | Right (SDL2Backends glv2v4 glv2v2) -> do 58 | -- Load up a texture. This can be done with either backend, as they both 59 | -- share the same OpenGL context. 60 | imgName <- getDataFileName $ "img" "lava.png" 61 | Just (tex, sz) <- allocTexture glv2v2 imgName 62 | -- Compiler our picture descriptions, sending their geometry to the GPU and 63 | -- returning a renderable resource and a cleanup action. The result of the 64 | -- picture computation is discarded. 65 | (_, colorRender) <- compilePicture glv2v4 colorPicture 66 | (_, bezierRenderer) <- compilePicture glv2v4 bezierPicture 67 | (_, texRender) <- compilePicture glv2v2 $ texturePicture tex sz 68 | -- Forever run the main loop, which polls for SDL events, clear the window, 69 | -- render our resources at different places with different transforms, and 70 | -- update the window with the new frame. 71 | forever $ do 72 | threadDelay 1 73 | events <- getEvents glv2v4 74 | when (any isQuit events) exitSuccess 75 | clearWindow glv2v4 76 | let indices = [0..10] 77 | forM_ indices $ \i -> do 78 | let txy = move (100 - 10 * i) (100 - 10 * i) 79 | a = alpha $ i/10 80 | rs = [txy, a] 81 | snd colorRender rs 82 | snd bezierRenderer $ move 400 0 : rs 83 | snd texRender $ move 0 200 : rs 84 | updateWindow glv2v4 85 | -------------------------------------------------------------------------------- /gelatin-sdl2/gelatin-sdl2.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-sdl2 2 | version: 0.1.1.0 3 | synopsis: An SDL2 backend for the gelatin renderer. 4 | description: Using SDL2 this package provides a backend to 5 | gelatin, an EDSL rendering pictures. 6 | homepage: https://github.com/schell/gelatin 7 | license: MIT 8 | license-file: LICENSE 9 | author: Schell Scivally 10 | maintainer: schell@takt.com 11 | category: Graphics 12 | build-type: Simple 13 | cabal-version: >= 1.10 14 | data-files: img/*.png 15 | stability: experimental 16 | 17 | library 18 | exposed-modules: Gelatin.SDL2 19 | ghc-options: -Wall 20 | build-depends: base >=4.8 && < 4.12 21 | , sdl2 >=2.4.0.1 && <2.5 22 | , gelatin-gl >=0.1 && <0.2 23 | , mtl >=2.2 && <2.3 24 | , transformers >=0.4 && <0.6 25 | hs-source-dirs: src 26 | default-language: Haskell2010 27 | 28 | executable gelatin-sdl2-example 29 | hs-source-dirs: app 30 | main-is: Main.hs 31 | other-modules: Paths_gelatin_sdl2 32 | ghc-options: -Wall 33 | default-language: Haskell2010 34 | build-depends: base >=4.8 && < 4.12 35 | , gelatin-sdl2 36 | , sdl2 >=2.4.0.1 && <2.5 37 | , filepath >=1.4 && <1.5 38 | , transformers >= 0.5 39 | -------------------------------------------------------------------------------- /gelatin-sdl2/img/lava.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/schell/gelatin/04c1c83d4297eac4f4cc5e8e5c805b1600b3ee98/gelatin-sdl2/img/lava.png -------------------------------------------------------------------------------- /gelatin-sdl2/sosrc-dev: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - stack.yaml$ 4 | - .*\.cabal$ 5 | commands: 6 | - stack build --fast 7 | - stack exec hlint \0 8 | - stack exec gelatin-sdl2-example 9 | -------------------------------------------------------------------------------- /gelatin-sdl2/src/Gelatin/SDL2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | -- | This module provides an entry point for your gelatin 6 | -- apps that run on sdl2. 7 | module Gelatin.SDL2 8 | ( -- * Backend definitions 9 | SDL2Backends(..) 10 | -- * Getting a window and the backends 11 | , initSDL2Window 12 | , startupSDL2BackendsWithWindow 13 | -- * Obtaining the backends without a window 14 | , startupSDL2BackendsWithConfig 15 | , startupSDL2Backends 16 | -- * Re-exports 17 | , module Gelatin.GL 18 | ) where 19 | 20 | import Control.Monad.Except (MonadError) 21 | import Control.Monad.IO.Class (MonadIO, liftIO) 22 | import Data.String (fromString) 23 | import Gelatin.GL 24 | import SDL hiding (Rectangle, Renderer, 25 | glBindTexture, glUnbindTexture) 26 | 27 | 28 | -- | A record containing both V2V4 and V2V2 backends. 29 | data SDL2Backends = SDL2Backends 30 | { backendV2V4 :: Backend GLuint Event V2V4 (V2 Float) Float Raster 31 | , backendV2V2 :: Backend GLuint Event V2V2 (V2 Float) Float Raster 32 | } 33 | 34 | 35 | -- | Creates and returns an SDL2 window. 36 | initSDL2Window 37 | :: MonadIO m 38 | => WindowConfig 39 | -- ^ The window configuration 40 | -> String 41 | -- ^ The window title. 42 | -> m Window 43 | initSDL2Window cfg title = liftIO $ do 44 | initializeAll 45 | w <- createWindow (fromString title) cfg 46 | _ <- glCreateContext w 47 | return w 48 | 49 | -- | Start up and return the sdl2 backends using the given window. 50 | startupSDL2BackendsWithWindow 51 | :: (MonadIO m, MonadError String m) 52 | => Window 53 | -- ^ The 'Window' to use render into. 54 | -> m SDL2Backends 55 | startupSDL2BackendsWithWindow window = do 56 | sh <- loadSimple2DShader 57 | 58 | liftIO $ do 59 | glEnable GL_BLEND 60 | glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA 61 | 62 | let wsize = do V2 x y <- get $ windowSize window 63 | return (fromIntegral x, fromIntegral y) 64 | fsize = do V2 x y <- glGetDrawableSize window 65 | return (fromIntegral x, fromIntegral y) 66 | 67 | ctx = Context { ctxFramebufferSize = fsize 68 | , ctxWindowSize = wsize 69 | } 70 | rz = Rez sh ctx 71 | ops = glOps rz (updateWindowSDL2 window) pollEvents 72 | v2v4 = Backend ops $ glV2V4Compiler rz 73 | v2v2 = Backend ops $ glV2V2Compiler rz 74 | return $ SDL2Backends v2v4 v2v2 75 | 76 | 77 | -- | Start up and return the sdl2 backends according to the given 78 | -- sdl2 'WindowConfig'. 79 | startupSDL2BackendsWithConfig 80 | :: (MonadIO m, MonadError String m) 81 | => WindowConfig 82 | -- ^ The configuration used to set up the window. 83 | -> String 84 | -- ^ The window title 85 | -> m SDL2Backends 86 | startupSDL2BackendsWithConfig cfg str = do 87 | w <- initSDL2Window cfg str 88 | startupSDL2BackendsWithWindow w 89 | 90 | 91 | -- | Start up and return the default backends. 92 | -- Uses OpenGL 3.3 with debugging turned on. 93 | startupSDL2Backends 94 | :: (MonadIO m, MonadError String m) 95 | => Int 96 | -- ^ Window width 97 | -> Int 98 | -- ^ Window height 99 | -> String 100 | -- ^ Window title 101 | -> Bool 102 | -- ^ Whether or not to request a high DPI window. 103 | -- Passing 'True' typically results in a framebuffer with 2x 104 | -- the window size. 105 | -> m SDL2Backends 106 | startupSDL2Backends ww wh ws highDPI = do 107 | let openGL = defaultOpenGL{ glProfile = Core Debug 3 3 108 | } 109 | window = defaultWindow{ windowInitialSize = V2 (fromIntegral ww) 110 | (fromIntegral wh) 111 | , windowOpenGL = Just openGL 112 | , windowResizable = True 113 | , windowHighDPI = highDPI 114 | } 115 | startupSDL2BackendsWithConfig window ws 116 | 117 | 118 | updateWindowSDL2 :: Window -> IO () 119 | updateWindowSDL2 = glSwapWindow 120 | -------------------------------------------------------------------------------- /gelatin-shaders/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Schell Scivally (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Schell Scivally nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /gelatin-shaders/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin-shaders/gelatin-shaders.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-shaders 2 | version: 0.1.0.0 3 | synopsis: Gelatin's OpenGL shaders. 4 | description: Gelatin's OpenGL shaders. Please see README.md 5 | homepage: https://github.com/schell/gelatin-shaders#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Schell Scivally 9 | maintainer: schell@zyghost.com 10 | copyright: Schell Scivally 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | data-files: shaders/*.frag, 15 | shaders/*.vert 16 | stability: experimental 17 | 18 | library 19 | hs-source-dirs: src 20 | exposed-modules: Gelatin.Shaders.Common 21 | , Gelatin.Shaders.Simple2D 22 | , Gelatin.Shaders.TypeLevel 23 | , Gelatin.Shaders 24 | other-modules: Paths_gelatin_shaders 25 | build-depends: base >=4.8 && < 4.12 26 | , gelatin >=0.1 && <0.2 27 | , bytestring >=0.10 && <0.11 28 | , filepath >=1.4 && <1.5 29 | default-language: Haskell2010 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/schell/gelatin-shaders 34 | -------------------------------------------------------------------------------- /gelatin-shaders/shaders/simple2d.frag: -------------------------------------------------------------------------------- 1 | #version 330 core 2 | 3 | in vec4 fcolor; 4 | in vec2 fuv; 5 | in vec3 fbez; 6 | in vec2 fbezuv; 7 | 8 | out vec4 fragColor; 9 | 10 | uniform int primitive; 11 | uniform bool hasUV; 12 | uniform sampler2D sampler; 13 | uniform sampler2D mainTex; 14 | uniform sampler2D maskTex; 15 | uniform float thickness; 16 | uniform float feather; 17 | uniform float sumlength; 18 | uniform vec2 cap; 19 | uniform float alpha; 20 | uniform vec4 mult; 21 | 22 | uniform vec4 replaceColor; 23 | uniform bool shouldColorReplace; 24 | 25 | // Primitive types 26 | const int PrimTri = 0; 27 | const int PrimBez = 1; 28 | const int PrimLine = 2; 29 | const int PrimMask = 4; 30 | 31 | // Types for rendering line caps 32 | const float CapNone = 0; 33 | const float CapButt = 1; 34 | const float CapSquare = 2; 35 | const float CapRound = 3; 36 | const float CapTriOut = 4; 37 | const float CapTriIn = 5; 38 | 39 | // Colors a fragment based solely on either an input color or a texture. 40 | vec4 coord_fragment(bool isUV, 41 | sampler2D s, 42 | vec4 clr, 43 | vec2 uvs) { 44 | if (isUV) { 45 | return texture(s, uvs.st); 46 | } else { 47 | return clr; 48 | } 49 | } 50 | 51 | // Colors a fragment using Loop-Blinn curve rendering. 52 | vec4 bez_fragment(bool isUV, 53 | sampler2D s, 54 | vec3 bz, 55 | vec4 clr, 56 | vec2 uvs) { 57 | vec2 p = bz.xy; 58 | // when cw is true, winding is clockwise and we're drawing outside the 59 | // curve. 60 | bool cw = bool(bz.z); 61 | // gradients 62 | vec2 px = dFdx(p); 63 | vec2 py = dFdy(p); 64 | // chain rule 65 | float fx = (2*p.x)*px.x - px.y; 66 | float fy = (2*p.x)*py.x - py.y; 67 | // signed distance 68 | float sd = (p.x*p.x - p.y) / sqrt(fx*fx + fy*fy); 69 | // linear alpha 70 | float alpha = 0.5 - sd; 71 | alpha = cw ? 1 - alpha : alpha; 72 | // find the resulting fragment color 73 | float a = 0; 74 | 75 | if (alpha > 1) { 76 | a = 1; 77 | } else if (alpha < 0) { 78 | discard; 79 | } else { 80 | // we are right on the boundary, interpolate the color intensity. 81 | a = alpha; 82 | } 83 | 84 | vec4 color = vec4(0); 85 | if (isUV) { 86 | color = texture(s, uvs.st); 87 | } else { 88 | color = clr; 89 | } 90 | return vec4(color.rgb, color.a * a); 91 | } 92 | 93 | // Renders a polyline cap fragment. 94 | float capd(float type, float u, float v, float t ) { 95 | // None 96 | if ( type == CapNone) discard; 97 | // Round 98 | else if (type == CapRound) return sqrt(u*u+v*v); 99 | // Triangle out 100 | else if (type == CapTriOut) return (u+abs(v)); 101 | // Triangle in 102 | else if (type == CapTriIn) return max(abs(v),(t+u-abs(v))); 103 | // Square 104 | else if (type == CapSquare) return max(u,v); 105 | // Butt 106 | else if (type == CapButt) return max(u+t,v); 107 | discard; 108 | } 109 | 110 | vec4 line_fragment(float thick, 111 | float fthr, 112 | float slen, 113 | vec2 cp, 114 | bool isUV, 115 | sampler2D s, 116 | vec4 clr, 117 | vec2 bzuv, 118 | vec2 uvs) { 119 | float u = bzuv.x; 120 | float v = bzuv.y; 121 | float l = slen; 122 | float dx = abs(min(u, u - l)); 123 | float dy = abs(v); 124 | float d = dy; 125 | 126 | vec4 color = vec4(0); 127 | if (isUV) { 128 | color = texture(s, uvs.st); 129 | } else { 130 | color = clr; 131 | } 132 | 133 | float t = thick/2.0 - fthr; 134 | 135 | if (u < 0) { 136 | // fragment is in the start cap 137 | d = capd(cp.x, abs(u), dy, t); 138 | } else if (u > slen) { 139 | // fragment is in the end cap 140 | d = capd(cp.y, u - l, dy, t); 141 | } 142 | 143 | d -= t; 144 | if (d < 0.0) { 145 | return color; 146 | } else { 147 | d /= fthr; 148 | return vec4(color.rgb, exp(-d*d)*color.a); 149 | } 150 | } 151 | 152 | // Colors a fragment using two textures, one the input texture and one as the 153 | // alpha masking texture. 154 | vec4 mask_fragment(sampler2D main, 155 | sampler2D mask, 156 | vec2 uvs) { 157 | vec4 color = texture(main, uvs.st); 158 | vec4 msk = texture(mask, uvs.st); 159 | return vec4(color.rgb, color.a * msk.a); 160 | } 161 | 162 | // Runs a color op on the fragment. 163 | vec4 color_op_fragment(vec4 c, float a, vec4 m) { 164 | vec4 c1 = vec4(0); 165 | if (shouldColorReplace) { 166 | // Use a replacement color multiplied by the current red channel value. 167 | c1 = vec4(replaceColor.r, replaceColor.g, replaceColor.b, replaceColor.a * c.r) * m; 168 | } else { 169 | c1 = c * m; 170 | } 171 | return vec4(c1.rgb, c1.a * a); 172 | } 173 | 174 | void main() { 175 | vec4 out_color = vec4(0); 176 | switch (primitive) { 177 | case PrimTri: 178 | out_color = coord_fragment(hasUV, sampler, fcolor, fuv); 179 | break; 180 | case PrimBez: 181 | out_color = bez_fragment(hasUV, sampler, fbez, fcolor, fuv); 182 | break; 183 | case PrimLine: { 184 | out_color = line_fragment(thickness, feather, sumlength, cap, hasUV, 185 | sampler, fcolor, fbezuv, fuv); 186 | break; 187 | } 188 | case PrimMask: 189 | out_color = mask_fragment(mainTex, maskTex, fuv); 190 | break; 191 | default: 192 | break; 193 | } 194 | 195 | fragColor = color_op_fragment(out_color, alpha, mult); 196 | } 197 | -------------------------------------------------------------------------------- /gelatin-shaders/shaders/simple2d.vert: -------------------------------------------------------------------------------- 1 | #version 330 core 2 | 3 | in vec2 position; 4 | in vec4 color; 5 | in vec2 uv; 6 | in vec3 bez; 7 | in vec2 bezuv; 8 | in vec2 next; 9 | in vec2 previous; 10 | 11 | out vec4 fcolor; 12 | out vec2 fuv; 13 | out vec3 fbez; 14 | out vec2 fbezuv; 15 | 16 | uniform int primitive; 17 | uniform mat4 projection; 18 | uniform mat4 modelview; 19 | uniform bool hasUV; 20 | uniform sampler2D sampler; 21 | uniform sampler2D mainTex; 22 | uniform sampler2D maskTex; 23 | uniform float thickness; 24 | 25 | // Primitive types 26 | const int PrimTri = 0; 27 | const int PrimBez = 1; 28 | const int PrimLine = 2; 29 | const int PrimMask = 4; 30 | 31 | // Projects a polyline segment into screen coordinates. 32 | vec4 project_line(mat4 pj, 33 | mat4 mv, 34 | float thick, 35 | vec2 pos, 36 | vec2 bzuv, 37 | vec2 nxt, 38 | vec2 prev) { 39 | vec2 a = prev; 40 | vec2 b = pos; 41 | vec2 c = nxt; 42 | vec2 ab = normalize(b - a); 43 | vec2 bc = normalize(c - b); 44 | vec2 tangent = normalize(ab + bc); 45 | vec2 extrusion = vec2(-tangent.y, tangent.x); 46 | float direction = sign(bzuv.y); 47 | float len = thick; 48 | 49 | // find the length of the miter line 50 | vec2 perpab = vec2(-ab.y,ab.x); 51 | len = len / dot(extrusion, perpab); 52 | 53 | vec2 delta = extrusion * len * direction; 54 | return pj * mv * vec4(pos + delta, 0.0, 1.0); 55 | } 56 | 57 | // Projects a plain point into screen coords. 58 | // Used for alpha masking and "regular" uv mapping and coloring. 59 | vec4 project_position(mat4 pj, mat4 mv, vec2 pos) { 60 | return pj * mv * vec4(pos.xy, 0.0, 1.0); 61 | } 62 | 63 | void main () { 64 | // Figure out what kind of projection to use. 65 | vec4 out_position = vec4(0); 66 | 67 | switch (primitive) { 68 | case PrimTri: 69 | case PrimBez: 70 | case PrimMask: 71 | out_position = project_position(projection, modelview, position); 72 | break; 73 | 74 | case PrimLine: { 75 | out_position = project_line(projection, modelview, thickness, position, 76 | bezuv, next, previous); 77 | break; 78 | } 79 | default: 80 | out_position = project_position(projection, modelview, position); 81 | } 82 | 83 | fcolor = color; 84 | fuv = uv; 85 | fbez = bez; 86 | fbezuv = bezuv; 87 | 88 | gl_Position = out_position; 89 | } 90 | -------------------------------------------------------------------------------- /gelatin-shaders/shaders/simple2dwebgl.frag: -------------------------------------------------------------------------------- 1 | #extension GL_OES_standard_derivatives : enable 2 | 3 | precision highp float; 4 | precision highp int; 5 | 6 | varying vec4 fcolor; 7 | varying vec2 fuv; 8 | varying vec3 fbez; 9 | varying vec2 fbezuv; 10 | 11 | uniform int primitive; 12 | uniform bool hasUV; 13 | uniform sampler2D sampler; 14 | uniform sampler2D mainTex; 15 | uniform sampler2D maskTex; 16 | uniform float thickness; 17 | uniform float feather; 18 | uniform float sumlength; 19 | uniform vec2 cap; 20 | uniform float alpha; 21 | uniform vec4 mult; 22 | 23 | uniform vec4 replaceColor; 24 | uniform bool shouldColorReplace; 25 | 26 | // Primitive types 27 | const int PrimTri = 0; 28 | const int PrimBez = 1; 29 | const int PrimLine = 2; 30 | const int PrimMask = 4; 31 | 32 | // Types for rendering line caps 33 | const float CapNone = 0.0; 34 | const float CapButt = 1.0; 35 | const float CapSquare = 2.0; 36 | const float CapRound = 3.0; 37 | const float CapTriOut = 4.0; 38 | const float CapTriIn = 5.0; 39 | 40 | // Colors a fragment based solely on either an input color or a texture. 41 | vec4 coord_fragment(bool isUV, 42 | sampler2D s, 43 | vec4 clr, 44 | vec2 uvs) { 45 | if (isUV) { 46 | return texture2D(s, uvs.st); 47 | } else { 48 | return clr; 49 | } 50 | } 51 | 52 | // Colors a fragment using Loop-Blinn curve rendering. 53 | vec4 bez_fragment(bool isUV, 54 | sampler2D s, 55 | vec3 bz, 56 | vec4 clr, 57 | vec2 uvs) { 58 | vec2 p = bz.xy; 59 | // when cw is true, winding is clockwise and we're drawing outside the 60 | // curve. 61 | bool cw = bool(bz.z); 62 | // gradients 63 | vec2 px = dFdx(p); 64 | vec2 py = dFdy(p); 65 | // chain rule 66 | float fx = (2.0*p.x)*px.x - px.y; 67 | float fy = (2.0*p.x)*py.x - py.y; 68 | // signed distance 69 | float sd = (p.x*p.x - p.y) / sqrt(fx*fx + fy*fy); 70 | // linear alpha 71 | float alpha = 0.5 - sd; 72 | alpha = cw ? 1.0 - alpha : alpha; 73 | // find the resulting fragment color 74 | float a = 0.0; 75 | 76 | if (alpha > 1.0) { 77 | a = 1.0; 78 | } else if (alpha < 0.0) { 79 | discard; 80 | } else { 81 | // we are right on the boundary, interpolate the color intensity. 82 | a = alpha; 83 | } 84 | 85 | vec4 color = vec4(0); 86 | if (isUV) { 87 | color = texture2D(s, uvs.st); 88 | } else { 89 | color = clr; 90 | } 91 | return vec4(color.rgb, color.a * a); 92 | } 93 | 94 | // Renders a polyline cap fragment. 95 | float capd(float type, float u, float v, float t ) { 96 | // None 97 | if ( type == CapNone) discard; 98 | // Round 99 | else if (type == CapRound) return sqrt(u*u+v*v); 100 | // Triangle out 101 | else if (type == CapTriOut) return (u+abs(v)); 102 | // Triangle in 103 | else if (type == CapTriIn) return max(abs(v),(t+u-abs(v))); 104 | // Square 105 | else if (type == CapSquare) return max(u,v); 106 | // Butt 107 | else if (type == CapButt) return max(u+t,v); 108 | discard; 109 | } 110 | 111 | vec4 line_fragment(float thick, 112 | float fthr, 113 | float slen, 114 | vec2 cp, 115 | bool isUV, 116 | sampler2D s, 117 | vec4 clr, 118 | vec2 bzuv, 119 | vec2 uvs) { 120 | float u = bzuv.x; 121 | float v = bzuv.y; 122 | float l = slen; 123 | float dx = abs(min(u, u - l)); 124 | float dy = abs(v); 125 | float d = dy; 126 | 127 | vec4 color = vec4(0); 128 | if (isUV) { 129 | color = texture2D(s, uvs.st); 130 | } else { 131 | color = clr; 132 | } 133 | 134 | float t = thick/2.0 - fthr; 135 | 136 | if (u < 0.0) { 137 | // fragment is in the start cap 138 | d = capd(cp.x, abs(u), dy, t); 139 | } else if (u > slen) { 140 | // fragment is in the end cap 141 | d = capd(cp.y, u - l, dy, t); 142 | } 143 | 144 | d -= t; 145 | if (d < 0.0) { 146 | return color; 147 | } else { 148 | d /= fthr; 149 | return vec4(color.rgb, exp(-d*d)*color.a); 150 | } 151 | } 152 | 153 | // Colors a fragment using two textures, one the input texture and one as the 154 | // alpha masking texture. 155 | vec4 mask_fragment(sampler2D main, 156 | sampler2D mask, 157 | vec2 uvs) { 158 | vec4 color = texture2D(main, uvs.st); 159 | vec4 msk = texture2D(mask, uvs.st); 160 | return vec4(color.rgb, color.a * msk.a); 161 | } 162 | 163 | // Runs a color op on the fragment. 164 | vec4 color_op_fragment(vec4 c, float a, vec4 m) { 165 | vec4 c1 = vec4(0); 166 | if (shouldColorReplace) { 167 | // Use a replacement color multiplied by the current red channel value. 168 | c1 = vec4(replaceColor.r, replaceColor.g, replaceColor.b, replaceColor.a * c.r) * m; 169 | } else { 170 | c1 = c * m; 171 | } 172 | return vec4(c1.rgb, c1.a * a); 173 | } 174 | 175 | void main() { 176 | vec4 out_color = vec4(0); 177 | if (primitive == PrimTri) { 178 | out_color = coord_fragment(hasUV, sampler, fcolor, fuv); 179 | } 180 | if (primitive == PrimBez) { 181 | out_color = bez_fragment(hasUV, sampler, fbez, fcolor, fuv); 182 | 183 | } 184 | if (primitive == PrimLine) { 185 | out_color = line_fragment(thickness, feather, sumlength, cap, hasUV, 186 | sampler, fcolor, fbezuv, fuv); 187 | } 188 | if (primitive == PrimMask) { 189 | out_color = mask_fragment(mainTex, maskTex, fuv); 190 | } 191 | 192 | gl_FragColor = color_op_fragment(out_color, alpha, mult); 193 | } 194 | -------------------------------------------------------------------------------- /gelatin-shaders/shaders/simple2dwebgl.vert: -------------------------------------------------------------------------------- 1 | precision highp float; 2 | precision highp int; 3 | 4 | attribute vec2 position; 5 | attribute vec4 color; 6 | attribute vec2 uv; 7 | attribute vec3 bez; 8 | attribute vec2 bezuv; 9 | attribute vec2 next; 10 | attribute vec2 previous; 11 | 12 | varying vec4 fcolor; 13 | varying vec2 fuv; 14 | varying vec3 fbez; 15 | varying vec2 fbezuv; 16 | 17 | uniform int primitive; 18 | uniform mat4 projection; 19 | uniform mat4 modelview; 20 | uniform bool hasUV; 21 | uniform sampler2D sampler; 22 | uniform sampler2D mainTex; 23 | uniform sampler2D maskTex; 24 | uniform float thickness; 25 | 26 | // Primitive types 27 | const int PrimTri = 0; 28 | const int PrimBez = 1; 29 | const int PrimLine = 2; 30 | const int PrimMask = 4; 31 | 32 | // Projects a polyline segment into screen coordinates. 33 | vec4 project_line(mat4 pj, 34 | mat4 mv, 35 | float thick, 36 | vec2 pos, 37 | vec2 bzuv, 38 | vec2 nxt, 39 | vec2 prev) { 40 | vec2 a = prev; 41 | vec2 b = pos; 42 | vec2 c = nxt; 43 | vec2 ab = normalize(b - a); 44 | vec2 bc = normalize(c - b); 45 | vec2 tangent = normalize(ab + bc); 46 | vec2 extrusion = vec2(-tangent.y, tangent.x); 47 | float direction = sign(bzuv.y); 48 | float len = thick; 49 | 50 | // find the length of the miter line 51 | vec2 perpab = vec2(-ab.y,ab.x); 52 | len = len / dot(extrusion, perpab); 53 | 54 | vec2 delta = extrusion * len * direction; 55 | return pj * mv * vec4(pos + delta, 0.0, 1.0); 56 | } 57 | 58 | // Projects a plain point into screen coords. 59 | // Used for alpha masking and "regular" uv mapping and coloring. 60 | vec4 project_position(mat4 pj, mat4 mv, vec2 pos) { 61 | return pj * mv * vec4(pos.xy, 0.0, 1.0); 62 | } 63 | 64 | void main () { 65 | // Figure out what kind of projection to use. 66 | vec4 out_position = vec4(0); 67 | 68 | if (primitive == PrimTri || primitive == PrimBez || primitive == PrimMask) { 69 | out_position = project_position(projection, modelview, position); 70 | } else if (primitive == PrimLine) { 71 | out_position = project_line(projection, modelview, thickness, position, 72 | bezuv, next, previous); 73 | } else { 74 | out_position = project_position(projection, modelview, position); 75 | } 76 | 77 | fcolor = color; 78 | fuv = uv; 79 | fbez = bez; 80 | fbezuv = bezuv; 81 | 82 | gl_Position = out_position; 83 | } 84 | -------------------------------------------------------------------------------- /gelatin-shaders/shaders/simple3d.frag: -------------------------------------------------------------------------------- 1 | #version 300 core 2 | 3 | in vec4 fcolor; 4 | in vec2 fuv; 5 | in vec3 fbez; 6 | in vec2 fbezuv; 7 | 8 | out vec4 fragColor; 9 | 10 | uniform int primitive; 11 | uniform bool hasUV; 12 | uniform sampler2D sampler; 13 | uniform sampler2D mainTex; 14 | uniform sampler2D maskTex; 15 | uniform float thickness; 16 | uniform float feather; 17 | uniform float sumlength; 18 | uniform vec2 cap; 19 | uniform float alpha; 20 | uniform vec4 mult; 21 | 22 | uniform vec4 replaceColor; 23 | uniform bool shouldColorReplace; 24 | 25 | // Primitive types 26 | const int PrimTri = 0; 27 | const int PrimBez = 1; 28 | const int PrimLine = 2; 29 | const int PrimMask = 4; 30 | 31 | // Types for rendering line caps 32 | const float CapNone = 0; 33 | const float CapButt = 1; 34 | const float CapSquare = 2; 35 | const float CapRound = 3; 36 | const float CapTriOut = 4; 37 | const float CapTriIn = 5; 38 | 39 | // Colors a fragment based solely on either an input color or a texture. 40 | vec4 coord_fragment(bool isUV, 41 | sampler2D s, 42 | vec4 clr, 43 | vec2 uvs) { 44 | if (isUV) { 45 | return texture(s, uvs.st); 46 | } else { 47 | return clr; 48 | } 49 | } 50 | 51 | // Colors a fragment using Loop-Blinn curve rendering. 52 | vec4 bez_fragment(bool isUV, 53 | sampler2D s, 54 | vec3 bz, 55 | vec4 clr, 56 | vec2 uvs) { 57 | vec2 p = bz.xy; 58 | // when cw is true, winding is clockwise and we're drawing outside the 59 | // curve. 60 | bool cw = bool(bz.z); 61 | // gradients 62 | vec2 px = dFdx(p); 63 | vec2 py = dFdy(p); 64 | // chain rule 65 | float fx = (2*p.x)*px.x - px.y; 66 | float fy = (2*p.x)*py.x - py.y; 67 | // signed distance 68 | float sd = (p.x*p.x - p.y) / sqrt(fx*fx + fy*fy); 69 | // linear alpha 70 | float alpha = 0.5 - sd; 71 | alpha = cw ? 1 - alpha : alpha; 72 | // find the resulting fragment color 73 | float a = 0; 74 | 75 | if (alpha > 1) { 76 | a = 1; 77 | } else if (alpha < 0) { 78 | discard; 79 | } else { 80 | // we are right on the boundary, interpolate the color intensity. 81 | a = alpha; 82 | } 83 | 84 | vec4 color = vec4(0); 85 | if (isUV) { 86 | color = texture(s, uvs.st); 87 | } else { 88 | color = clr; 89 | } 90 | return vec4(color.rgb, color.a * a); 91 | } 92 | 93 | // Renders a polyline cap fragment. 94 | float capd(float type, float u, float v, float t ) { 95 | // None 96 | if ( type == CapNone) discard; 97 | // Round 98 | else if (type == CapRound) return sqrt(u*u+v*v); 99 | // Triangle out 100 | else if (type == CapTriOut) return (u+abs(v)); 101 | // Triangle in 102 | else if (type == CapTriIn) return max(abs(v),(t+u-abs(v))); 103 | // Square 104 | else if (type == CapSquare) return max(u,v); 105 | // Butt 106 | else if (type == CapButt) return max(u+t,v); 107 | discard; 108 | } 109 | 110 | vec4 line_fragment(float thick, 111 | float fthr, 112 | float slen, 113 | vec2 cp, 114 | bool isUV, 115 | sampler2D s, 116 | vec4 clr, 117 | vec2 bzuv, 118 | vec2 uvs) { 119 | float u = bzuv.x; 120 | float v = bzuv.y; 121 | float l = slen; 122 | float dx = abs(min(u, u - l)); 123 | float dy = abs(v); 124 | float d = dy; 125 | 126 | vec4 color = vec4(0); 127 | if (isUV) { 128 | color = texture(s, uvs.st); 129 | } else { 130 | color = clr; 131 | } 132 | 133 | float t = thick/2.0 - fthr; 134 | 135 | if (u < 0) { 136 | // fragment is in the start cap 137 | d = capd(cp.x, abs(u), dy, t); 138 | } else if (u > slen) { 139 | // fragment is in the end cap 140 | d = capd(cp.y, u - l, dy, t); 141 | } 142 | 143 | d -= t; 144 | if (d < 0.0) { 145 | return color; 146 | } else { 147 | d /= fthr; 148 | return vec4(color.rgb, exp(-d*d)*color.a); 149 | } 150 | } 151 | 152 | // Colors a fragment using two textures, one the input texture and one as the 153 | // alpha masking texture. 154 | vec4 mask_fragment(sampler2D main, 155 | sampler2D mask, 156 | vec2 uvs) { 157 | vec4 color = texture(main, uvs.st); 158 | vec4 msk = texture(mask, uvs.st); 159 | return vec4(color.rgb, color.a * msk.a); 160 | } 161 | 162 | // Runs a color op on the fragment. 163 | vec4 color_op_fragment(vec4 c, float a, vec4 m) { 164 | vec4 c1 = vec4(0); 165 | if (shouldColorReplace) { 166 | // Use a replacement color multiplied by the current red channel value. 167 | c1 = vec4(replaceColor.r, replaceColor.g, replaceColor.b, replaceColor.a * c.r) * m; 168 | } else { 169 | c1 = c * m; 170 | } 171 | return vec4(c1.rgb, c1.a * a); 172 | } 173 | 174 | void main() { 175 | vec4 out_color = vec4(0); 176 | switch (primitive) { 177 | case PrimTri: 178 | out_color = coord_fragment(hasUV, sampler, fcolor, fuv); 179 | break; 180 | case PrimBez: 181 | out_color = bez_fragment(hasUV, sampler, fbez, fcolor, fuv); 182 | break; 183 | case PrimLine: { 184 | out_color = line_fragment(thickness, feather, sumlength, cap, hasUV, 185 | sampler, fcolor, fbezuv, fuv); 186 | break; 187 | } 188 | case PrimMask: 189 | out_color = mask_fragment(mainTex, maskTex, fuv); 190 | break; 191 | default: 192 | break; 193 | } 194 | 195 | fragColor = color_op_fragment(out_color, alpha, mult); 196 | } 197 | -------------------------------------------------------------------------------- /gelatin-shaders/shaders/simple3d.vert: -------------------------------------------------------------------------------- 1 | #version 300 core 2 | 3 | in vec3 position; 4 | in vec4 color; 5 | in vec2 uv; 6 | in vec3 bez; 7 | in vec2 bezuv; 8 | in vec3 next; 9 | in vec3 previous; 10 | 11 | out vec4 fcolor; 12 | out vec2 fuv; 13 | out vec3 fbez; 14 | out vec2 fbezuv; 15 | 16 | uniform int primitive; 17 | uniform mat4 projection; 18 | uniform mat4 modelview; 19 | uniform bool hasUV; 20 | uniform sampler2D sampler; 21 | uniform sampler2D mainTex; 22 | uniform sampler2D maskTex; 23 | uniform float thickness; 24 | 25 | // Primitive types 26 | const int PrimTri = 0; 27 | const int PrimBez = 1; 28 | const int PrimLine = 2; 29 | const int PrimMask = 4; 30 | 31 | // Projects a polyline segment into screen coordinates. 32 | vec4 project_line(mat4 pj, 33 | mat4 mv, 34 | float thick, 35 | vec3 pos, 36 | vec2 bzuv, 37 | vec2 nxt, 38 | vec2 prev) { 39 | vec3 a = prev; 40 | vec3 b = pos; 41 | vec3 c = nxt; 42 | vec3 ab = normalize(b - a); 43 | vec3 bc = normalize(c - b); 44 | vec3 tangent = normalize(ab + bc); 45 | vec3 extrusion = vec2(-tangent.y, tangent.x); 46 | float direction = sign(bzuv.y); 47 | float len = thick; 48 | 49 | // find the length of the miter line 50 | vec2 perpab = vec2(-ab.y,ab.x); 51 | len = len / dot(extrusion, perpab); 52 | 53 | vec2 delta = extrusion * len * direction; 54 | return pj * mv * vec4(pos + delta, 0.0, 1.0); 55 | } 56 | 57 | // Projects a plain point into screen coords. 58 | // Used for alpha masking and "regular" uv mapping and coloring. 59 | vec4 project_position(mat4 pj, mat4 mv, vec2 pos) { 60 | return pj * mv * vec4(pos.xy, 0.0, 1.0); 61 | } 62 | 63 | void main () { 64 | // Figure out what kind of projection to use. 65 | vec4 out_position = vec4(0); 66 | 67 | switch (primitive) { 68 | case PrimTri: 69 | case PrimBez: 70 | case PrimMask: 71 | out_position = project_position(projection, modelview, position); 72 | break; 73 | 74 | case PrimLine: { 75 | out_position = project_line(projection, modelview, thickness, position, 76 | bezuv, next, previous); 77 | break; 78 | } 79 | default: 80 | out_position = project_position(projection, modelview, position); 81 | } 82 | 83 | fcolor = color; 84 | fuv = uv; 85 | fbez = bez; 86 | fbezuv = bezuv; 87 | 88 | gl_Position = out_position; 89 | } 90 | -------------------------------------------------------------------------------- /gelatin-shaders/sosrc-dev: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - .*\.cabal$ 4 | commands: 5 | - stack install --fast 6 | - stack exec hlint \0 7 | -------------------------------------------------------------------------------- /gelatin-shaders/src/Gelatin/Shaders.hs: -------------------------------------------------------------------------------- 1 | module Gelatin.Shaders 2 | ( module S 3 | , simple2dVertFilePath 4 | , simple2dFragFilePath 5 | , simple2dVertWebGLFilePath 6 | , simple2dFragWebGLFilePath 7 | ) where 8 | 9 | import Gelatin.Shaders.Common as S 10 | import Gelatin.Shaders.Simple2D as S 11 | import Gelatin.Shaders.TypeLevel as S 12 | import Paths_gelatin_shaders as S 13 | import System.FilePath 14 | 15 | simple2dVertFilePath :: IO FilePath 16 | simple2dVertFilePath = getDataFileName $ "shaders" "simple2d.vert" 17 | 18 | simple2dFragFilePath :: IO FilePath 19 | simple2dFragFilePath = getDataFileName $ "shaders" "simple2d.frag" 20 | 21 | simple2dVertWebGLFilePath :: IO FilePath 22 | simple2dVertWebGLFilePath = getDataFileName $ "shaders" "simple2dwebgl.vert" 23 | 24 | simple2dFragWebGLFilePath :: IO FilePath 25 | simple2dFragWebGLFilePath = getDataFileName $ "shaders" "simple2dwebgl.frag" 26 | -------------------------------------------------------------------------------- /gelatin-shaders/src/Gelatin/Shaders/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE TypeSynonymInstances #-} 11 | module Gelatin.Shaders.Common 12 | ( VertexShader 13 | , FragmentShader 14 | , Uniform 15 | , Attribute 16 | , AttributeToggling 17 | , AttributeBuffering 18 | , IsShaderType(..) 19 | , ShaderSteps(..) 20 | ) where 21 | 22 | import Data.Proxy (Proxy (..)) 23 | -------------------------------------------------------------------------------- 24 | import Gelatin.Shaders.TypeLevel 25 | -------------------------------------------------------------------------------- 26 | -- $shader Defining shaders using (mostly) just types 27 | -------------------------------------------------------------------------------- 28 | data VertexShader 29 | data FragmentShader 30 | 31 | data ShaderType = ShaderTypeVertex | ShaderTypeFragment 32 | 33 | class IsShaderType a b where 34 | getShaderType :: Proxy a -> b 35 | 36 | instance IsShaderType VertexShader ShaderType where 37 | getShaderType _ = ShaderTypeVertex 38 | 39 | instance IsShaderType FragmentShader ShaderType where 40 | getShaderType _ = ShaderTypeFragment 41 | 42 | instance (IsShaderType t b, IsShaderType ts [b]) 43 | => IsShaderType (t ': ts) [b] where 44 | getShaderType _ = getShaderType (Proxy :: Proxy t) : getShaderType (Proxy :: Proxy ts) 45 | 46 | instance IsShaderType '[] [x] where 47 | getShaderType _ = [] 48 | 49 | -- | A glsl uniform type. 50 | data Uniform name val 51 | 52 | instance GetLits name String => GetLits (Uniform name val) String where 53 | getSymbols _ = getSymbols (Proxy :: Proxy name) 54 | 55 | -- | A glsl attribute type. 56 | data Attribute name val loc 57 | 58 | instance (GetLits name String, GetLits loc Integer) 59 | => GetLits (Attribute name val loc) (String, Integer) where 60 | getSymbols _ = 61 | let name = getSymbols (Proxy :: Proxy name) 62 | loc = getSymbols (Proxy :: Proxy loc) 63 | in (name, loc) 64 | 65 | -- | Used to resolve typeclass instances for generating enable/disable attribute 66 | -- functions. 67 | data AttributeToggling a 68 | 69 | -- | Used to resolve typeclass instances for generating attribute buffering 70 | -- functions. 71 | data AttributeBuffering a 72 | 73 | -- | A shader step is a step in the shader compilation process. This means that 74 | -- `ShaderSteps '[VertexShader, FragmentShader] [ByteString]` is a list of 75 | -- vertex and fragment shader source code that needs to be compiled. 76 | -- `ShaderSteps '[VertexShader, FragmentShader] GLuint` most likely means a list 77 | -- of vertex and fragment shaders that need to be linked. 78 | data ShaderSteps t v = ShaderSteps { unShaderSteps :: [v] } 79 | 80 | -- | This is some future work in progress. 81 | class MonadShader a where 82 | data M a :: * -> * 83 | 84 | data Program a 85 | readProgram :: (M a) (Program a) 86 | 87 | data Uniforms a 88 | updateUniforms :: Uniforms a -> (M a) () 89 | 90 | data Attributes a 91 | enableAttributes :: Attributes a -> (M a) () 92 | disableAttributes :: Attributes a -> (M a) () 93 | bufferAttributes :: Attributes a -> (M a) () 94 | -------------------------------------------------------------------------------- /gelatin-shaders/src/Gelatin/Shaders/Simple2D.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module Gelatin.Shaders.Simple2D where 4 | 5 | import Gelatin 6 | 7 | import Gelatin.Shaders.Common 8 | import Gelatin.Shaders.TypeLevel 9 | 10 | -- | TODO: Most of this stuff is shader specific and shoud be moved to a 11 | -- different part of the repo. 12 | 13 | -------------------------------------------------------------------------------- 14 | -- $layout 15 | -- Attributes layout locations are unique and global. 16 | -------------------------------------------------------------------------------- 17 | type APosition = Attribute "position" (V2 Float) 0 18 | type AColor = Attribute "color" (V4 Float) 1 19 | type AUV = Attribute "uv" (V2 Float) 2 20 | type ABez = Attribute "bez" (V3 Float) 3 21 | type ABezUV = Attribute "bezuv" (V2 Float) 4 22 | type APrev = Attribute "prev" (V2 Float) 5 23 | type ANext = Attribute "next" (V2 Float) 6 24 | 25 | type Simple2DAttribs = '[APosition, AColor, AUV, ABez, ABezUV, APrev, ANext] 26 | type Simple2DAttribToggles = TypeMap AttributeToggling Simple2DAttribs 27 | type Simple2DAttribBuffers = TypeMap AttributeBuffering Simple2DAttribs 28 | 29 | -------------------------------------------------------------------------------- 30 | -- $uniforms 31 | -- Uniform Helper Types 32 | -------------------------------------------------------------------------------- 33 | data PrimType = PrimTri 34 | | PrimBez 35 | | PrimLine 36 | | PrimMask 37 | deriving (Show, Eq, Enum, Ord, Bounded) 38 | -------------------------------------------------------------------------------- 39 | -- Updating uniforms 40 | -------------------------------------------------------------------------------- 41 | type UPrimType = Uniform "primitive" PrimType 42 | type UProjection = Uniform "projection" (M44 Float) 43 | type UModelView = Uniform "modelview" (M44 Float) 44 | type UThickness = Uniform "thickness" Float 45 | type UFeather = Uniform "feather" Float 46 | type USumLength = Uniform "sumlength" Float 47 | type ULineCaps = Uniform "cap" (LineCap,LineCap) 48 | type UHasUV = Uniform "hasUV" Bool 49 | type USampler = Uniform "sampler" Int 50 | type UMainTex = Uniform "mainTex" Int 51 | type UMaskTex = Uniform "maskTex" Int 52 | type UAlpha = Uniform "alpha" Float 53 | type UMult = Uniform "mult" (V4 Float) 54 | type UShouldReplaceColor = Uniform "shouldColorReplace" Bool 55 | type UReplaceColor = Uniform "replaceColor" (V4 Float) 56 | 57 | type Simple2DUniforms = '[ UPrimType 58 | , UProjection 59 | , UModelView 60 | , UThickness 61 | , UFeather 62 | , USumLength 63 | , ULineCaps 64 | , UHasUV 65 | , USampler 66 | , UMainTex 67 | , UMaskTex 68 | , UAlpha 69 | , UMult 70 | , UShouldReplaceColor 71 | , UReplaceColor 72 | ] 73 | 74 | type Simple2DShaders = '[VertexShader, FragmentShader] 75 | -------------------------------------------------------------------------------- /gelatin-shaders/src/Gelatin/Shaders/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE #-} 2 | module Gelatin.Shader.System where 3 | 4 | class ShaderSystem t where 5 | compileSources :: ShaderSteps 6 | -------------------------------------------------------------------------------- /gelatin-shaders/src/Gelatin/Shaders/TypeLevel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | module Gelatin.Shaders.TypeLevel 12 | ( -- * Type level combinators 13 | (:&)(..) 14 | -- * Generating symbol values on type lists 15 | , GetLits(..) 16 | -- * Generating function class 17 | , HasGenFunc(..) 18 | -- * Mapping types 19 | , TypeMap 20 | ) where 21 | 22 | import Data.Proxy (Proxy (..)) 23 | import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) 24 | -------------------------------------------------------------------------------- 25 | -- Type level combinators 26 | -------------------------------------------------------------------------------- 27 | -- | A heterogenious list. 28 | data a :& b = a :& b 29 | infixr 8 :& 30 | 31 | class GetLits a t where 32 | getSymbols :: Proxy a -> t 33 | 34 | instance GetLits '[] [t] where 35 | getSymbols _ = [] 36 | 37 | instance (GetLits a t, GetLits as [t]) => GetLits (a ': as) [t] where 38 | getSymbols _ = getSymbols (Proxy :: Proxy a) : getSymbols (Proxy :: Proxy as) 39 | 40 | instance KnownSymbol a => GetLits a String where 41 | getSymbols = symbolVal 42 | 43 | instance KnownNat a => GetLits a Integer where 44 | getSymbols = natVal 45 | -------------------------------------------------------------------------------- 46 | -- Generating a function from a type 47 | -------------------------------------------------------------------------------- 48 | class HasGenFunc a where 49 | type GenFunc a :: * 50 | genFunction :: Proxy a -> GenFunc a 51 | 52 | instance (HasGenFunc a, HasGenFunc b) => HasGenFunc (a :& b) where 53 | type GenFunc (a :& b) = GenFunc a :& GenFunc b 54 | genFunction _ = 55 | let a = (Proxy :: Proxy a) 56 | b = (Proxy :: Proxy b) 57 | in genFunction a :& genFunction b 58 | 59 | instance HasGenFunc '[] where 60 | type GenFunc '[] = () 61 | genFunction _ = () 62 | 63 | instance (HasGenFunc a, HasGenFunc as) => HasGenFunc (a ': as) where 64 | type GenFunc (a ': as) = GenFunc a :& GenFunc as 65 | genFunction _ = 66 | let a = (Proxy :: Proxy a) 67 | as = (Proxy :: Proxy as) 68 | in genFunction a :& genFunction as 69 | 70 | type family TypeMap (a :: * -> *) (xs :: [*]) :: [*] 71 | type instance TypeMap t '[] = '[] 72 | type instance TypeMap t (x ': xs) = t x ': TypeMap t xs 73 | -------------------------------------------------------------------------------- /gelatin-shaders/src/Gelatin/Shaders/`: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Gelatin.Shaders.Common 10 | ( VertexShader 11 | , FragmentShader 12 | , Uniform 13 | , Attribute 14 | , AttributeLocation(..) 15 | , AttributeToggling(..) 16 | , AttributeBuffering(..) 17 | , ShaderSource(..) 18 | , ProgramDef(..) 19 | , GetProgram(..) 20 | , getProgramDef 21 | , emptyProgramDef 22 | , addSource 23 | ) where 24 | 25 | import Data.ByteString.Char8 (ByteString) 26 | import Data.Proxy (Proxy (..)) 27 | -------------------------------------------------------------------------------- 28 | import Gelatin.Shaders.TypeLevel 29 | -------------------------------------------------------------------------------- 30 | -- $oldshader 31 | -------------------------------------------------------------------------------- 32 | -- | A Shader is a compiled shader program along with a list of uniform 33 | -- locations. 34 | --data Shader program uniform = Shader { shProgram :: program 35 | -- , shUniforms :: [(String, uniform)] 36 | -- } 37 | -- 38 | ---- | A ShaderDef is the definition of a shader, which is used to compile a 39 | ---- Shader. 40 | --data ShaderDef shadertype attribloc = 41 | -- ShaderDefFP { defShaderPaths :: [(String, shadertype)] 42 | -- , defUniforms :: [String] 43 | -- , defAttribs :: [attribloc] 44 | -- } 45 | -- | ShaderDefBS { defShaderSrcs :: [(ByteString, shadertype)] 46 | -- , defUniforms :: [String] 47 | -- , defAttribs :: [attribloc] 48 | -- } 49 | -------------------------------------------------------------------------------- 50 | -- $newshader A new kind of shader definition 51 | -------------------------------------------------------------------------------- 52 | data VertexShader 53 | data FragmentShader 54 | 55 | data ShaderType = ShaderTypeVertex | ShaderTypeFragment 56 | 57 | class IsShaderType a where 58 | getShaderType :: Proxy a -> ShaderType 59 | 60 | instance IsShaderType VertexShader where 61 | getShaderType _ = ShaderTypeVertex 62 | 63 | instance IsShaderType FragmentShader where 64 | getShaderType _ = ShaderTypeFragment 65 | 66 | -- | A glsl uniform type. 67 | data Uniform a 68 | 69 | instance GetSymbols a => GetSymbols (Uniform a) where 70 | getSymbols _ = getSymbols (Proxy :: Proxy a) 71 | 72 | -- | A glsl attribute type. 73 | data Attribute a loc 74 | 75 | -- | Used to resolve typeclass instances for generating enable/disable attribute 76 | -- functions. 77 | newtype AttributeToggling a b loc = AttributeToggling (Attribute (a := b) loc) 78 | 79 | -- | Used to resolve typeclass instances for generating attribute buffering 80 | -- functions. 81 | newtype AttributeBuffering a b = AttributeBuffering (Attribute (a := b) loc) 82 | 83 | -- | Used to resolve typeclass instances for generating attribute locations. 84 | newtype AttributeLocation a b = AttributeLocation (Attribute (a := b) loc) 85 | 86 | instance GetSymbols a => GetSymbols (Attribute a) where 87 | getSymbols _ = getSymbols (Proxy :: Proxy a) 88 | 89 | -- | A shader's source code. 90 | data ShaderSource t = ShaderSourcePath String 91 | | ShaderSourceBinary ByteString 92 | deriving (Show, Eq) 93 | 94 | stripShaderType :: ShaderSource t -> ShaderSource () 95 | stripShaderType (ShaderSourcePath path) = ShaderSourcePath path 96 | stripShaderType (ShaderSourceBinary src) = ShaderSourceBinary src 97 | -------------------------------------------------------------------------------- 98 | -- $program Defining programs of shaders 99 | -------------------------------------------------------------------------------- 100 | data ProgramDef s u a = 101 | ProgramDef { programDefSources :: [(ShaderType, ShaderSource ())] 102 | , programDefUniforms :: [String] 103 | , programDefAttribs :: [String] 104 | } 105 | 106 | instance Monoid (ProgramDef s u a) where 107 | mempty = ProgramDef [] [] [] 108 | mappend (ProgramDef a b c) (ProgramDef d e f) = 109 | ProgramDef (mappend a d) (mappend b e) (mappend c f) 110 | 111 | getProgramDef :: forall s u a t. (GetSymbols u, GetSymbols a, IsShaderType t) 112 | => ShaderSource t -> ProgramDef s u a 113 | getProgramDef source = 114 | let us = getSymbols (Proxy :: Proxy u) 115 | as = getSymbols (Proxy :: Proxy a) 116 | st = getShaderType (Proxy :: Proxy t) 117 | in ProgramDef { programDefSources = [(st, stripShaderType source)] 118 | , programDefUniforms = us 119 | , programDefAttribs = as 120 | } 121 | 122 | emptyProgramDef :: ProgramDef '[] u a 123 | emptyProgramDef = mempty 124 | 125 | addSource :: forall t ts u a. IsShaderType t 126 | => ProgramDef ts u a -> ShaderSource t -> ProgramDef (t ': ts) u a 127 | addSource def src = 128 | let st = getShaderType (Proxy :: Proxy t) 129 | srcs = programDefSources def 130 | in ProgramDef { programDefSources = (st, stripShaderType src) : srcs 131 | , programDefUniforms = programDefUniforms def 132 | , programDefAttribs = programDefAttribs def 133 | } 134 | 135 | class GetProgram t u a where 136 | type MkProgram t u a :: * 137 | compileProgram :: ProgramDef t u a -> MkProgram t u a 138 | -------------------------------------------------------------------------------- /gelatin-webgl/.sosrc: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - .*\.cabal$ 4 | commands: 5 | - stack install --fast 6 | - stack exec hlint \0 7 | -------------------------------------------------------------------------------- /gelatin-webgl/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Schell Scivally (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Schell Scivally nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /gelatin-webgl/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /gelatin-webgl/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Main where 3 | 4 | import Control.Arrow (first) 5 | import Control.Concurrent (threadDelay) 6 | import Control.Monad 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Trans.Either 9 | import GHCJS.DOM.JSFFI.Generated.Node 10 | import GHCJS.DOM.Types 11 | 12 | import Gelatin.WebGL 13 | 14 | import ImageData 15 | 16 | frag :: String 17 | frag = "https://raw.githubusercontent.com/schell/gelatin/master/gelatin-shaders/shaders/simple2dwebgl.frag" 18 | 19 | vert :: String 20 | vert = "https://raw.githubusercontent.com/schell/gelatin/master/gelatin-shaders/shaders/simple2dwebgl.vert" 21 | 22 | colorGeometry :: MonadIO m => GeometryT (V2 Float, V4 Float) m () 23 | colorGeometry = do 24 | triangles tris 25 | beziers $ mapVertices (first (+ V2 100 0)) tris 26 | line $ mapVertices (first (+V2 200 0)) tris 27 | line $ mapVertices (first (+V2 300 0)) bcurve 28 | line $ mapVertices (first ((+V2 300 100) . (*V2 1 (-1)))) bcurve 29 | line $ mapVertices (first (+V2 350 50)) circle 30 | where tris = do tri (0, red) (V2 100 0, green) (100, blue) 31 | tri (0, magenta) (V2 0 100, canary) (100, cyan) 32 | bcurve = mapVertices (\v -> (v,white)) $ 33 | curve (V2 0 100) (V2 50 (-50)) 100 34 | circle = mapVertices (\v -> (v,white)) $ arc 50 50 0 (2*pi) 35 | 36 | colorPicture :: MonadIO m => ColorPictureT m () 37 | colorPicture = do 38 | setStroke [StrokeWidth 3, StrokeFeather 1] 39 | setGeometry colorGeometry 40 | 41 | bezierPicture :: MonadIO m => ColorPictureT m () 42 | bezierPicture = setGeometry $ beziers $ do 43 | bez (V2 0 0, white) (V2 200 0, blue) (V2 200 200, green) 44 | bez (V2 400 200, white) (V2 400 0, blue) (V2 200 0, green) 45 | 46 | texturePicture :: MonadIO m => WebGLTexture -> V2 Int -> TexturePictureT m () 47 | texturePicture tex (V2 w h) = do 48 | setTextures [tex] 49 | setGeometry $ triangles $ tri (toUV tl) (toUV tr) (toUV br) 50 | where toUV :: V2 Float -> (V2 Float, V2 Float) 51 | toUV (V2 x y) = (V2 x y, V2 (x/fromIntegral w) (y/fromIntegral h)) 52 | tl = 0 53 | tr = fromIntegral <$> V2 w 0 54 | br = fromIntegral <$> V2 w h 55 | 56 | app :: MonadIO m => EitherT String m () 57 | app = do 58 | body <- webBody 59 | be <- startupWebGLBackends 600 400 vert frag 60 | void $ liftIO $ appendChild body $ Just $ backendCanvas be 61 | liftIO $ backendOpGetWindowSize (backendOps $ backendV2V4 be) >>= print 62 | 63 | let v2v2 = backendV2V2 be 64 | v2v4 = backendV2V4 be 65 | 66 | --loadImage imageData >>= void . liftIO . appendChild body . Just 67 | (_, colorPicRender) <- compilePictureT v2v4 colorPicture 68 | (_, bezPicRender) <- compilePictureT v2v4 bezierPicture 69 | 70 | liftIO (allocTexture (backendV2V2 be) imageData) >>= liftIO . \case 71 | Nothing -> putStrLn "Could not alloc texture." 72 | Just (tex, sz@(V2 w h)) -> do 73 | putStrLn $ "Texture is " ++ show (w, h) ++ "px" 74 | (_, texPicRender) <- compilePictureT v2v2 $ texturePicture tex sz 75 | clearWindow v2v4 76 | snd bezPicRender [move 0 150] 77 | snd texPicRender [] 78 | snd colorPicRender [] 79 | 80 | main :: IO () 81 | main = runEitherT app >>= \case 82 | Left str -> putStrLn str 83 | Right _ -> putStrLn "Done." 84 | -------------------------------------------------------------------------------- /gelatin-webgl/gelatin-webgl.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin-webgl 2 | version: 0.1.0.0 3 | synopsis: Gelatin's WebGL renderer. 4 | description: Gelatin's WebGL renderer. Please see README.md 5 | homepage: https://github.com/schell/gelatin-webgl#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Schell Scivally 9 | maintainer: schell@zyghost.com 10 | copyright: Schell Scivally 11 | category: Web, Graphics 12 | build-type: Simple 13 | cabal-version: >=1.18 14 | stability: experimental 15 | 16 | library 17 | hs-source-dirs: src 18 | ghc-options: -Wall -O2 19 | exposed-modules: Gelatin.WebGL 20 | , Gelatin.WebGL.Common 21 | , Gelatin.WebGL.Shaders 22 | , Gelatin.WebGL.Renderer 23 | 24 | build-depends: base >= 4.8 && < 4.11 25 | , gelatin >= 0.1 && < 0.2 26 | , gelatin-shaders >= 0.1 && < 0.2 27 | , ghcjs-base -any 28 | , ghcjs-dom -any 29 | , ghcjs-dom-jsffi 30 | , mtl >= 2.2 && < 2.3 31 | , async -any 32 | , vector >= 0.12 && < 0.13 33 | , bytestring >= 0.10 && < 0.11 34 | , stm -any 35 | , transformers >= 0.4 && < 0.6 36 | 37 | default-language: Haskell2010 38 | 39 | executable gelatin-webgl-exe 40 | hs-source-dirs: app 41 | main-is: Main.hs 42 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 43 | build-depends: base >=4.8 && < 4.12 44 | , gelatin 45 | , gelatin-webgl 46 | , gelatin-shaders 47 | , ghcjs-base 48 | , ghcjs-dom 49 | , ghcjs-dom-jsffi 50 | , transformers 51 | , either 52 | , async 53 | , vector 54 | , stm 55 | , transformers 56 | , bytestring 57 | 58 | default-language: Haskell2010 59 | 60 | test-suite gelatin-webgl-test 61 | type: exitcode-stdio-1.0 62 | hs-source-dirs: test 63 | main-is: Spec.hs 64 | build-depends: base >=4.8 && < 4.12 65 | , gelatin-webgl 66 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 67 | default-language: Haskell2010 68 | 69 | source-repository head 70 | type: git 71 | location: https://github.com/schell/gelatin-webgl 72 | -------------------------------------------------------------------------------- /gelatin-webgl/src/Gelatin/WebGL.hs: -------------------------------------------------------------------------------- 1 | module Gelatin.WebGL 2 | ( module G ) where 3 | 4 | import Gelatin as G 5 | import Gelatin.WebGL.Common as G 6 | import Gelatin.WebGL.Renderer as G 7 | import Gelatin.WebGL.Shaders as G 8 | -------------------------------------------------------------------------------- /gelatin-webgl/src/Gelatin/WebGL/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | module Gelatin.WebGL.Common where 6 | 7 | import Control.Monad.Reader 8 | import Control.Monad.Trans.Either 9 | import GHCJS.DOM.Types 10 | 11 | import Gelatin 12 | import Gelatin.Shaders 13 | 14 | type V2V4 = (V2 Float, V4 Float) 15 | type ColorPictureData = PictureData WebGLTexture (V2 Float, V4 Float) 16 | type ColorPictureT = PictureT WebGLTexture (V2 Float, V4 Float) 17 | 18 | type V2V2 = (V2 Float, V2 Float) 19 | type TexturePictureData = PictureData WebGLTexture (V2 Float, V2 Float) 20 | type TexturePictureT = PictureT WebGLTexture (V2 Float, V2 Float) 21 | 22 | type WebGLV2V2 = 23 | Backend WebGLTexture () V2V2 (V2 Float) Float Raster 24 | 25 | type WebGLV2V4 = 26 | Backend WebGLTexture () V2V4 (V2 Float) Float Raster 27 | 28 | data WebGLBackends = WebGLBackends { backendV2V4 :: WebGLV2V4 29 | , backendV2V2 :: WebGLV2V2 30 | , backendContext :: WebGLRenderingContextBase 31 | , backendCanvas :: HTMLCanvasElement 32 | } 33 | 34 | type WGLShaderDef = ShaderDef GLenum Simple2DAttrib 35 | type WGLShader = Shader WebGLProgram WebGLUniformLocation 36 | 37 | data GelatinContext = GelatinContext 38 | { gelCanvas :: HTMLCanvasElement 39 | , gelRenderingContext :: WebGLRenderingContextBase 40 | } 41 | 42 | type WebGLT m = EitherT String (ReaderT WebGLRenderingContextBase m) 43 | 44 | type Gelatin = ReaderT GelatinContext IO 45 | -------------------------------------------------------------------------------- /gelatin-webgl/src/Gelatin/WebGL/Shaders.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Gelatin.WebGL.Shaders where 4 | 5 | import Gelatin.Shaders 6 | import Gelatin.WebGL.Common 7 | 8 | import Control.Arrow (first) 9 | import Control.Concurrent (threadDelay) 10 | import Control.Monad (forM, 11 | forM_, 12 | unless) 13 | import Control.Monad.IO.Class 14 | import Control.Monad.Reader 15 | import Data.ByteString.Char8 (ByteString) 16 | import qualified Data.ByteString.Char8 as C8 17 | import Data.Function (fix) 18 | import Data.Maybe (catMaybes) 19 | import GHCJS.DOM.JSFFI.Generated.WebGLRenderingContextBase 20 | import GHCJS.DOM.JSFFI.Generated.XMLHttpRequest hiding 21 | (error) 22 | import GHCJS.DOM.Types 23 | import GHCJS.Marshal 24 | import GHCJS.Types 25 | 26 | wglCompileShader :: ToJSString s => s -> GLenum -> Gelatin WebGLShader 27 | wglCompileShader source shaderType = do 28 | gl <- asks gelRenderingContext 29 | shader <- createShader gl shaderType >>= \case 30 | Nothing -> error "Could not create a shader" 31 | Just sh -> return sh 32 | liftIO $ putStrLn "Created shader" 33 | shaderSource gl (Just shader) source 34 | liftIO $ putStrLn "Added shader source" 35 | compileShader gl (Just shader) 36 | liftIO $ putStrLn "Compiled shader source" 37 | let toBool :: MonadIO m => JSVal -> m (Maybe Bool) 38 | toBool val 39 | | isNull val = return Nothing 40 | | isUndefined val = return Nothing 41 | | otherwise = liftIO $ do 42 | putStrLn "Got compile status...reading it" 43 | fromJSVal val 44 | liftIO $ putStrLn "Checking shader compile status" 45 | getShaderParameter gl (Just shader) COMPILE_STATUS >>= toBool >>= \case 46 | Nothing -> do 47 | liftIO $ putStrLn "Could not check compile status...assuming it's all good." 48 | return shader 49 | Just success 50 | | success -> do 51 | liftIO $ putStrLn "Shader compiled successfully" 52 | return shader 53 | | otherwise -> do 54 | liftIO $ putStrLn "Checking shader info log" 55 | getShaderInfoLog gl (Just shader) >>= \case 56 | Nothing -> error "Encountered an unreadable error while compiling a shader." 57 | Just err -> error $ "Could not compile shader: " ++ fromJSString err 58 | 59 | wglCompileProgram :: [WebGLShader] -> [Simple2DAttrib] -> Gelatin WebGLProgram 60 | wglCompileProgram shaders attribs = do 61 | gl <- asks gelRenderingContext 62 | program <- createProgram gl >>= \case 63 | Nothing -> error "Could not create a shader program." 64 | Just p -> return p 65 | 66 | forM_ shaders (attachShader gl (Just program) . Just) 67 | forM_ attribs $ \attrib -> 68 | bindAttribLocation gl (Just program) (attribToGLuint attrib) 69 | (simple2DAttribIdentifier attrib) 70 | linkProgram gl (Just program) 71 | 72 | success <- fmap (\case 73 | Nothing -> False 74 | Just s -> s) $ 75 | getProgramParameter gl (Just program) LINK_STATUS >>= liftIO . fromJSVal 76 | 77 | unless success $ getProgramInfoLog gl (Just program) >>= \case 78 | Nothing -> error "Could not link program for some unreadable reason." 79 | Just jsstr -> error $ "Could not link program: " ++ fromJSString jsstr 80 | 81 | forM_ shaders (deleteShader gl . Just) 82 | return program 83 | -------------------------------------------------------------------------------- 84 | -- Loading shaders 85 | -------------------------------------------------------------------------------- 86 | loadGLShader :: WGLShaderDef -> Gelatin WGLShader 87 | loadGLShader (ShaderDefBS ss uniforms attribs) = do 88 | gl <- asks gelRenderingContext 89 | void $ getExtension gl "OES_standard_derivatives" 90 | shaders <- mapM (uncurry wglCompileShader . first C8.unpack) ss 91 | liftIO $ putStrLn "Compiled shaders" 92 | program <- wglCompileProgram shaders attribs 93 | liftIO $ putStrLn "Created and linked programs" 94 | useProgram gl $ Just program 95 | ulocs <- forM uniforms $ \u -> getUniformLocation gl (Just program) u >>= \case 96 | Nothing -> do 97 | liftIO $ putStrLn $ "Warning! Could not find the uniform " ++ show u 98 | return Nothing 99 | Just loc -> return $ Just (u, loc) 100 | return $ Shader program (catMaybes ulocs) 101 | loadGLShader (ShaderDefFP fps uniforms attribs) = do 102 | srcs <- forM fps $ \(fp, shaderType) -> do 103 | src <- C8.pack <$> getShaderFileSource fp 104 | return (src, shaderType) 105 | loadGLShader $ ShaderDefBS srcs uniforms attribs 106 | where getShaderFileSource fp = do 107 | req <- newXMLHttpRequest 108 | open req "GET" fp True "" "" 109 | send req 110 | fix $ \loop -> getStatus req >>= \case 111 | 0 -> liftIO (threadDelay 1) >> loop 112 | _ -> return () 113 | getResponseText req >>= \case 114 | Nothing -> fail $ "Could not get shader source from" ++ show fp 115 | Just src -> return src 116 | 117 | attribToGLuint :: Simple2DAttrib -> GLuint 118 | attribToGLuint = fromIntegral . fromEnum 119 | 120 | -- | Compile a shader program from a remote source 121 | loadShaderRemote :: FilePath -> FilePath -> Gelatin WGLShader 122 | loadShaderRemote a b = do 123 | gl <- asks gelRenderingContext 124 | 125 | ext <- getExtension gl "OES_standard_derivatives" 126 | when (isNull ext || isUndefined ext) $ 127 | liftIO $ putStrLn "Could not load a needed extension: OES_standard_derivatives" 128 | 129 | let ufms = map simple2DUniformIdentifier allSimple2DUniforms 130 | atts = allAttribs 131 | shdef = ShaderDefFP [(a, VERTEX_SHADER),(b, FRAGMENT_SHADER)] ufms atts 132 | loadGLShader shdef 133 | 134 | -- | Compile a shader program from a local, in memory source 135 | loadShaderMemory :: ByteString -> ByteString -> Gelatin WGLShader 136 | loadShaderMemory a b = do 137 | gl <- asks gelRenderingContext 138 | 139 | ext <- getExtension gl "OES_standard_derivatives" 140 | when (isNull ext || isUndefined ext) $ 141 | liftIO $ putStrLn "Could not load a needed extension: OES_standard_derivatives" 142 | 143 | let ufms = map simple2DUniformIdentifier allSimple2DUniforms 144 | atts = allAttribs 145 | shdef = ShaderDefBS [(a, VERTEX_SHADER),(b, FRAGMENT_SHADER)] ufms atts 146 | loadGLShader shdef 147 | -------------------------------------------------------------------------------- /gelatin-webgl/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /gelatin-webgl/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.07 2 | compiler: ghcjs-0.2.1.9007014_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007014_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2016-12-25-lts-7.14-9007014.tar.gz 10 | sha1: 0d2ebe0931b29adca7cb9d9b9f77d60095bfb864 11 | 12 | packages: 13 | - . 14 | - ../gelatin 15 | - ../gelatin-shaders 16 | 17 | extra-deps: 18 | - ghcjs-dom-0.3.1.0 19 | - ghcjs-dom-jsffi-0.3.1.0 20 | -------------------------------------------------------------------------------- /gelatin-webgl/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /gelatin/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Schell Scivally 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /gelatin/README.md: -------------------------------------------------------------------------------- 1 | gelatin-core 2 | ============ 3 | 4 | Core datatypes and functions for the gelatin renderer. 5 | -------------------------------------------------------------------------------- /gelatin/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gelatin/app/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | import Gelatin 4 | import Linear 5 | 6 | -------------------------------------------------------------------------------- 7 | -- Example 8 | -------------------------------------------------------------------------------- 9 | picture :: Picture () (V2 Float, V4 Float) () 10 | picture = setGeometry $ fan $ do 11 | to (0, red) 12 | to (V2 100 0, green) 13 | to (100, blue) 14 | to (V2 0 100, white) 15 | 16 | main :: IO () 17 | main = putStrLn "picture" 18 | -------------------------------------------------------------------------------- /gelatin/docimages/demoteCubic.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/schell/gelatin/04c1c83d4297eac4f4cc5e8e5c805b1600b3ee98/gelatin/docimages/demoteCubic.png -------------------------------------------------------------------------------- /gelatin/docimages/twobeziers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/schell/gelatin/04c1c83d4297eac4f4cc5e8e5c805b1600b3ee98/gelatin/docimages/twobeziers.png -------------------------------------------------------------------------------- /gelatin/gelatin.cabal: -------------------------------------------------------------------------------- 1 | name: gelatin 2 | version: 0.1.0.1 3 | synopsis: A graphics description language. 4 | description: An EDSL for describing pictures and scenes. 5 | homepage: https://github.com/schell/gelatin 6 | license: MIT 7 | license-file: LICENSE 8 | author: Schell Scivally 9 | maintainer: schell@takt.com 10 | category: Graphics 11 | build-type: Simple 12 | extra-doc-files: docimages/*.png 13 | stability: experimental 14 | 15 | cabal-version: >=1.18 16 | 17 | library 18 | ghc-options: -Wall 19 | 20 | exposed-modules: Gelatin 21 | , Gelatin.Compiler 22 | , Gelatin.Core 23 | , Gelatin.Core.Bezier 24 | , Gelatin.Core.Bounds 25 | , Gelatin.Core.Color 26 | --, Gelatin.Core.Font 27 | , Gelatin.Core.Polyline 28 | , Gelatin.Core.Stroke 29 | , Gelatin.Core.Transform 30 | , Gelatin.Core.Triangle 31 | , Gelatin.Core.Utils 32 | , Gelatin.Picture 33 | , Gelatin.Picture.Internal 34 | , Gelatin.Picture.Shapes 35 | 36 | build-depends: base >=4.8 && < 4.12 37 | , linear >=1.20 && <1.21 38 | , containers >=0.5 && <0.6 39 | , vector >=0.12 && <0.13 40 | , mtl >=2.2 && <2.3 41 | , transformers >=0.4 && <0.6 42 | , bytestring >=0.10 && <0.11 43 | , lens >=4.14 && <4.17 44 | 45 | hs-source-dirs: src 46 | default-language: Haskell2010 47 | 48 | executable example 49 | ghc-options: -Wall 50 | 51 | build-depends: base >=4.8 && < 4.12 52 | , gelatin 53 | , linear >=1.20 && <1.21 54 | , vector >=0.12 && <0.13 55 | , mtl >=2.2 && <2.3 56 | 57 | hs-source-dirs: app 58 | main-is: Example.hs 59 | default-language: Haskell2010 60 | -------------------------------------------------------------------------------- /gelatin/sosrc-dev: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - .*\.cabal$ 4 | commands: 5 | - stack build --fast 6 | - stack exec hlint \0 7 | # - stack build --fast --stack-yaml=stack80-ghcjs.yaml 8 | # - stack exec hlint \0 --stack-yaml=stack80-ghcjs.yaml 9 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Gelatin 3 | -- Copyright: (c) 2017 Schell Scivally 4 | -- License: MIT 5 | -- Maintainer: Schell Scivally 6 | -- 7 | -- [@Core@] 8 | -- Core types and pure functions. 9 | -- 10 | -- [@Picture@] 11 | -- Creating pictures. 12 | -- 13 | -- [@Compiler@] 14 | -- Shared types for writing backends and compiling pictures. 15 | -- 16 | module Gelatin 17 | ( -- * Re-exports 18 | module Gelatin.Core 19 | , module Gelatin.Picture 20 | , module Gelatin.Compiler 21 | , module Linear 22 | ) where 23 | 24 | import Gelatin.Core 25 | import Gelatin.Picture 26 | import Gelatin.Compiler 27 | import Linear hiding (rotate) 28 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | module Gelatin.Compiler where 7 | 8 | import qualified Data.Vector as B 9 | import Data.Vector.Unboxed (Vector) 10 | import Data.Functor.Identity 11 | import Data.Foldable (foldl') 12 | import Linear (V4(..), V2(..), M44, identity, (!*!)) 13 | import Control.Monad.IO.Class 14 | 15 | import Gelatin.Core 16 | import Gelatin.Picture.Internal 17 | -------------------------------------------------------------------------------- 18 | -- Compilation results in a Renderer 19 | -------------------------------------------------------------------------------- 20 | data RenderTransform v r s = Spatial (Affine v r) 21 | | Special s 22 | 23 | extractSpatial :: [RenderTransform v r s] -> [Affine v r] 24 | extractSpatial = concatMap f 25 | where f (Spatial x) = [x] 26 | f _ = [] 27 | 28 | type Renderer v r s = (IO (), [RenderTransform v r s] -> IO ()) 29 | -------------------------------------------------------------------------------- 30 | -- Renderers can be transformed with many things, but here are some concrete 31 | -- examples. 32 | -------------------------------------------------------------------------------- 33 | data Raster = Alpha Float 34 | | Multiply (V4 Float) 35 | | ColorReplacement (V4 Float) 36 | deriving (Show, Eq) 37 | 38 | type RenderTransform2 = RenderTransform (V2 Float) Float Raster 39 | type Renderer2 = Renderer (V2 Float) Float Raster 40 | -------------------------------------------------------------------------------- 41 | -- Transformation Helpers 42 | -------------------------------------------------------------------------------- 43 | unwrapTransforms :: [RenderTransform2] 44 | -> (M44 Float, Float, V4 Float, Maybe (V4 Float)) 45 | unwrapTransforms = foldl' f (identity, 1, white, Nothing) 46 | where f (mv, alph, mlt, rep) (Spatial a) = 47 | (mv !*! affine2Modelview a, alph, mlt, rep) 48 | f (mv, alph, mlt, rep) (Special (Alpha a)) = 49 | (mv, alph * a, mlt, rep) 50 | f (mv, alph, mlt, rep) (Special (Multiply a)) = 51 | (mv, alph, mlt * a, rep) 52 | f (mv, alph, mlt, _) (Special (ColorReplacement a)) = 53 | (mv, alph, mlt, Just a) 54 | -------------------------------------------------------------------------------- 55 | -- Conveniences for creating transformations 56 | -------------------------------------------------------------------------------- 57 | move :: Float -> Float -> RenderTransform2 58 | move x y = Spatial $ Translate $ V2 x y 59 | 60 | moveV2 :: V2 Float -> RenderTransform2 61 | moveV2 (V2 x y) = move x y 62 | 63 | scale :: Float -> Float -> RenderTransform2 64 | scale x y = Spatial $ Scale $ V2 x y 65 | 66 | scaleV2 :: V2 Float -> RenderTransform2 67 | scaleV2 (V2 x y) = scale x y 68 | 69 | rotate :: Float -> RenderTransform2 70 | rotate = Spatial . Rotate 71 | 72 | alpha :: Float -> RenderTransform2 73 | alpha = Special . Alpha 74 | 75 | multiply :: Float -> Float -> Float -> Float -> RenderTransform2 76 | multiply r g b a = Special $ Multiply $ V4 r g b a 77 | 78 | multiplyV4 :: V4 Float -> RenderTransform2 79 | multiplyV4 (V4 r g b a) = multiply r g b a 80 | 81 | redChannelReplacement :: Float -> Float -> Float -> Float -> RenderTransform2 82 | redChannelReplacement r g b a = Special $ ColorReplacement $ V4 r g b a 83 | 84 | redChannelReplacementV4 :: V4 Float -> RenderTransform2 85 | redChannelReplacementV4 (V4 r g b a) = redChannelReplacement r g b a 86 | -------------------------------------------------------------------------------- 87 | -- Making compiling easier through types 88 | -------------------------------------------------------------------------------- 89 | data VertexType = VertexTriangles 90 | | VertexBeziers 91 | | VertexStrip 92 | | VertexFan 93 | deriving (Show, Eq) 94 | 95 | data GeometryCompiler vx v r s = GeometryCompiler 96 | { compileShapes :: VertexType -> Vector vx -> IO (Renderer v r s) 97 | , compileLine :: Stroke -> Vector vx -> IO (Renderer v r s) 98 | } 99 | 100 | type MakeCompiler z vx v r s = z -> GeometryCompiler vx v r s 101 | -------------------------------------------------------------------------------- 102 | -- Specifying the backend 103 | -------------------------------------------------------------------------------- 104 | data BackendOps tex event = BackendOps 105 | { backendOpGetFramebufferSize :: IO (V2 Int) 106 | , backendOpGetWindowSize :: IO (V2 Int) 107 | , backendOpClearWindow :: IO () 108 | , backendOpUpdateWindow :: IO () 109 | , backendOpSetClearColor :: V4 Float -> IO () 110 | , backendOpAllocTexture :: FilePath -> IO (Maybe (tex, V2 Int)) 111 | , backendOpBindTextures :: [tex] -> IO () -> IO () 112 | , backendOpGetEvents :: IO [event] 113 | } 114 | data BackendCompiler vert spatial rot rast = BackendComp 115 | { backendCompApplyOption :: Renderer spatial rot rast -> RenderingOption 116 | -> Renderer spatial rot rast 117 | , backendCompCompiler :: GeometryCompiler vert spatial rot rast 118 | } 119 | data Backend tex event vert spatial rot rast = Backend 120 | { backendOps :: BackendOps tex event 121 | , backendCompiler :: BackendCompiler vert spatial rot rast 122 | } 123 | 124 | compiler :: Backend tex event vert spatial rot rast 125 | -> GeometryCompiler vert spatial rot rast 126 | compiler = backendCompCompiler . backendCompiler 127 | 128 | applyCompilerOption :: Backend tex event vert spatial rot rast 129 | -> Renderer spatial rot rast 130 | -> RenderingOption 131 | -> Renderer spatial rot rast 132 | applyCompilerOption b = backendCompApplyOption $ backendCompiler b 133 | 134 | bindTextures :: Backend tex event vert spatial rot rast -> [tex] -> IO () -> IO () 135 | bindTextures b = backendOpBindTextures $ backendOps b 136 | 137 | allocTexture :: Backend tex event vert spatial rot rast -> FilePath 138 | -> IO (Maybe (tex, V2 Int)) 139 | allocTexture b = backendOpAllocTexture $ backendOps b 140 | 141 | clearWindow :: Backend tex event vert spatial rot rast -> IO () 142 | clearWindow = backendOpClearWindow . backendOps 143 | 144 | updateWindow :: Backend tex event vert spatial rot rast -> IO () 145 | updateWindow = backendOpUpdateWindow . backendOps 146 | 147 | getEvents :: Backend tex event vert spatial rot rast -> IO [event] 148 | getEvents = backendOpGetEvents . backendOps 149 | -------------------------------------------------------------------------------- 150 | -- Compiling Concrete Picture Types 151 | -------------------------------------------------------------------------------- 152 | compilePictureT :: MonadIO m 153 | => Backend tex event vert spatial rot rast 154 | -> PictureT tex vert m a 155 | -> m (a, Renderer spatial rot rast) 156 | compilePictureT b pic = do 157 | (a, dat) <- runPictureT pic 158 | glr <- compilePictureData b dat 159 | return (a, glr) 160 | 161 | compilePicture :: MonadIO m 162 | => Backend tex event vert spatial rot rast 163 | -> Picture tex vert a 164 | -> m (a, Renderer spatial rot rast) 165 | compilePicture b pic = do 166 | let (a, dat) = runIdentity $ runPictureT pic 167 | glr <- compilePictureData b dat 168 | return (a, glr) 169 | 170 | compileGeometry :: GeometryCompiler vx v r s -> [StrokeAttr] -> RawGeometry vx 171 | -> IO (Renderer v r s) 172 | compileGeometry GeometryCompiler{..} _ (RawTriangles v) = 173 | compileShapes VertexTriangles v 174 | compileGeometry GeometryCompiler{..} _ (RawBeziers v) = 175 | compileShapes VertexBeziers v 176 | compileGeometry GeometryCompiler{..} _ (RawTriangleStrip v) = 177 | compileShapes VertexStrip v 178 | compileGeometry GeometryCompiler{..} _ (RawTriangleFan v) = 179 | compileShapes VertexFan v 180 | compileGeometry GeometryCompiler{..} ss (RawLine v) = 181 | compileLine (strokeWith ss) v 182 | 183 | compilePictureData :: MonadIO m 184 | => Backend tex event vert spatial rot rast 185 | -> PictureData tex vert 186 | -> m (Renderer spatial rot rast) 187 | compilePictureData b PictureData{..} = do 188 | let compile = liftIO . compileGeometry (compiler b) _picDataStroke 189 | glrs <- B.mapM compile _picDataGeometry 190 | let render rs = bindTextures b _picDataTextures $ mapM_ (($ rs) . snd) glrs 191 | clean = mapM_ fst glrs 192 | glr = foldl (applyCompilerOption b) (clean, render) _picDataOptions 193 | return glr 194 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core.hs: -------------------------------------------------------------------------------- 1 | -- | In this module you'll find the types and functions used throughout gelatin. 2 | -- 3 | -- [@Bezier@] 4 | -- Inner and outer beziers. 5 | -- 6 | -- [@Bounds@] 7 | -- Working with bounding boxes. 8 | -- 9 | -- [@Color@] 10 | -- All the nifty named css colors. 11 | -- 12 | -- [@Polyline@] 13 | -- Creating smooth, anti-aliased lines with end caps. 14 | -- 15 | -- [@Stroke@] 16 | -- Helpers for stroking polylines. 17 | -- 18 | -- [@Transform@] 19 | -- Affine transformations (and more). 20 | -- 21 | -- [@Triangle@] 22 | -- Most likely not used - contains triangles. 23 | -- 24 | -- [@Utils@] 25 | -- Various utilities. 26 | module Gelatin.Core ( 27 | module Gelatin.Core.Bezier 28 | , module Gelatin.Core.Bounds 29 | , module Gelatin.Core.Color 30 | -- , module Gelatin.Core.Font 31 | , module Gelatin.Core.Polyline 32 | , module Gelatin.Core.Utils 33 | , module Gelatin.Core.Stroke 34 | , module Gelatin.Core.Transform 35 | , module Gelatin.Core.Triangle 36 | ) where 37 | 38 | import Gelatin.Core.Bezier 39 | import Gelatin.Core.Bounds 40 | import Gelatin.Core.Color 41 | --import Gelatin.Core.Font 42 | import Gelatin.Core.Polyline 43 | import Gelatin.Core.Utils 44 | import Gelatin.Core.Stroke 45 | import Gelatin.Core.Transform 46 | import Gelatin.Core.Triangle 47 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Bounds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Gelatin.Core.Bounds where 5 | 6 | import Control.Arrow (Arrow, first, second, (>>>)) 7 | import Data.Vector.Unboxed (Unbox, Vector) 8 | import qualified Data.Vector.Unboxed as V 9 | import Gelatin.Core.Transform 10 | import Linear 11 | 12 | type BBox = (V2 Float, V2 Float) 13 | 14 | type BCube = (V3 Float, V3 Float) 15 | 16 | -------------------------------------------------------------------------------- 17 | -- 3d 18 | -------------------------------------------------------------------------------- 19 | boundingCube :: (Unbox a, Real a) => Vector (V3 a) -> BCube 20 | boundingCube vs 21 | | V.null vs = (0,0) 22 | | otherwise = V.foldl' f (br,tl) vs 23 | where mn a = min a . realToFrac 24 | mx a = max a . realToFrac 25 | f (a, b) c = (mn <$> a <*> c, mx <$> b <*> c) 26 | inf = 1/0 27 | ninf = (-1)/0 28 | tl = V3 ninf ninf ninf 29 | br = V3 inf inf inf 30 | 31 | listToCube :: [V3 Float] -> BCube 32 | listToCube = boundingCube . V.fromList 33 | 34 | foldIntoCube :: Vector BCube -> BCube 35 | foldIntoCube = boundingCube . uncurry (V.++) . V.unzip 36 | 37 | pointInCube :: V2 Float -> BBox -> Bool 38 | pointInCube (V2 px py) (V2 minx miny, V2 maxx maxy) = 39 | (px >= minx && px <= maxx) && (py >= miny && py <= maxy) 40 | 41 | applyTfrmToCube :: M44 Float -> BBox -> BBox 42 | applyTfrmToCube t (tl,br) = listToBox [transformV2 t tl, transformV2 t br] 43 | -------------------------------------------------------------------------------- 44 | -- 2d 45 | -------------------------------------------------------------------------------- 46 | both :: Arrow a => a d c -> a (d, d) (c, c) 47 | both f = first f >>> second f 48 | 49 | boundingBox :: (Unbox a, Real a) => Vector (V2 a) -> BBox 50 | boundingBox = second demoteV3 . first demoteV3 . boundingCube . V.map promoteV2 51 | 52 | listToBox :: [V2 Float] -> BBox 53 | listToBox = boundingBox . V.fromList 54 | 55 | foldIntoBox :: Vector BBox -> BBox 56 | foldIntoBox = boundingBox . uncurry (V.++) . V.unzip 57 | 58 | pointInBox :: V2 Float -> BBox -> Bool 59 | pointInBox (V2 px py) (V2 minx miny, V2 maxx maxy) = 60 | (px >= minx && px <= maxx) && (py >= miny && py <= maxy) 61 | 62 | applyTfrmToBox :: M44 Float -> BBox -> BBox 63 | applyTfrmToBox t (tl,br) = listToBox [transformV2 t tl, transformV2 t br] 64 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Color.hs: -------------------------------------------------------------------------------- 1 | -- | CSS style colors! Also includes 'withAlpha' and 'fromHex', for 2 | -- convenience. 3 | module Gelatin.Core.Color where 4 | 5 | import Data.Bits 6 | import Linear 7 | 8 | type Color = V4 Float 9 | 10 | maroon :: Fractional a => V4 a 11 | maroon = V4 (128/255) (0/255) (0/255) 1 12 | 13 | red :: Fractional a => V4 a 14 | red = V4 (255/255) (0/255) (0/255) 1 15 | 16 | orange :: Fractional a => V4 a 17 | orange = V4 (255/255) (165/255) (0/255) 1 18 | 19 | yellow,canary :: Fractional a => V4 a 20 | yellow = V4 (255/255) (255/255) (0/255) 1 21 | canary = yellow 22 | 23 | olive :: Fractional a => V4 a 24 | olive = V4 (128/255) (128/255) (0/255) 1 25 | 26 | green :: Fractional a => V4 a 27 | green = V4 0 (128/255) (0/255) 1 28 | 29 | purple :: Fractional a => V4 a 30 | purple = V4 (128/255) (0/255) (128/255) 1 31 | 32 | fuchsia :: Fractional a => V4 a 33 | fuchsia = V4 (255/255) (0/255) (255/255) 1 34 | 35 | lime :: Fractional a => V4 a 36 | lime = V4 0 (255/255) (0/255) 1 37 | 38 | teal :: Fractional a => V4 a 39 | teal = V4 0 (128/255) (128/255) 1 40 | 41 | aqua :: Fractional a => V4 a 42 | aqua = V4 0 (255/255) (255/255) 1 43 | 44 | blue :: Fractional a => V4 a 45 | blue = V4 0 (0/255) (255/255) 1 46 | 47 | navy :: Fractional a => V4 a 48 | navy = V4 0 (0/255) (128/255) 1 49 | 50 | black :: Fractional a => V4 a 51 | black = V4 0 (0/255) (0/255) 1 52 | 53 | gray :: Fractional a => V4 a 54 | gray = V4 (128/255) (128/255) (128/255) 1 55 | 56 | grey :: Fractional a => V4 a 57 | grey = gray 58 | 59 | silver :: Fractional a => V4 a 60 | silver = V4 (192/255) (192/255) (192/255) 1 61 | 62 | white :: Fractional a => V4 a 63 | white = V4 (255/255) (255/255) (255/255) 1 64 | 65 | indianRed :: Fractional a => V4 a 66 | indianRed = V4 (205/255) (92/255) (92/255) 1 67 | 68 | lightCoral :: Fractional a => V4 a 69 | lightCoral = V4 (240/255) (128/255) (128/255) 1 70 | 71 | salmon :: Fractional a => V4 a 72 | salmon = V4 (250/255) (128/255) (114/255) 1 73 | 74 | darkSalmon :: Fractional a => V4 a 75 | darkSalmon = V4 (233/255) (150/255) (122/255) 1 76 | 77 | lightSalmon :: Fractional a => V4 a 78 | lightSalmon = V4 (255/255) (160/255) (122/255) 1 79 | 80 | crimson :: Fractional a => V4 a 81 | crimson = V4 (220/255) (20/255) (60/255) 1 82 | 83 | fireBrick :: Fractional a => V4 a 84 | fireBrick = V4 (178/255) (34/255) (34/255) 1 85 | 86 | darkRed :: Fractional a => V4 a 87 | darkRed = V4 (139/255) (0/255) (0/255) 1 88 | 89 | pink :: Fractional a => V4 a 90 | pink = V4 (255/255) (192/255) (203/255) 1 91 | 92 | lightPink :: Fractional a => V4 a 93 | lightPink = V4 (255/255) (182/255) (193/255) 1 94 | 95 | hotPink :: Fractional a => V4 a 96 | hotPink = V4 (255/255) (105/255) (180/255) 1 97 | 98 | deepPink :: Fractional a => V4 a 99 | deepPink = V4 (255/255) (20/255) (147/255) 1 100 | 101 | mediumVioletRed :: Fractional a => V4 a 102 | mediumVioletRed = V4 (199/255) (21/255) (133/255) 1 103 | 104 | paleVioletRed :: Fractional a => V4 a 105 | paleVioletRed = V4 (219/255) (112/255) (147/255) 1 106 | 107 | coral :: Fractional a => V4 a 108 | coral = V4 (255/255) (127/255) (80/255) 1 109 | 110 | tomato :: Fractional a => V4 a 111 | tomato = V4 (255/255) (99/255) (71/255) 1 112 | 113 | orangeRed :: Fractional a => V4 a 114 | orangeRed = V4 (255/255) (69/255) (0/255) 1 115 | 116 | darkOrange :: Fractional a => V4 a 117 | darkOrange = V4 (255/255) (140/255) (0/255) 1 118 | 119 | gold :: Fractional a => V4 a 120 | gold = V4 (255/255) (215/255) (0/255) 1 121 | 122 | lightYellow :: Fractional a => V4 a 123 | lightYellow = V4 (255/255) (255/255) (224/255) 1 124 | 125 | lemonChiffon :: Fractional a => V4 a 126 | lemonChiffon = V4 (255/255) (250/255) (205/255) 1 127 | 128 | lightGoldenrodYellow :: Fractional a => V4 a 129 | lightGoldenrodYellow = V4 (250/255) (250/255) (210/255) 1 130 | 131 | papayaWhip :: Fractional a => V4 a 132 | papayaWhip = V4 (255/255) (239/255) (213/255) 1 133 | 134 | moccasin :: Fractional a => V4 a 135 | moccasin = V4 (255/255) (228/255) (181/255) 1 136 | 137 | peachPuff :: Fractional a => V4 a 138 | peachPuff = V4 (255/255) (218/255) (185/255) 1 139 | 140 | paleGoldenrod :: Fractional a => V4 a 141 | paleGoldenrod = V4 (238/255) (232/255) (170/255) 1 142 | 143 | khaki :: Fractional a => V4 a 144 | khaki = V4 (240/255) (230/255) (140/255) 1 145 | 146 | darkKhaki :: Fractional a => V4 a 147 | darkKhaki = V4 (189/255) (183/255) (107/255) 1 148 | 149 | lavender :: Fractional a => V4 a 150 | lavender = V4 (230/255) (230/255) (250/255) 1 151 | 152 | thistle :: Fractional a => V4 a 153 | thistle = V4 (216/255) (191/255) (216/255) 1 154 | 155 | plum :: Fractional a => V4 a 156 | plum = V4 (221/255) (160/255) (221/255) 1 157 | 158 | violet :: Fractional a => V4 a 159 | violet = V4 (238/255) (130/255) (238/255) 1 160 | 161 | orchid :: Fractional a => V4 a 162 | orchid = V4 (218/255) (112/255) (214/255) 1 163 | 164 | magenta :: Fractional a => V4 a 165 | magenta = V4 (255/255) (0/255) (255/255) 1 166 | 167 | mediumOrchid :: Fractional a => V4 a 168 | mediumOrchid = V4 (186/255) (85/255) (211/255) 1 169 | 170 | mediumPurple :: Fractional a => V4 a 171 | mediumPurple = V4 (147/255) (112/255) (219/255) 1 172 | 173 | amethyst :: Fractional a => V4 a 174 | amethyst = V4 (153/255) (102/255) (204/255) 1 175 | 176 | blueViolet :: Fractional a => V4 a 177 | blueViolet = V4 (138/255) (43/255) (226/255) 1 178 | 179 | darkViolet :: Fractional a => V4 a 180 | darkViolet = V4 (148/255) (0/255) (211/255) 1 181 | 182 | darkOrchid :: Fractional a => V4 a 183 | darkOrchid = V4 (153/255) (50/255) (204/255) 1 184 | 185 | darkMagenta :: Fractional a => V4 a 186 | darkMagenta = V4 (139/255) (0/255) (139/255) 1 187 | 188 | indigo :: Fractional a => V4 a 189 | indigo = V4 (75/255) (0/255) (130/255) 1 190 | 191 | slateBlue :: Fractional a => V4 a 192 | slateBlue = V4 (106/255) (90/255) (205/255) 1 193 | 194 | darkSlateBlue :: Fractional a => V4 a 195 | darkSlateBlue = V4 (72/255) (61/255) (139/255) 1 196 | 197 | mediumSlateBlue :: Fractional a => V4 a 198 | mediumSlateBlue = V4 (123/255) (104/255) (238/255) 1 199 | 200 | greenYellow :: Fractional a => V4 a 201 | greenYellow = V4 (173/255) (255/255) (47/255) 1 202 | 203 | chartreuse :: Fractional a => V4 a 204 | chartreuse = V4 (127/255) (255/255) (0/255) 1 205 | 206 | lawnGreen :: Fractional a => V4 a 207 | lawnGreen = V4 (124/255) (252/255) (0/255) 1 208 | 209 | limeGreen :: Fractional a => V4 a 210 | limeGreen = V4 (50/255) (205/255) (50/255) 1 211 | 212 | paleGreen :: Fractional a => V4 a 213 | paleGreen = V4 (152/255) (251/255) (152/255) 1 214 | 215 | lightGreen :: Fractional a => V4 a 216 | lightGreen = V4 (144/255) (238/255) (144/255) 1 217 | 218 | mediumSpringGreen :: Fractional a => V4 a 219 | mediumSpringGreen = V4 0 (250/255) (154/255) 1 220 | 221 | springGreen :: Fractional a => V4 a 222 | springGreen = V4 0 (255/255) (127/255) 1 223 | 224 | mediumSeaGreen :: Fractional a => V4 a 225 | mediumSeaGreen = V4 (60/255) (179/255) (113/255) 1 226 | 227 | seaGreen :: Fractional a => V4 a 228 | seaGreen = V4 (46/255) (139/255) (87/255) 1 229 | 230 | forestGreen :: Fractional a => V4 a 231 | forestGreen = V4 (34/255) (139/255) (34/255) 1 232 | 233 | darkGreen :: Fractional a => V4 a 234 | darkGreen = V4 0 (100/255) (0/255) 1 235 | 236 | yellowGreen :: Fractional a => V4 a 237 | yellowGreen = V4 (154/255) (205/255) (50/255) 1 238 | 239 | oliveDrab :: Fractional a => V4 a 240 | oliveDrab = V4 (107/255) (142/255) (35/255) 1 241 | 242 | darkOliveGreen :: Fractional a => V4 a 243 | darkOliveGreen = V4 (85/255) (107/255) (47/255) 1 244 | 245 | mediumAquamarine :: Fractional a => V4 a 246 | mediumAquamarine = V4 (102/255) (205/255) (170/255) 1 247 | 248 | darkSeaGreen :: Fractional a => V4 a 249 | darkSeaGreen = V4 (143/255) (188/255) (143/255) 1 250 | 251 | lightSeaGreen :: Fractional a => V4 a 252 | lightSeaGreen = V4 (32/255) (178/255) (170/255) 1 253 | 254 | darkCyan :: Fractional a => V4 a 255 | darkCyan = V4 0 (139/255) (139/255) 1 256 | 257 | cyan :: Fractional a => V4 a 258 | cyan = V4 0 (255/255) (255/255) 1 259 | 260 | lightCyan :: Fractional a => V4 a 261 | lightCyan = V4 (224/255) (255/255) (255/255) 1 262 | 263 | paleTurquoise :: Fractional a => V4 a 264 | paleTurquoise = V4 (175/255) (238/255) (238/255) 1 265 | 266 | aquamarine :: Fractional a => V4 a 267 | aquamarine = V4 (127/255) (255/255) (212/255) 1 268 | 269 | turquoise :: Fractional a => V4 a 270 | turquoise = V4 (64/255) (224/255) (208/255) 1 271 | 272 | mediumTurquoise :: Fractional a => V4 a 273 | mediumTurquoise = V4 (72/255) (209/255) (204/255) 1 274 | 275 | darkTurquoise :: Fractional a => V4 a 276 | darkTurquoise = V4 0 (206/255) (209/255) 1 277 | 278 | cadetBlue :: Fractional a => V4 a 279 | cadetBlue = V4 (95/255) (158/255) (160/255) 1 280 | 281 | steelBlue :: Fractional a => V4 a 282 | steelBlue = V4 (70/255) (130/255) (180/255) 1 283 | 284 | lightSteelBlue :: Fractional a => V4 a 285 | lightSteelBlue = V4 (176/255) (196/255) (222/255) 1 286 | 287 | powderBlue :: Fractional a => V4 a 288 | powderBlue = V4 (176/255) (224/255) (230/255) 1 289 | 290 | lightBlue :: Fractional a => V4 a 291 | lightBlue = V4 (173/255) (216/255) (230/255) 1 292 | 293 | skyBlue :: Fractional a => V4 a 294 | skyBlue = V4 (135/255) (206/255) (235/255) 1 295 | 296 | lightSkyBlue :: Fractional a => V4 a 297 | lightSkyBlue = V4 (135/255) (206/255) (250/255) 1 298 | 299 | deepSkyBlue :: Fractional a => V4 a 300 | deepSkyBlue = V4 0 (191/255) (255/255) 1 301 | 302 | dodgerBlue :: Fractional a => V4 a 303 | dodgerBlue = V4 (30/255) (144/255) (255/255) 1 304 | 305 | cornflowerBlue :: Fractional a => V4 a 306 | cornflowerBlue = V4 (100/255) (149/255) (237/255) 1 307 | 308 | royalBlue :: Fractional a => V4 a 309 | royalBlue = V4 (65/255) (105/255) (225/255) 1 310 | 311 | mediumBlue :: Fractional a => V4 a 312 | mediumBlue = V4 0 (0/255) (205/255) 1 313 | 314 | darkBlue :: Fractional a => V4 a 315 | darkBlue = V4 0 (0/255) (139/255) 1 316 | 317 | midnightBlue :: Fractional a => V4 a 318 | midnightBlue = V4 (25/255) (25/255) (112/255) 1 319 | 320 | cornsilk :: Fractional a => V4 a 321 | cornsilk = V4 (255/255) (248/255) (220/255) 1 322 | 323 | blanchedAlmond :: Fractional a => V4 a 324 | blanchedAlmond = V4 (255/255) (235/255) (205/255) 1 325 | 326 | bisque :: Fractional a => V4 a 327 | bisque = V4 (255/255) (228/255) (196/255) 1 328 | 329 | navajoWhite :: Fractional a => V4 a 330 | navajoWhite = V4 (255/255) (222/255) (173/255) 1 331 | 332 | wheat :: Fractional a => V4 a 333 | wheat = V4 (245/255) (222/255) (179/255) 1 334 | 335 | burlyWood :: Fractional a => V4 a 336 | burlyWood = V4 (222/255) (184/255) (135/255) 1 337 | 338 | tan :: Fractional a => V4 a 339 | tan = V4 (210/255) (180/255) (140/255) 1 340 | 341 | rosyBrown :: Fractional a => V4 a 342 | rosyBrown = V4 (188/255) (143/255) (143/255) 1 343 | 344 | sandyBrown :: Fractional a => V4 a 345 | sandyBrown = V4 (244/255) (164/255) (96/255) 1 346 | 347 | goldenrod :: Fractional a => V4 a 348 | goldenrod = V4 (218/255) (165/255) (32/255) 1 349 | 350 | darkGoldenrod :: Fractional a => V4 a 351 | darkGoldenrod = V4 (184/255) (134/255) (11/255) 1 352 | 353 | peru :: Fractional a => V4 a 354 | peru = V4 (205/255) (133/255) (63/255) 1 355 | 356 | chocolate :: Fractional a => V4 a 357 | chocolate = V4 (210/255) (105/255) (30/255) 1 358 | 359 | saddleBrown :: Fractional a => V4 a 360 | saddleBrown = V4 (139/255) (69/255) (19/255) 1 361 | 362 | sienna :: Fractional a => V4 a 363 | sienna = V4 (160/255) (82/255) (45/255) 1 364 | 365 | brown :: Fractional a => V4 a 366 | brown = V4 (165/255) (42/255) (42/255) 1 367 | 368 | snow :: Fractional a => V4 a 369 | snow = V4 (255/255) (250/255) (250/255) 1 370 | 371 | honeydew :: Fractional a => V4 a 372 | honeydew = V4 (240/255) (255/255) (240/255) 1 373 | 374 | mintCream :: Fractional a => V4 a 375 | mintCream = V4 (245/255) (255/255) (250/255) 1 376 | 377 | azure :: Fractional a => V4 a 378 | azure = V4 (240/255) (255/255) (255/255) 1 379 | 380 | aliceBlue :: Fractional a => V4 a 381 | aliceBlue = V4 (240/255) (248/255) (255/255) 1 382 | 383 | ghostWhite :: Fractional a => V4 a 384 | ghostWhite = V4 (248/255) (248/255) (255/255) 1 385 | 386 | whiteSmoke :: Fractional a => V4 a 387 | whiteSmoke = V4 (245/255) (245/255) (245/255) 1 388 | 389 | seashell :: Fractional a => V4 a 390 | seashell = V4 (255/255) (245/255) (238/255) 1 391 | 392 | beige :: Fractional a => V4 a 393 | beige = V4 (245/255) (245/255) (220/255) 1 394 | 395 | oldLace :: Fractional a => V4 a 396 | oldLace = V4 (253/255) (245/255) (230/255) 1 397 | 398 | floralWhite :: Fractional a => V4 a 399 | floralWhite = V4 (255/255) (250/255) (240/255) 1 400 | 401 | ivory :: Fractional a => V4 a 402 | ivory = V4 (255/255) (255/255) (240/255) 1 403 | 404 | antiqueWhite :: Fractional a => V4 a 405 | antiqueWhite = V4 (250/255) (235/255) (215/255) 1 406 | 407 | linen :: Fractional a => V4 a 408 | linen = V4 (250/255) (240/255) (230/255) 1 409 | 410 | lavenderBlush :: Fractional a => V4 a 411 | lavenderBlush = V4 (255/255) (240/255) (245/255) 1 412 | 413 | mistyRose :: Fractional a => V4 a 414 | mistyRose = V4 (255/255) (228/255) (225/255) 1 415 | 416 | gainsboro :: Fractional a => V4 a 417 | gainsboro = V4 (220/255) (220/255) (220/255) 1 418 | 419 | lightGrey :: Fractional a => V4 a 420 | lightGrey = V4 (211/255) (211/255) (211/255) 1 421 | 422 | darkGray :: Fractional a => V4 a 423 | darkGray = V4 (169/255) (169/255) (169/255) 1 424 | 425 | dimGray :: Fractional a => V4 a 426 | dimGray = V4 (105/255) (105/255) (105/255) 1 427 | 428 | lightSlateGray :: Fractional a => V4 a 429 | lightSlateGray = V4 (119/255) (136/255) (153/255) 1 430 | 431 | slateGray :: Fractional a => V4 a 432 | slateGray = V4 (112/255) (128/255) (144/255) 1 433 | 434 | darkSlateGray :: Fractional a => V4 a 435 | darkSlateGray = V4 (47/255) (79/255) (79/255) 1 436 | 437 | transparent :: Fractional a => V4 a 438 | transparent = V4 0 0 0 0 439 | 440 | withAlpha :: V4 a -> a -> V4 a 441 | withAlpha (V4 r g b _) = V4 r g b 442 | 443 | fromHex :: Fractional b => Int -> V4 b 444 | fromHex n = ((/255) . fromIntegral) <$> V4 r g b a 445 | where r = n `shiftR` 24 446 | g = n `shiftR` 16 .&. 0xFF 447 | b = n `shiftR` 8 .&. 0xFF 448 | a = n .&. 0xFF 449 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/CommonOld.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | module Gelatin.Core.Common where 4 | 5 | import GHC.Generics 6 | import Data.Hashable 7 | 8 | newtype Uid = Uid { unUid :: Int } deriving (Show, Eq, Generic, Num, Enum) 9 | 10 | instance Hashable Uid where 11 | hashWithSalt s = hashWithSalt s . unUid 12 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Font.hs: -------------------------------------------------------------------------------- 1 | module Gelatin.Core.Font where 2 | 3 | import qualified Data.Vector as B 4 | import Data.Vector.Unboxed (Vector) 5 | import Gelatin.Core.Bezier 6 | import Linear 7 | 8 | type CalcFontCurves = Int -> Float -> String -> [[Vector (QuadraticBezier (V2 Float))]] 9 | type CalcFontGeom = Int -> Float -> String -> (Vector (Bezier (V2 Float)), [Vector (V2 Float)]) 10 | 11 | data FontData = FontData { fontStringCurves :: CalcFontCurves 12 | , fontStringGeom :: CalcFontGeom 13 | , fontHash :: Int -> Int 14 | , fontShow :: String 15 | } 16 | 17 | stringCurvesToPaths :: FontData -> Int -> Float -> String -> [Vector (V2 Float)] 18 | stringCurvesToPaths fd dpi px str = 19 | let qs = fontStringCurves fd dpi px str 20 | sub = subdivideAdaptive 100 0 21 | mkPath :: Vector (QuadraticBezier (V2 Float)) -> Vector (V2 Float) 22 | mkPath = cleanSeqDupes 23 | . B.convert 24 | . B.concatMap (B.convert . sub) 25 | . B.convert 26 | in concatMap (fmap mkPath) qs 27 | 28 | instance Show FontData where 29 | show = fontShow 30 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Polyline.hs: -------------------------------------------------------------------------------- 1 | -- | This module is planned to disappear in favor of a stateful polyline 2 | -- drawing mode. It's still here for various renderers. 3 | module Gelatin.Core.Polyline where 4 | 5 | import Data.List (unzip5) 6 | import Data.Vector.Unboxed (Unbox, Vector) 7 | import qualified Data.Vector.Unboxed as V 8 | import Linear hiding (trace) 9 | 10 | 11 | type PolylineData f = 12 | ( Vector (V2 Float) 13 | , Vector (f Float) 14 | , Vector (V2 Float) 15 | , Vector (V2 Float) 16 | , Vector (V2 Float) 17 | , Float 18 | ) 19 | 20 | expandPolyline :: Unbox (f Float) 21 | => Vector (V2 Float) -> Vector (f Float) -> Float -> Float 22 | -> Maybe (PolylineData f) 23 | expandPolyline verts colors thickness feather 24 | | Just (v1,v2) <- (,) <$> (verts V.!? 0) <*> (verts V.!? 1) 25 | , Just c1 <- colors V.!? 0 26 | , Just (v3,v3n) <- (,) <$> (verts V.!? (V.length verts -1)) 27 | <*> (verts V.!? (V.length verts -2)) 28 | , Just c3 <- colors V.!? (V.length verts -1) = 29 | let -- clamp the lower bound of our thickness to 1 30 | absthick = max thickness 1 31 | d = fromIntegral (ceiling $ absthick + 2.5 * feather :: Integer) 32 | lens = 0 `V.cons` V.zipWith distance verts (V.drop 1 verts) 33 | totalLen = V.foldl' (+) 0 lens 34 | totalEnd = totalLen + d 35 | seqfunc (total,ts) len = (total + len,ts V.++ V.singleton (total + len)) 36 | seqLens = snd $ V.foldl' seqfunc (0,mempty) lens 37 | isClosed = distance v1 v3 <= 0.00001 38 | -- if the polyline is closed return a miter with the last point 39 | startCap = ( V.fromList [cap,cap] 40 | , V.fromList [c1,c1] 41 | , uvs 42 | , V.fromList [v2,v2] 43 | , V.fromList [prev,prev] 44 | ) 45 | where (uvs,cap,prev) = if isClosed 46 | -- no cap 47 | then (V.fromList [V2 0 d, V2 0 (-d)],v1,v3n) 48 | -- cap 49 | else let c = d *^ signorm (v2 - v1) 50 | in ( V.fromList [V2 (-d) d, V2 (-d) (-d)] 51 | , v1 - c 52 | , v1 - 2*c) 53 | endCap = ( V.fromList [cap,cap] 54 | , V.fromList [c3,c3] 55 | , uvs 56 | , V.fromList [next,next] 57 | , V.fromList [v3n,v3n] 58 | ) 59 | where (uvs,cap,next) = if isClosed 60 | -- no cap 61 | then ( V.fromList [ V2 totalLen d 62 | , V2 totalLen (-d) 63 | ] 64 | , v3 65 | , v2 66 | ) 67 | -- cap 68 | else let c = d *^ signorm (v3 - v3n) 69 | in (V.fromList [ V2 totalEnd d 70 | , V2 totalEnd (-d) 71 | ] 72 | , v3 + c 73 | , v3 + 2*c 74 | ) 75 | vcs = V.toList $ V.zip3 verts colors seqLens 76 | zs = zipWith3 strp vcs (drop 1 vcs) (drop 2 vcs) 77 | -- Expand the line into a triangle strip 78 | strp :: Unbox (f Float) 79 | => (V2 Float, f Float, Float) -> (V2 Float, f Float, Float) 80 | -> (V2 Float, f Float, Float) -> (Vector (V2 Float) 81 | ,Vector (f Float) 82 | ,Vector (V2 Float) 83 | ,Vector (V2 Float) 84 | ,Vector (V2 Float) 85 | ) 86 | strp (a,_,_) (b,bc,l) (c,_,_) = 87 | ( V.fromList [b,b] 88 | , V.fromList [bc,bc] 89 | , V.fromList [V2 l d,V2 l (-d)] 90 | , V.fromList [c,c] 91 | , V.fromList [a,a] 92 | ) 93 | (vs,cs,us,ns,ps) = unzip5 $ startCap : zs ++ [endCap] 94 | in Just (V.concat vs, V.concat cs, V.concat us, V.concat ns, V.concat ps, totalLen) 95 | | otherwise = Nothing 96 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Stroke.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | -- | Strokes are used for defining lines and drawing them. 3 | module Gelatin.Core.Stroke where 4 | 5 | import Data.Maybe (fromMaybe) 6 | import GHC.Generics (Generic) 7 | 8 | data LineCap = LineCapNone 9 | | LineCapButt 10 | | LineCapSquare 11 | | LineCapRound 12 | | LineCapTriOut 13 | | LineCapTriIn 14 | deriving (Show, Ord, Eq, Enum, Generic) 15 | 16 | data Stroke = Stroke { strokeWidth :: Float 17 | , strokeFeather :: Float 18 | , strokeLineCaps :: (LineCap,LineCap) 19 | } deriving (Show, Eq, Generic) 20 | 21 | data StrokeAttr = StrokeNone 22 | | StrokeWidth Float 23 | | StrokeFeather Float 24 | | StrokeCaps (LineCap,LineCap) 25 | deriving (Show, Eq, Generic) 26 | 27 | defaultStroke :: Stroke 28 | defaultStroke = Stroke 1 1 (LineCapRound,LineCapRound) 29 | 30 | strokeAttr :: Maybe Stroke -> StrokeAttr -> Maybe Stroke 31 | strokeAttr _ StrokeNone = Nothing 32 | strokeAttr Nothing c = strokeAttr (Just defaultStroke) c 33 | strokeAttr (Just s) (StrokeWidth w) = Just $ s {strokeWidth = w} 34 | strokeAttr (Just s) (StrokeFeather t) = Just $ s {strokeFeather = t} 35 | strokeAttr (Just s) (StrokeCaps cs) = Just $ s {strokeLineCaps = cs} 36 | 37 | strokeWith :: [StrokeAttr] -> Stroke 38 | strokeWith atts = fromMaybe defaultStroke $ foldl strokeAttr Nothing atts 39 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | -- | Limited spatial transformations in 2 and 3 dimensions. 4 | module Gelatin.Core.Transform where 5 | 6 | import Data.Foldable (foldl') 7 | import Linear (Epsilon (..), M44, V1 (..), V2 (..), 8 | V3 (..), V4 (..), axisAngle, identity, 9 | mkTransformation, mkTransformationMat, (!*!)) 10 | -------------------------------------------------------------------------------- 11 | -- Affine Transformation 12 | -------------------------------------------------------------------------------- 13 | data Affine a r = Translate a 14 | | Scale a 15 | | Rotate r 16 | deriving (Show, Eq) 17 | 18 | type Affine2 a = Affine (V2 a) a 19 | 20 | type Affine3 a = Affine (V3 a) (a, V3 a) 21 | 22 | -- | Promotes a point in R2 to a point in R3 by setting the z coord to '0'. 23 | promoteV2 :: Num a => V2 a -> V3 a 24 | promoteV2 (V2 x y) = V3 x y 0 25 | 26 | -- | Demotes a point in R3 to a point in R2 by discarding the z coord. 27 | demoteV3 :: V3 a -> V2 a 28 | demoteV3 (V3 x y _) = V2 x y 29 | 30 | -- | Promotes an affine transformation in R2 to one in R3 by using `promoteV2` 31 | -- in case of translation or scaling, and promotes rotation as a rotation about 32 | -- the z axis. 33 | promoteAffine2 :: Num a => Affine2 a -> Affine3 a 34 | promoteAffine2 (Translate v2) = Translate $ promoteV2 v2 35 | promoteAffine2 (Scale v2) = Scale $ promoteV2 v2 36 | promoteAffine2 (Rotate r) = Rotate (r, V3 0 0 1) 37 | 38 | affine3Modelview :: (Num a, Real a, Floating a, Epsilon a) 39 | => Affine3 a -> M44 a 40 | affine3Modelview (Translate v) = mat4Translate v 41 | affine3Modelview (Scale v) = mat4Scale v 42 | affine3Modelview (Rotate (r,axis)) = mat4Rotate r axis 43 | 44 | affine2Modelview :: (Num a, Real a, Floating a, Epsilon a) 45 | => Affine2 a -> M44 a 46 | affine2Modelview = affine3Modelview . promoteAffine2 47 | 48 | affine2sModelview :: (Num a, Real a, Floating a, Epsilon a) 49 | => [Affine2 a] -> M44 a 50 | affine2sModelview = foldl' f identity 51 | where f mv a = (mv !*!) $ affine2Modelview a 52 | 53 | transformV2 :: Num a => M44 a -> V2 a -> V2 a 54 | transformV2 mv = demoteV3 . m41ToV3 . (mv !*!) . v3ToM41 . promoteV2 55 | 56 | transformPoly :: M44 Float -> [V2 Float] -> [V2 Float] 57 | transformPoly t = map (transformV2 t) 58 | 59 | transformV3 :: RealFloat a => M44 a -> V3 a -> V3 a 60 | transformV3 t v = m41ToV3 $ t !*! v3ToM41 v 61 | 62 | v3ToM41 :: Num a => V3 a -> V4 (V1 a) 63 | v3ToM41 (V3 x y z) = V4 (V1 x) (V1 y) (V1 z) (V1 1) 64 | 65 | m41ToV3 :: V4 (V1 a) -> V3 a 66 | m41ToV3 (V4 (V1 x) (V1 y) (V1 z) _) = V3 x y z 67 | 68 | rotateAbout :: (Num a, Epsilon a, Floating a) => V3 a -> a -> V3 a -> V3 a 69 | rotateAbout axis phi = m41ToV3 . (mat4Rotate phi axis !*!) . v3ToM41 70 | -------------------------------------------------------------------------------- 71 | -- Matrix helpers 72 | -------------------------------------------------------------------------------- 73 | mat4Translate :: Num a => V3 a -> M44 a 74 | mat4Translate = mkTransformationMat identity 75 | 76 | mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a 77 | mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0) 78 | 79 | mat4Scale :: Num a => V3 a -> M44 a 80 | mat4Scale (V3 x y z) = 81 | V4 (V4 x 0 0 0) 82 | (V4 0 y 0 0) 83 | (V4 0 0 z 0) 84 | (V4 0 0 0 1) 85 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Triangle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Gelatin.Core.Triangle where 6 | 7 | import Data.Vector.Unboxed (Unbox, Vector) 8 | import qualified Data.Vector.Unboxed as V 9 | import Gelatin.Core.Bezier 10 | import Gelatin.Core.Bounds 11 | import Linear 12 | 13 | type Triangle a = (a,a,a) 14 | 15 | trisToComp :: Unbox a => Vector (Triangle (V2 a)) -> Vector (V2 a) 16 | trisToComp = V.concatMap triPoints 17 | 18 | triPoints :: Unbox a => Triangle (V2 a) -> Vector (V2 a) 19 | triPoints (a,b,c) = V.fromList [a, b, c] 20 | 21 | bezToTri :: Bezier a -> Triangle a 22 | bezToTri (_,a,b,c) = (a,b,c) 23 | 24 | triToPath :: Unbox a => Triangle a -> Vector a 25 | triToPath (a,b,c) = V.fromList [a,b,c] 26 | 27 | fmapTriangle :: (t -> t1) -> (t, t, t) -> (t1, t1, t1) 28 | fmapTriangle f (a,b,c) = (f a, f b, f c) 29 | 30 | triBounds :: Triangle (V2 Float) -> BBox 31 | triBounds (a,b,c) = boundingBox $ V.fromList [a,b,c] 32 | -------------------------------------------------------------------------------- 33 | -- Decomposing things into triangles 34 | -------------------------------------------------------------------------------- 35 | sizeToTris :: V2 Float -> Vector (Triangle (V2 Float)) 36 | sizeToTris (V2 w h) = V.fromList [(a,b,c), (a,c,d)] 37 | where [a,b,c,d] = [V2 (-hw) (-hh), V2 hw (-hh), V2 hw hh, V2 (-hw) hh] 38 | (hw,hh) = (w/2,h/2) 39 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Core/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Gelatin.Core.Utils where 6 | 7 | import Data.Vector.Unboxed (Unbox, Vector) 8 | import qualified Data.Vector.Unboxed as V 9 | import Linear 10 | 11 | -- | Determine if a point lies within a polygon path using the even/odd 12 | -- rule. 13 | -- A point is inside a path if it has an odd number of intersections with 14 | -- the boundary (Jordan Curve theorem) 15 | pathHasPoint :: (Ord a, Fractional a, Unbox a) => Vector (V2 a) -> V2 a -> Bool 16 | pathHasPoint vs v = V.foldr' (\s a -> if s then not a else a) False $ 17 | V.zipWith3 f vv vs (V.drop 1 vs) 18 | where vv = V.replicate (V.length vs) v 19 | f a b c = t1 a b c && t2 a b c 20 | t1 p p1 p2 = (y p2 > y p) /= (y p1 > y p) 21 | t2 p p1 p2 = x p < (x p1 - x p2) * (y p - y p2) / (y p1 - y p2) + x p2 22 | x (V2 a _) = a 23 | y (V2 _ b) = b 24 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Picture.hs: -------------------------------------------------------------------------------- 1 | -- | A picture in gelatin's context is a collection of vertices, organized into 2 | -- geometries of triangles, beziers, triangle strips, triangle fans and polylines. 3 | -- The vertices of these pictures can be anything, but the currently available 4 | -- backends already support these vertices: 5 | -- 6 | -- * @(V2 Float, V4 Float)@, ie. colored points in 2d space 7 | -- * @(V2 Float, V2 Float)@, ie. textured points in 2d space 8 | -- 9 | module Gelatin.Picture ( 10 | -- * Defining Vertex Data 11 | VerticesT(..) 12 | , runVerticesT 13 | , Vertices 14 | , runVertices 15 | , tri 16 | , bez 17 | , to 18 | , addVertexList 19 | , segment 20 | , mapVertices 21 | -- * Defining Geometry (Vertex Data + Drawing Operation) 22 | , RawGeometry(..) 23 | , mapRawGeometry 24 | , GeometryT(..) 25 | , runGeometryT 26 | , Geometry 27 | , runGeometry 28 | , triangles 29 | , beziers 30 | , strip 31 | , fan 32 | , line 33 | , mapGeometry 34 | -- * The Picture API 35 | , PictureT 36 | , runPictureT 37 | , Picture 38 | , runPicture 39 | , setRawGeometry 40 | , getRawGeometry 41 | , setGeometry 42 | , setStroke 43 | , getStroke 44 | , setTextures 45 | , getTextures 46 | , setRenderingOptions 47 | , getRenderingOptions 48 | -- * An example of creating a Picture 49 | -- $creating 50 | -- * Making shapes 51 | , module S 52 | -- * Measuring Pictures (2d) 53 | , mapPictureVertices 54 | , pictureBounds2 55 | , pictureSize2 56 | , pictureOrigin2 57 | , pictureCenter2 58 | -- * Measuring Pictures (3d) 59 | , pictureBounds3 60 | , pictureSize3 61 | , pictureOrigin3 62 | , pictureCenter3 63 | -- * Underlying PictureData Exported for renderers 64 | , RenderingOption(..) 65 | , PictureData(..) 66 | ) where 67 | 68 | import Gelatin.Picture.Internal 69 | import Gelatin.Picture.Shapes as S 70 | 71 | -- $creating 72 | -- Here is an example of drawing two colored beziers into a 2d picture using 73 | -- colors from the 'Gelatin.Core.Color' module: 74 | -- 75 | -- > bezierPicture :: Picture tex (V2 Float, V4 Float) () 76 | -- > bezierPicture = setGeometry $ beziers $ do 77 | -- > bez (V2 0 0, white) (V2 200 0, blue) (V2 200 200, green) 78 | -- > bez (V2 400 200, white) (V2 400 0, blue) (V2 200 0, green) 79 | -- 80 | -- Here is the rendering of that picture after being compiled by a backend: 81 | -- 82 | -- <> 83 | -- 84 | -- As you can see the two beziers have different fill directions, the first is 85 | -- fill inner while the second is fill outer. This is determined by the bezier's 86 | -- winding. 87 | -------------------------------------------------------------------------------- /gelatin/src/Gelatin/Picture/Shapes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | module Gelatin.Picture.Shapes where 6 | 7 | import Control.Monad.State.Strict 8 | import Data.Vector.Unboxed (Unbox) 9 | import qualified Data.Vector.Unboxed as V 10 | import Gelatin.Core 11 | import Gelatin.Picture.Internal 12 | import Linear hiding (rotate) 13 | -------------------------------------------------------------------------------- 14 | -- Shapes (at the level of Vertices) 15 | -------------------------------------------------------------------------------- 16 | curve :: (RealFloat a, Unbox a, Monad m) 17 | => V2 a -> V2 a -> V2 a 18 | -> VerticesT (V2 a) m () 19 | curve a b c = 20 | let vs = subdivideAdaptive 100 0 $ bez3 a b c 21 | in Vertices $ modify (V.++ vs) 22 | 23 | corner :: (RealFloat a, Unbox a, Monad m) 24 | => a -> a -> VerticesT (V2 a) m () 25 | corner xr yr = 26 | let vs = cleanSeqDupes $ V.concatMap (subdivideAdaptive 100 0) $ cornerBez3 xr yr 27 | in Vertices $ modify (V.++ vs) 28 | 29 | -- | Create an arched sequence of vertices along an ellipse. 30 | arc 31 | :: (Unbox a, Epsilon a, RealFloat a, Monad m) 32 | => a 33 | -- ^ Width of the ellipse. 34 | -> a 35 | -- ^ Height of the ellipse. 36 | -> a 37 | -- ^ Starting position of the arc on the ellipse in radians. 38 | -> a 39 | -- ^ Ending position of the arc on the ellipse in radians. 40 | -> VerticesT (V2 a) m () 41 | arc w h start stop = 42 | let vs = cleanSeqDupes $ V.concatMap (subdivideAdaptive 100 0) $ arcBez3 w h start stop 43 | in Vertices $ modify (V.++ vs) 44 | 45 | rectangle :: (Unbox a, Monad m) 46 | => V2 a -> V2 a -> VerticesT (V2 a) m () 47 | rectangle tl@(V2 tlx tly) br@(V2 brx bry) = do 48 | to tl 49 | to $ V2 brx tly 50 | to br 51 | to $ V2 tlx bry 52 | -------------------------------------------------------------------------------- /gelatin/stack80-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2016-09-08 2 | compiler: ghcjs-0.2.0.820160908_ghc-8.0.1 3 | compiler-check: match-exact 4 | setup-info: 5 | ghcjs: 6 | source: 7 | ghcjs-0.2.0.820160908_ghc-8.0.1: 8 | url: "http://tolysz.org/ghcjs/untested/ghc-8.0-2016-09-08-nightly-2016-09-08-820160908.tar.gz" 9 | sha1: 68ab94c735ba5173603fb24fa7804541600750e1 10 | allow-newer: true 11 | 12 | packages: 13 | - . 14 | 15 | extra-deps: [] 16 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/schell/gelatin/04c1c83d4297eac4f4cc5e8e5c805b1600b3ee98/screenshot.png -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-11.3 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - gelatin 9 | - gelatin-shaders 10 | - gelatin-gl 11 | - gelatin-sdl2 12 | - gelatin-fruity 13 | - gelatin-freetype2 14 | - gelatin-example 15 | 16 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 17 | extra-deps: 18 | - FontyFruity-0.5.3.2 19 | - freetype2-0.1.1 20 | #- halive-0.1.0.7 21 | # Override default flag values for local packages and extra-deps 22 | flags: {} 23 | 24 | # Extra package databases containing global packages 25 | extra-package-dbs: [] 26 | 27 | # Control whether we use the GHC we find on the path 28 | # system-ghc: true 29 | 30 | # Require a specific version of stack, using version ranges 31 | # require-stack-version: -any # Default 32 | # require-stack-version: >= 1.0.0 33 | 34 | # Override the architecture used by stack, especially useful on Windows 35 | # arch: i386 36 | # arch: x86_64 37 | 38 | # Extra directories used by stack for building 39 | # extra-include-dirs: [/path/to/dir] 40 | # extra-lib-dirs: [/path/to/dir] 41 | 42 | # Allow a newer minor version of GHC than the snapshot specifies 43 | # compiler-check: newer-minor 44 | --------------------------------------------------------------------------------