├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── OpenGL.cabal ├── README.md ├── Setup.hs ├── cabal.haskell-ci ├── specs ├── enumerant │ ├── 00README │ ├── ConvertEnumSpec.hs │ ├── EBNF.txt │ ├── Makefile │ ├── enum.spec │ ├── enumglu.spec │ ├── test.spec │ └── test.stdout ├── function │ ├── ConvertSpec.hs │ ├── FunctionSpec.bnf │ └── Makefile └── preprocess │ ├── Makefile │ └── Preprocess.hs └── src └── Graphics └── Rendering ├── OpenGL.hs └── OpenGL ├── GL.hs ├── GL ├── Antialiasing.hs ├── BeginEnd.hs ├── Bitmaps.hs ├── BlendingFactor.hs ├── BufferMode.hs ├── BufferObjects.hs ├── ByteString.hs ├── Capability.hs ├── Clipping.hs ├── ColorSum.hs ├── Colors.hs ├── ComparisonFunction.hs ├── ConditionalRendering.hs ├── ControlPoint.hs ├── CoordTrans.hs ├── DataType.hs ├── DebugOutput.hs ├── DisplayLists.hs ├── Domain.hs ├── EdgeFlag.hs ├── Evaluators.hs ├── Exception.hs ├── Face.hs ├── Feedback.hs ├── FlushFinish.hs ├── Fog.hs ├── Framebuffer.hs ├── FramebufferObjects.hs ├── FramebufferObjects │ ├── Attachments.hs │ ├── FramebufferObject.hs │ ├── FramebufferObjectAttachment.hs │ ├── FramebufferObjects.hs │ ├── FramebufferTarget.hs │ ├── Queries.hs │ ├── RenderbufferObject.hs │ ├── RenderbufferObjects.hs │ └── RenderbufferTarget.hs ├── GLboolean.hs ├── Hints.hs ├── IOState.hs ├── LineSegments.hs ├── MatrixComponent.hs ├── PeekPoke.hs ├── PerFragment.hs ├── PixelData.hs ├── PixelFormat.hs ├── PixelRectangles.hs ├── PixelRectangles │ ├── ColorTable.hs │ ├── Convolution.hs │ ├── Histogram.hs │ ├── Minmax.hs │ ├── PixelMap.hs │ ├── PixelStorage.hs │ ├── PixelTransfer.hs │ ├── Rasterization.hs │ ├── Reset.hs │ └── Sink.hs ├── PixellikeObject.hs ├── PointParameter.hs ├── Points.hs ├── PolygonMode.hs ├── Polygons.hs ├── PrimitiveMode.hs ├── PrimitiveModeInternal.hs ├── QueryObject.hs ├── QueryObjects.hs ├── QueryUtils.hs ├── QueryUtils │ ├── PName.hs │ └── VertexAttrib.hs ├── RasterPos.hs ├── ReadCopyPixels.hs ├── Rectangles.hs ├── RenderMode.hs ├── SavingState.hs ├── Selection.hs ├── Shaders.hs ├── Shaders │ ├── Attribs.hs │ ├── Limits.hs │ ├── Program.hs │ ├── ProgramBinaries.hs │ ├── ProgramObjects.hs │ ├── Shader.hs │ ├── ShaderBinaries.hs │ ├── ShaderObjects.hs │ ├── Uniform.hs │ └── Variables.hs ├── StringQueries.hs ├── SyncObjects.hs ├── Tensor.hs ├── Texturing.hs ├── Texturing │ ├── Application.hs │ ├── Environments.hs │ ├── Filter.hs │ ├── Objects.hs │ ├── Parameters.hs │ ├── PixelInternalFormat.hs │ ├── Queries.hs │ ├── Specification.hs │ ├── TexParameter.hs │ ├── TextureObject.hs │ ├── TextureTarget.hs │ └── TextureUnit.hs ├── TransformFeedback.hs ├── VertexArrayObjects.hs ├── VertexArrays.hs ├── VertexAttributes.hs └── VertexSpec.hs ├── GLU.hs └── GLU ├── Errors.hs ├── ErrorsInternal.hs ├── Initialization.hs ├── Matrix.hs ├── Mipmapping.hs ├── NURBS.hs ├── Quadrics.hs └── Tessellation.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | *~ 3 | /.cabal-sandbox 4 | /dist/ 5 | /dist-newstyle/ 6 | cabal.sandbox.config 7 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 3.0.3.1 2 | ------- 3 | * Relaxed upper version bound for `bytestring`. 4 | 5 | 3.0.3.0 6 | ------- 7 | * Handle MonadFail proposal. 8 | 9 | 3.0.2.2 10 | ------- 11 | * Relaxed upper version bound for `containers`. 12 | 13 | 3.0.2.1 14 | ------- 15 | * Relaxed upper version bound for `OpenGLRaw`. 16 | 17 | 3.0.2.0 18 | ------- 19 | * Added support for S3_s3tc, EXT_texture_compression_s3tc, ARB_texture_float, and EXT_packed_depth_stencil extensions. 20 | 21 | 3.0.1.0 22 | ------- 23 | * Added `Uniform` instances for `GLmatrix`, `Vertex1`, `Vector1`, `Vector2`, `Vector3`, and `Vector4`. 24 | * Unbreak `Uniform` instances for `GLint`, `GLuint` and `Gldouble`. 25 | * Relaxed upper version bound for `OpenGLRaw`. 26 | 27 | 3.0.0.2 28 | ------- 29 | * Removed redundant constraints. 30 | 31 | 3.0.0.1 32 | ------- 33 | * Relaxed upper version bound for `OpenGLRaw`. 34 | 35 | 3.0.0.0 36 | ------- 37 | * Depend on new `OpenGLRaw` and `GLURaw` packages. 38 | 39 | 2.13.2.1 40 | -------- 41 | * Relaxed upper version bound for `transformers`. 42 | 43 | 2.13.2.0 44 | -------- 45 | * Implement Uniform instances for `GLint`, `GLuint`, `GLfloat`, and `GLdouble`. 46 | 47 | 2.13.1.1 48 | -------- 49 | * Aftermath for the `glClearNamedFramebufferfi` chaos in the OpenGL registry, 50 | see the corresponding 51 | [issue](https://www.khronos.org/bugzilla/show_bug.cgi?id=1394) on Khronos. 52 | 53 | 2.13.1.0 54 | -------- 55 | * Added `extensionSupported`. 56 | * Relaxed upper version bound for OpenGLRaw. 57 | * Added CHANGELOG.md to distribution. 58 | 59 | 2.13.0.0 60 | -------- 61 | * Added missing drawing commands using vertex arrays and some related types. 62 | * Added missing whole framebuffer operations. 63 | * Added getters for `stencilMaskSeparate`, `stencilFuncSeparate`, and `stencilOpSeparate`, making them full-blown `StateVar`s. 64 | * Added `patchDefaultInnerLevel` and `patchDefaultOuterLevel` to control the default tessellation levels. 65 | * Added `ContextLost` constructor to `ErrorCategory` type. 66 | * Added `SeparateAttribs` and deprecated `SeperateAttribs`, fixing a spelling mistake. 67 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2002-2005, Sven Panne 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, 8 | this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the author nor the names of its contributors may be 15 | used to endorse or promote products derived from this software without 16 | specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 22 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 23 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 24 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 26 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 27 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 28 | POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Hackage](https://img.shields.io/hackage/v/OpenGL.svg)](https://hackage.haskell.org/package/OpenGL) 2 | [![Stackage LTS](https://www.stackage.org/package/OpenGL/badge/lts)](https://www.stackage.org/lts/package/OpenGL) 3 | [![Stackage nightly](https://www.stackage.org/package/OpenGL/badge/nightly)](https://www.stackage.org/nightly/package/OpenGL) 4 | [![Build Status](https://img.shields.io/travis/haskell-opengl/OpenGL/master.svg)](https://travis-ci.org/haskell-opengl/OpenGL) 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | apt: freeglut3-dev -------------------------------------------------------------------------------- /specs/enumerant/00README: -------------------------------------------------------------------------------- 1 | This directory contains: 2 | 3 | * ConvertEnumSpec.hs: 4 | 5 | A converter for the transformation of OpenGL enumerant spec files into Haskell 6 | data types, including (un)marshaling functions. 7 | 8 | 9 | * EBNF.txt: 10 | 11 | An LL(1) grammar for enumerant spec files in ISO Extended BNF. The LL(1) 12 | property has been checked with the RDP parser generator, see 13 | 14 | http://www.cs.rhbnc.ac.uk/research/languages/projects/rdp.shtml 15 | 16 | For a draft (= free :-) paper of ISO/IEC 14977:1996, see 17 | 18 | http://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html 19 | 20 | 21 | * enum.spec: 22 | 23 | An OpenGL 1.3 enumerant specification, including extensions. This is a heavily 24 | modified version of the SI's enum.spec (rev. 1.3), cf. 25 | 26 | http://oss.sgi.com/cgi-bin/cvsweb.cgi/projects/ogl-sample/main/gfx/include/gl/spec/enum.spec?rev=1.3 27 | 28 | 29 | * enumglu.spec: 30 | 31 | An almost unmodified GLU 1.3 spec straight from the SI (rev. 1.1), see: 32 | 33 | http://oss.sgi.com/cgi-bin/cvsweb.cgi/projects/ogl-sample/main/doc/registry/specs/enumglu.spec?rev=1.1 34 | 35 | The only change was making "Version" a "define" instead of an "enum". 36 | -------------------------------------------------------------------------------- /specs/enumerant/EBNF.txt: -------------------------------------------------------------------------------- 1 | enumerantSpec = { typeDefinition, ";" }; 2 | typeDefinition = typeName, kind, ":", equations; 3 | kind = "enum" | "mask" | "float" | "define"; 4 | equations = [ equation, ",", { equation } ]; 5 | equation = use | definition; 6 | use = "use", typeName, identifier; 7 | definition = identifier, [ "=", value ]; 8 | value = reference | number; 9 | reference = "$", identifier, [ "+", number ]; 10 | number = hexNumber | decNumber; 11 | hexNumber = ( "0x" | "0X" ), hexDigit, { hexDigit }; 12 | hexDigit = digit | "a" | "b" | "c" | "d" | "e" | "f" 13 | | "A" | "B" | "C" | "D" | "E" | "F"; 14 | decNumber = digit, { digit }; 15 | digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9"; 16 | typeName = word; 17 | identifier = word - "use"; 18 | word = wordChar, { wordChar }; 19 | wordChar = character - (" " | punctuation ); 20 | punctuation = ";" | ":" | "," | "=" | "+" | "$"; 21 | -------------------------------------------------------------------------------- /specs/enumerant/Makefile: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | 3 | TOP = ../../.. 4 | include $(TOP)/mk/boilerplate.mk 5 | 6 | # ----------------------------------------------------------------------------- 7 | 8 | MKDEPENDHS = $(GHC_INPLACE) 9 | HS_PROG = ConvertEnumSpec 10 | CLEAN_FILES += Main.hi test.stdout.tmp 11 | 12 | SRC_HC_OPTS += -cpp -package parsec -package mtl 13 | 14 | TMP_FILE = test.stdout.tmp 15 | 16 | test: ConvertEnumSpec 17 | @$(RM) $(TMP_FILE) 18 | @./ConvertEnumSpec -v test.spec > $(TMP_FILE) 19 | @if diff test.stdout $(TMP_FILE) ; then \ 20 | echo "test passed" ; \ 21 | $(RM) $(TMP_FILE) ; \ 22 | else \ 23 | echo "test failed" ; \ 24 | fi 25 | 26 | # ----------------------------------------------------------------------------- 27 | 28 | include $(TOP)/mk/target.mk 29 | -------------------------------------------------------------------------------- /specs/enumerant/test.spec: -------------------------------------------------------------------------------- 1 | TypeMask mask: 2 | MASK_A 3 | MASK_B 4 | MASK_C 5 | MASK_D 6 | MASK_E 7 | use TypeEnum ENUM_C 8 | use TypeEnum LEFT 9 | RIGHT 10 | 11 | TypeEnum enum: 12 | ENUM_A 13 | ENUM_B 14 | ENUM_C = 42 15 | ENUM_D 16 | use TypeDefine DEFINE_C 17 | ENUM_F 18 | use TypeMask MASK_D 19 | ENUM_H 20 | ENUM_I = $MASK_E 21 | ENUM_J = $ENUM_F + 42 22 | LEFT 23 | use TypeMask RIGHT 24 | 25 | TypeDefine define: 26 | DEFINE_A 27 | DEFINE_B 28 | DEFINE_C = 128 29 | DEFINE_D 30 | DEFINE_E 31 | use TypeEnum ENUM_C 32 | use TypeEnum ENUM_H 33 | -------------------------------------------------------------------------------- /specs/function/FunctionSpec.bnf: -------------------------------------------------------------------------------- 1 | (* An LL(1) grammar for function spec files in RDP syntax, see 2 | http://www.cs.rhbnc.ac.uk/research/languages/projects/rdp.shtml *) 3 | 4 | spec ::= [ requiredProperties ] { validProperty } { category }. 5 | 6 | requiredProperties ::= ':required-props' { propertyName } ';'. 7 | 8 | validProperty ::= ':' validPropertyName validPropertyValues ';'. 9 | validPropertyName ::= 'param' | propertyName. 10 | validPropertyValues ::= [ '*' | propertyValue { propertyValue } ] . 11 | 12 | category ::= functionDeclaration 13 | | newCategory { functionDeclaration } endCategory. 14 | 15 | newCategory ::= ':newcategory' categoryName ';'. 16 | endCategory ::= ':endcategory' ';'. 17 | 18 | functionDeclaration ::= functionName parameters returnType [ ',' paramsAndProps ] ';' . 19 | parameters ::= '(' [ parameterName { ',' parameterName } ] ')'. 20 | returnType ::= 'return' typeName. 21 | paramsAndProps ::= parameterDeclaration [ ',' paramsAndProps ] 22 | | [ functionProperty { ',' functionProperty } ]. 23 | 24 | parameterDeclaration ::= 'param' parameterName parameterType [ lengthDescriptor ] { propertyValue }. 25 | 26 | parameterType ::= typeName direction transferType. 27 | direction ::= 'in' | 'out' | 'in/out'. 28 | transferType ::= 'array' | 'reference' | 'value'. 29 | 30 | lengthDescriptor ::= '[' indexExpression { ',' indexExpression } ']'. 31 | indexExpression ::= term { addOp term }. 32 | addOp ::= '+' | '-'. 33 | term ::= factor { mulOp factor }. 34 | mulOp ::= '*' | '/'. 35 | factor ::= compsize | '(' indexExpression ')' | integer | parameterName. 36 | compsize ::= 'COMPSIZE' '(' [ parameterName { '/' parameterName } ] ')'. 37 | integer ::= digit { digit }. 38 | 39 | functionProperty ::= propertyName { metaPropertyValue }. 40 | 41 | metaPropertyValue ::= [ '!' ] ( 'all' | propertyValue ). 42 | propertyValue ::= word. 43 | 44 | propertyName ::= word. 45 | categoryName ::= word. 46 | functionName ::= word. 47 | typeName ::= word. 48 | parameterName ::= word. 49 | 50 | (* Not totally correct, but with RDP one can't specify a lexer. We really mean: 51 | A word is a non-empty sequence of characters which are not in the set 52 | " \t\n\r\f\v\xa0()[]:,;+*/!". Integers are not words. *) 53 | 54 | word ::= ( upper | lower ) wordChar. 55 | wordChar ::= upper | lower | digit | special. 56 | 57 | upper ::= 'A' | 'B' | 'C' | 'D' | 'E' | 'F' | 'G' | 'H' | 'I' | 'J' 58 | | 'K' | 'L' | 'M' | 'N' | 'O' | 'P' | 'Q' | 'R' | 'S' | 'T' 59 | | 'U' | 'V' | 'W' | 'X' | 'Y' | 'Z'. 60 | 61 | lower ::= 'a' | 'b' | 'c' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 'j' 62 | | 'k' | 'l' | 'm' | 'n' | 'o' | 'p' | 'q' | 'r' | 's' | 't' 63 | | 'u' | 'v' | 'w' | 'x' | 'y' | 'z'. 64 | 65 | digit ::= '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'. 66 | 67 | special ::= '_' | '-' | '.'. 68 | -------------------------------------------------------------------------------- /specs/function/Makefile: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | 3 | TOP = ../../.. 4 | include $(TOP)/mk/boilerplate.mk 5 | 6 | # ----------------------------------------------------------------------------- 7 | 8 | HC = $(GHC_INPLACE) 9 | MKDEPENDHS = $(GHC_INPLACE) 10 | HS_PROG = ConvertSpec 11 | CLEAN_FILES += Main.hi 12 | SRC_HC_OPTS += -package parsec 13 | 14 | # ----------------------------------------------------------------------------- 15 | 16 | include $(TOP)/mk/target.mk 17 | -------------------------------------------------------------------------------- /specs/preprocess/Makefile: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | 3 | TOP = ../../.. 4 | include $(TOP)/mk/boilerplate.mk 5 | 6 | # ----------------------------------------------------------------------------- 7 | 8 | HC = $(GHC_INPLACE) 9 | MKDEPENDHS = $(GHC_INPLACE) 10 | HS_PROG = Preprocess 11 | CLEAN_FILES += Main.hi 12 | 13 | # ----------------------------------------------------------------------------- 14 | 15 | include $(TOP)/mk/target.mk 16 | -------------------------------------------------------------------------------- /specs/preprocess/Preprocess.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- 3 | -- Program : Preprocess 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- The .spec files from the SI are normally processed by Perl/AWK scripts and 12 | -- have therefore a rather ugly line-oriented syntax. To make things more 13 | -- amenable to "real" parsing, some lexical preprocessing is useful. Note that 14 | -- the following algorithm doesn't remove or insert lines, which is important 15 | -- for good error messages later. After this preprocessing, whitespace is not 16 | -- significant anymore, apart from its common use as a token separator. 17 | -- 18 | -- For every line do: 19 | -- 20 | -- 1) Remove comments: Remove everything starting at the first '#'. 21 | -- 22 | -- 2) Ignore passthru-hack: Consider lines starting with 'passthru:' as empty. 23 | -- 24 | -- 3) Remove trailing whitespace. 25 | -- 26 | -- 4) Mangle property declarations: Append ';' to a line where the first ':' 27 | -- is only preceded by non-TAB and non-SPC characters. Additionally, move 28 | -- that ':' to the beginning of the line. 29 | -- 30 | -- 5) Separate definitions: Append ',' to a line starting with TAB and 31 | -- followed (ignoring empty lines) by a line starting with TAB. 32 | -- 33 | -- 6) Terminate definitions: Append ';' to a line starting with TAB and not 34 | -- followed (ignoring empty lines) by a line starting with TAB. 35 | -- 36 | -------------------------------------------------------------------------------- 37 | 38 | module Main ( main ) where 39 | 40 | import Data.Char ( isSpace ) 41 | import Data.List ( isPrefixOf, tails ) 42 | import System.Environment ( getArgs ) 43 | 44 | -------------------------------------------------------------------------------- 45 | -- Preprocessing of spec files, making it more amenable to "real" parsing 46 | -------------------------------------------------------------------------------- 47 | 48 | preprocess :: String -> String 49 | preprocess = unlines . 50 | addSeparators . mangleColonLines . 51 | removeTrailingWhitespace . removePassthru . removeComments . 52 | lines 53 | 54 | where removeComments = map $ takeWhile (/= '#') 55 | removePassthru = map $ \l -> if "passthru:" `isPrefixOf` l then "" else l 56 | removeTrailingWhitespace = map $ reverse . dropWhile isSpace . reverse 57 | mangleColonLines = map $ \l -> 58 | case break (== ':') l of 59 | (xs, ':':ys) | noSpaceIn xs -> ":" ++ xs ++ " " ++ ys ++ ";" 60 | _ -> l 61 | noSpaceIn = not . any (`elem` ['\t',' ']) 62 | 63 | addSeparators = map addSeparator . tails 64 | 65 | addSeparator [] = [] 66 | addSeparator xs@(l:ls) | startsWithTabbedLine xs = l ++ separatorFor ls 67 | | otherwise = l 68 | 69 | separatorFor ls | startsWithTabbedLine (dropEmpty ls) = "," 70 | | otherwise = ";" 71 | 72 | dropEmpty = dropWhile ((== 0) . length) 73 | 74 | startsWithTabbedLine (('\t':_):_) = True 75 | startsWithTabbedLine _ = False 76 | 77 | -------------------------------------------------------------------------------- 78 | -- The driver 79 | -------------------------------------------------------------------------------- 80 | 81 | -- behave like 'cat' 82 | mainWithArgs :: [String] -> IO () 83 | mainWithArgs fileNames = putStr . preprocess =<< input 84 | where input | null fileNames = getContents 85 | | otherwise = fmap concat (mapM readFile fileNames) 86 | 87 | main :: IO () 88 | main = getArgs >>= mainWithArgs 89 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- A Haskell binding for OpenGL, the industry\'s most widely used and 12 | -- supported 2D and 3D graphics API. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL ( 17 | -- * OpenGL Fundamentals 18 | module Graphics.GL.Types, 19 | module Graphics.Rendering.OpenGL.GL.FlushFinish, 20 | module Data.ObjectName, 21 | 22 | -- * Event Model 23 | module Graphics.Rendering.OpenGL.GL.SyncObjects, 24 | module Graphics.Rendering.OpenGL.GL.QueryObjects, 25 | 26 | -- * Vertex Specification and Drawing Commands 27 | module Graphics.Rendering.OpenGL.GL.PrimitiveMode, 28 | module Graphics.Rendering.OpenGL.GL.BeginEnd, 29 | module Graphics.Rendering.OpenGL.GL.Rectangles, 30 | module Graphics.Rendering.OpenGL.GL.ConditionalRendering, 31 | 32 | -- * OpenGL Operation 33 | module Graphics.Rendering.OpenGL.GL.VertexSpec, 34 | module Graphics.Rendering.OpenGL.GL.VertexArrays, 35 | module Graphics.Rendering.OpenGL.GL.VertexArrayObjects, 36 | module Graphics.Rendering.OpenGL.GL.BufferObjects, 37 | module Graphics.Rendering.OpenGL.GL.CoordTrans, 38 | module Graphics.Rendering.OpenGL.GL.Clipping, 39 | module Graphics.Rendering.OpenGL.GL.RasterPos, 40 | module Graphics.Rendering.OpenGL.GL.Colors, 41 | module Graphics.Rendering.OpenGL.GL.Shaders, 42 | 43 | -- * Rasterization 44 | module Graphics.Rendering.OpenGL.GL.Antialiasing, 45 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects, 46 | module Graphics.Rendering.OpenGL.GL.Points, 47 | module Graphics.Rendering.OpenGL.GL.LineSegments, 48 | module Graphics.Rendering.OpenGL.GL.Polygons, 49 | module Graphics.Rendering.OpenGL.GL.PixelRectangles, 50 | module Graphics.Rendering.OpenGL.GL.Bitmaps, 51 | module Graphics.Rendering.OpenGL.GL.Texturing, 52 | module Graphics.Rendering.OpenGL.GL.ColorSum, 53 | module Graphics.Rendering.OpenGL.GL.Fog, 54 | 55 | -- * Per-Fragment Operations and the Framebuffer 56 | module Graphics.Rendering.OpenGL.GL.PerFragment, 57 | module Graphics.Rendering.OpenGL.GL.Framebuffer, 58 | module Graphics.Rendering.OpenGL.GL.ReadCopyPixels, 59 | 60 | -- * Special Functions 61 | module Graphics.Rendering.OpenGL.GL.Evaluators, 62 | module Graphics.Rendering.OpenGL.GL.Selection, 63 | module Graphics.Rendering.OpenGL.GL.Feedback, 64 | module Graphics.Rendering.OpenGL.GL.DisplayLists, 65 | module Graphics.Rendering.OpenGL.GL.Hints, 66 | module Graphics.Rendering.OpenGL.GL.PixellikeObject, 67 | module Graphics.Rendering.OpenGL.GL.TransformFeedback, 68 | module Graphics.Rendering.OpenGL.GL.DebugOutput, 69 | 70 | -- * State and State Requests 71 | module Data.StateVar, 72 | module Graphics.Rendering.OpenGL.GL.Tensor, 73 | module Graphics.Rendering.OpenGL.GL.StringQueries, 74 | module Graphics.Rendering.OpenGL.GL.SavingState 75 | ) where 76 | 77 | import Graphics.GL.Types 78 | import Graphics.Rendering.OpenGL.GL.FlushFinish 79 | import Data.ObjectName 80 | import Data.StateVar 81 | 82 | import Graphics.Rendering.OpenGL.GL.SyncObjects 83 | import Graphics.Rendering.OpenGL.GL.QueryObjects 84 | 85 | import Graphics.Rendering.OpenGL.GL.PrimitiveMode 86 | import Graphics.Rendering.OpenGL.GL.BeginEnd 87 | import Graphics.Rendering.OpenGL.GL.Rectangles 88 | import Graphics.Rendering.OpenGL.GL.ConditionalRendering 89 | 90 | import Graphics.Rendering.OpenGL.GL.VertexSpec 91 | import Graphics.Rendering.OpenGL.GL.VertexArrays 92 | import Graphics.Rendering.OpenGL.GL.VertexArrayObjects 93 | import Graphics.Rendering.OpenGL.GL.BufferObjects 94 | import Graphics.Rendering.OpenGL.GL.CoordTrans 95 | import Graphics.Rendering.OpenGL.GL.Clipping 96 | import Graphics.Rendering.OpenGL.GL.RasterPos 97 | import Graphics.Rendering.OpenGL.GL.Colors 98 | import Graphics.Rendering.OpenGL.GL.Shaders 99 | 100 | import Graphics.Rendering.OpenGL.GL.Antialiasing 101 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects 102 | import Graphics.Rendering.OpenGL.GL.Points 103 | import Graphics.Rendering.OpenGL.GL.LineSegments 104 | import Graphics.Rendering.OpenGL.GL.Polygons 105 | import Graphics.Rendering.OpenGL.GL.PixelRectangles 106 | import Graphics.Rendering.OpenGL.GL.Bitmaps 107 | import Graphics.Rendering.OpenGL.GL.Texturing 108 | import Graphics.Rendering.OpenGL.GL.ColorSum 109 | import Graphics.Rendering.OpenGL.GL.Fog 110 | 111 | import Graphics.Rendering.OpenGL.GL.PerFragment 112 | import Graphics.Rendering.OpenGL.GL.Framebuffer 113 | import Graphics.Rendering.OpenGL.GL.ReadCopyPixels 114 | 115 | import Graphics.Rendering.OpenGL.GL.Evaluators 116 | import Graphics.Rendering.OpenGL.GL.Selection 117 | import Graphics.Rendering.OpenGL.GL.Feedback 118 | import Graphics.Rendering.OpenGL.GL.DisplayLists 119 | import Graphics.Rendering.OpenGL.GL.Hints 120 | import Graphics.Rendering.OpenGL.GL.PixellikeObject 121 | import Graphics.Rendering.OpenGL.GL.TransformFeedback 122 | import Graphics.Rendering.OpenGL.GL.DebugOutput 123 | 124 | import Graphics.Rendering.OpenGL.GL.Tensor 125 | import Graphics.Rendering.OpenGL.GL.StringQueries 126 | import Graphics.Rendering.OpenGL.GL.SavingState 127 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Antialiasing.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Antialiasing 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.2 (Antialiasing) of the OpenGL 2.1 12 | -- specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Antialiasing ( 17 | sampleBuffers, samples, multisample, subpixelBits 18 | ) where 19 | 20 | import Data.StateVar 21 | import Graphics.Rendering.OpenGL.GL.Capability 22 | import Graphics.Rendering.OpenGL.GL.QueryUtils 23 | import Graphics.GL 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | sampleBuffers :: GettableStateVar GLsizei 28 | sampleBuffers = antialiasingInfo GetSampleBuffers 29 | 30 | samples :: GettableStateVar GLsizei 31 | samples = antialiasingInfo GetSamples 32 | 33 | multisample :: StateVar Capability 34 | multisample = makeCapability CapMultisample 35 | 36 | subpixelBits :: GettableStateVar GLsizei 37 | subpixelBits = antialiasingInfo GetSubpixelBits 38 | 39 | antialiasingInfo :: GetPName1I p => p -> GettableStateVar GLsizei 40 | antialiasingInfo = makeGettableStateVar . getSizei1 id 41 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Bitmaps.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Bitmaps 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.7 (Bitmaps) of the OpenGL 2.1 specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.Bitmaps ( 16 | bitmap 17 | ) where 18 | 19 | import Foreign.Ptr 20 | import Graphics.Rendering.OpenGL.GL.CoordTrans 21 | import Graphics.Rendering.OpenGL.GL.Tensor 22 | import Graphics.GL 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | bitmap :: Size -> (Vertex2 GLfloat) -> (Vector2 GLfloat) -> Ptr GLubyte -> IO () 27 | bitmap (Size w h) (Vertex2 xbo ybo) (Vector2 xbi ybi) = 28 | glBitmap w h xbo ybo xbi ybi 29 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/BlendingFactor.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.BlendingFactor 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling BlendingFactor. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.BlendingFactor ( 17 | BlendingFactor(..), marshalBlendingFactor, unmarshalBlendingFactor 18 | ) where 19 | 20 | import Graphics.GL 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | data BlendingFactor = 25 | Zero 26 | | One 27 | | SrcColor 28 | | OneMinusSrcColor 29 | | DstColor 30 | | OneMinusDstColor 31 | | SrcAlpha 32 | | OneMinusSrcAlpha 33 | | DstAlpha 34 | | OneMinusDstAlpha 35 | | ConstantColor 36 | | OneMinusConstantColor 37 | | ConstantAlpha 38 | | OneMinusConstantAlpha 39 | | SrcAlphaSaturate 40 | deriving ( Eq, Ord, Show ) 41 | 42 | marshalBlendingFactor :: BlendingFactor -> GLenum 43 | marshalBlendingFactor x = case x of 44 | Zero -> GL_ZERO 45 | One -> GL_ONE 46 | SrcColor -> GL_SRC_COLOR 47 | OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR 48 | DstColor -> GL_DST_COLOR 49 | OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR 50 | SrcAlpha -> GL_SRC_ALPHA 51 | OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA 52 | DstAlpha -> GL_DST_ALPHA 53 | OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA 54 | ConstantColor -> GL_CONSTANT_COLOR 55 | OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR 56 | ConstantAlpha -> GL_CONSTANT_ALPHA 57 | OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA 58 | SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE 59 | 60 | unmarshalBlendingFactor :: GLenum -> BlendingFactor 61 | unmarshalBlendingFactor x 62 | | x == GL_ZERO = Zero 63 | | x == GL_ONE = One 64 | | x == GL_SRC_COLOR = SrcColor 65 | | x == GL_ONE_MINUS_SRC_COLOR = OneMinusSrcColor 66 | | x == GL_DST_COLOR = DstColor 67 | | x == GL_ONE_MINUS_DST_COLOR = OneMinusDstColor 68 | | x == GL_SRC_ALPHA = SrcAlpha 69 | | x == GL_ONE_MINUS_SRC_ALPHA = OneMinusSrcAlpha 70 | | x == GL_DST_ALPHA = DstAlpha 71 | | x == GL_ONE_MINUS_DST_ALPHA = OneMinusDstAlpha 72 | | x == GL_CONSTANT_COLOR = ConstantColor 73 | | x == GL_ONE_MINUS_CONSTANT_COLOR = OneMinusConstantColor 74 | | x == GL_CONSTANT_ALPHA = ConstantAlpha 75 | | x == GL_ONE_MINUS_CONSTANT_ALPHA = OneMinusConstantAlpha 76 | | x == GL_SRC_ALPHA_SATURATE = SrcAlphaSaturate 77 | | otherwise = error ("unmarshalBlendingFactor: illegal value " ++ show x) 78 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/BufferMode.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.BufferMode 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling BufferMode. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.BufferMode ( 17 | BufferMode(..), marshalBufferMode, unmarshalBufferMode, 18 | unmarshalBufferModeSafe, 19 | maxColorAttachments, 20 | ) where 21 | 22 | import Graphics.GL 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | -- | The set of color buffers which are selected for reading and writing. Note 27 | -- that 'FBOColorAttachment' can only be used with framebuffer objects, while 28 | -- the rest can only be used with the default framebuffer. Furthermore, OpenGL 29 | -- 3.0 deprecated auxiliary buffers, so avoid 'AuxBuffer' in modern code. 30 | 31 | data BufferMode = 32 | NoBuffers 33 | -- ^ No color buffers are selected. 34 | | FrontLeftBuffer 35 | -- ^ Only the front left color buffer is selected. 36 | | FrontRightBuffer 37 | -- ^ Only the front right color buffer is selected. 38 | | BackLeftBuffer 39 | -- ^ Only the back left color buffer is selected. 40 | | BackRightBuffer 41 | -- ^ Only the back right color buffer is selected. 42 | | FrontBuffers 43 | -- ^ Only the front left and front right color buffers are selected. If 44 | -- there is no front right color buffer, only the front left color buffer 45 | -- is selected. 46 | | BackBuffers 47 | -- ^ Only the back left and back right color buffers are selected. If there 48 | -- is no back right color buffer, only the back left color buffer is 49 | -- selected. 50 | | LeftBuffers 51 | -- ^ Only the front left and back left color buffers are selected. If there 52 | -- is no back left color buffer, only the front left color buffer is 53 | -- selected. 54 | | RightBuffers 55 | -- ^ Only the front right and back right color buffers are selected. If 56 | -- there is no back right color buffer, only the front right color buffer 57 | -- is selected. 58 | | FrontAndBackBuffers 59 | -- ^ All the front and back color buffers (front left, front right, back 60 | -- left, back right) are selected. If there are no back color buffers, only 61 | -- the front left and front right color buffers are selected. If there are 62 | -- no right color buffers, only the front left and back left color buffers 63 | -- are selected. If there are no right or back color buffers, only the 64 | -- front left color buffer is selected. 65 | | AuxBuffer GLsizei 66 | -- ^ Only the given auxiliary color buffer no. /i/ is selected. 67 | | FBOColorAttachment GLsizei 68 | -- ^ Only the given color attachment of the bound framebufferobject is selected for reading 69 | -- or writing. 70 | deriving ( Eq, Ord, Show ) 71 | 72 | marshalBufferMode :: BufferMode -> Maybe GLenum 73 | marshalBufferMode x = case x of 74 | NoBuffers -> Just GL_NONE 75 | FrontLeftBuffer -> Just GL_FRONT_LEFT 76 | FrontRightBuffer -> Just GL_FRONT_RIGHT 77 | BackLeftBuffer -> Just GL_BACK_LEFT 78 | BackRightBuffer -> Just GL_BACK_RIGHT 79 | FrontBuffers -> Just GL_FRONT 80 | BackBuffers -> Just GL_BACK 81 | LeftBuffers -> Just GL_LEFT 82 | RightBuffers -> Just GL_RIGHT 83 | FrontAndBackBuffers -> Just GL_FRONT_AND_BACK 84 | AuxBuffer i 85 | | fromIntegral i <= maxAuxBuffer -> Just (GL_AUX0 + fromIntegral i) 86 | | otherwise -> Nothing 87 | FBOColorAttachment i 88 | | fromIntegral i <= maxColorAttachments -> Just (GL_COLOR_ATTACHMENT0 + fromIntegral i) 89 | | otherwise -> Nothing 90 | 91 | unmarshalBufferMode :: GLenum -> BufferMode 92 | unmarshalBufferMode x = maybe 93 | (error ("unmarshalBufferMode: illegal value " ++ show x)) id $ unmarshalBufferModeSafe x 94 | 95 | unmarshalBufferModeSafe :: GLenum -> Maybe BufferMode 96 | unmarshalBufferModeSafe x 97 | | x == GL_NONE = Just NoBuffers 98 | | x == GL_FRONT_LEFT = Just FrontLeftBuffer 99 | | x == GL_FRONT_RIGHT = Just FrontRightBuffer 100 | | x == GL_BACK_LEFT = Just BackLeftBuffer 101 | | x == GL_BACK_RIGHT = Just BackRightBuffer 102 | | x == GL_FRONT = Just FrontBuffers 103 | | x == GL_BACK = Just BackBuffers 104 | | x == GL_LEFT = Just LeftBuffers 105 | | x == GL_RIGHT = Just RightBuffers 106 | | x == GL_FRONT_AND_BACK = Just FrontAndBackBuffers 107 | | GL_AUX0 <= x && x <= GL_AUX0 + maxAuxBuffer = Just . AuxBuffer . fromIntegral $ x - GL_AUX0 108 | | GL_COLOR_ATTACHMENT0 <= x && x <= GL_COLOR_ATTACHMENT0 + maxColorAttachments 109 | = Just . FBOColorAttachment . fromIntegral $ x - GL_COLOR_ATTACHMENT0 110 | | otherwise = Nothing 111 | 112 | maxAuxBuffer :: GLenum 113 | maxAuxBuffer = 246 114 | 115 | maxColorAttachments :: GLenum 116 | maxColorAttachments = 16 117 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/ByteString.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.ByteString 5 | -- Copyright : (c) Sven Panne 2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for interfacing with ByteStrings. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.ByteString ( 17 | B.ByteString, stringQuery, createAndTrimByteString, 18 | withByteString, withGLstring, 19 | packUtf8, unpackUtf8, 20 | getStringWith 21 | ) where 22 | 23 | import Data.StateVar 24 | import Foreign.Ptr 25 | import Graphics.Rendering.OpenGL.GL.QueryUtils 26 | import Graphics.GL 27 | import qualified Data.ByteString as B 28 | import qualified Data.ByteString.Internal as BI 29 | import qualified Data.ByteString.Unsafe as BU 30 | import qualified Data.Text as T 31 | import qualified Data.Text.Encoding as TE 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | stringQuery :: (a -> GettableStateVar GLsizei) 36 | -> (a -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()) 37 | -> a 38 | -> IO B.ByteString 39 | stringQuery lengthVar getStr obj = do 40 | len <- get (lengthVar obj) 41 | createByteString len $ 42 | getStr obj len nullPtr 43 | 44 | createByteString :: Integral a => a -> (Ptr GLchar -> IO ()) -> IO B.ByteString 45 | createByteString size act = BI.create (fromIntegral size) (act . castPtr) 46 | 47 | createAndTrimByteString :: 48 | (Integral a, Integral b) => a -> (Ptr GLchar -> IO b) -> IO B.ByteString 49 | createAndTrimByteString maxLen act = 50 | BI.createAndTrim (fromIntegral maxLen) (fmap fromIntegral . act . castPtr) 51 | 52 | withByteString :: B.ByteString -> (Ptr GLchar -> GLsizei -> IO b) -> IO b 53 | withByteString bs act = 54 | BU.unsafeUseAsCStringLen bs $ \(ptr, size) -> 55 | act (castPtr ptr) (fromIntegral size) 56 | 57 | withGLstring :: String -> (Ptr GLchar -> IO a) -> IO a 58 | withGLstring s act = withByteString (packUtf8 (s ++ "\0")) (const . act) 59 | 60 | packUtf8 :: String -> B.ByteString 61 | packUtf8 = TE.encodeUtf8 . T.pack 62 | 63 | unpackUtf8 :: B.ByteString -> String 64 | unpackUtf8 = T.unpack . TE.decodeUtf8 65 | 66 | getStringWith :: IO (Ptr GLubyte) -> IO String 67 | getStringWith getStr = getStr >>= maybeNullPtr (return "") peekGLstring 68 | 69 | peekGLstring :: Ptr GLubyte -> IO String 70 | peekGLstring p = fmap unpackUtf8 $ BU.unsafePackCString (castPtr p) 71 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Clipping.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Clipping 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 13.5 (Primitive Clipping) of the OpenGL 12 | -- 4.4 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Clipping ( 17 | ClipPlaneName(..), clipPlane, maxClipPlanes 18 | ) where 19 | 20 | import Data.StateVar 21 | import Foreign.Marshal.Alloc 22 | import Foreign.Marshal.Utils 23 | import Foreign.Ptr 24 | import Foreign.Storable 25 | import Graphics.Rendering.OpenGL.GL.Capability 26 | import Graphics.Rendering.OpenGL.GL.CoordTrans 27 | import Graphics.Rendering.OpenGL.GL.QueryUtils 28 | import Graphics.Rendering.OpenGL.GLU.ErrorsInternal 29 | import Graphics.GL 30 | 31 | -------------------------------------------------------------------------------- 32 | 33 | newtype ClipPlaneName = ClipPlaneName GLsizei 34 | deriving ( Eq, Ord, Show ) 35 | 36 | -------------------------------------------------------------------------------- 37 | 38 | clipPlane :: ClipPlaneName -> StateVar (Maybe (Plane GLdouble)) 39 | clipPlane name = 40 | makeStateVarMaybe 41 | (return $ nameToCap name) 42 | (alloca $ \buf -> do 43 | clipPlaneAction name $ flip glGetClipPlane $ castPtr buf 44 | peek buf) 45 | (\plane -> with plane $ clipPlaneAction name . flip glClipPlane . castPtr) 46 | 47 | nameToCap :: ClipPlaneName -> EnableCap 48 | nameToCap (ClipPlaneName i) = CapClipPlane i 49 | 50 | clipPlaneAction :: ClipPlaneName -> (GLenum -> IO ()) -> IO () 51 | clipPlaneAction (ClipPlaneName i) act = 52 | maybe recordInvalidEnum act (clipPlaneIndexToEnum i) 53 | 54 | -------------------------------------------------------------------------------- 55 | 56 | maxClipPlanes :: GettableStateVar GLsizei 57 | maxClipPlanes = makeGettableStateVar (getSizei1 id GetMaxClipPlanes) 58 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/ColorSum.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.ColorSum 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.9 (Color Sum) of the OpenGL 2.1 specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.ColorSum ( 16 | colorSum 17 | ) where 18 | 19 | import Data.StateVar 20 | import Graphics.Rendering.OpenGL.GL.Capability 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | colorSum :: StateVar Capability 25 | colorSum = makeCapability CapColorSum 26 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/ComparisonFunction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.ComparisonFunction 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling ComparisonFunction. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.ComparisonFunction ( 17 | ComparisonFunction(..), marshalComparisonFunction, 18 | unmarshalComparisonFunction 19 | ) where 20 | 21 | import Graphics.GL 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | data ComparisonFunction = 26 | Never 27 | | Less 28 | | Equal 29 | | Lequal 30 | | Greater 31 | | Notequal 32 | | Gequal 33 | | Always 34 | deriving ( Eq, Ord, Show ) 35 | 36 | marshalComparisonFunction :: ComparisonFunction -> GLenum 37 | marshalComparisonFunction x = case x of 38 | Never -> GL_NEVER 39 | Less -> GL_LESS 40 | Equal -> GL_EQUAL 41 | Lequal -> GL_LEQUAL 42 | Greater -> GL_GREATER 43 | Notequal -> GL_NOTEQUAL 44 | Gequal -> GL_GEQUAL 45 | Always -> GL_ALWAYS 46 | 47 | unmarshalComparisonFunction :: GLenum -> ComparisonFunction 48 | unmarshalComparisonFunction x 49 | | x == GL_NEVER = Never 50 | | x == GL_LESS = Less 51 | | x == GL_EQUAL = Equal 52 | | x == GL_LEQUAL = Lequal 53 | | x == GL_GREATER = Greater 54 | | x == GL_NOTEQUAL = Notequal 55 | | x == GL_GEQUAL = Gequal 56 | | x == GL_ALWAYS = Always 57 | | otherwise = error ("unmarshalComparisonFunction: illegal value " ++ show x) 58 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/ConditionalRendering.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.ConditionalRendering 4 | -- Copyright : (c) Sven Panne 2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 10.10 (Conditional Rendering) of the 12 | -- OpenGL 4.4 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.ConditionalRendering ( 17 | ConditionalRenderMode(..), 18 | beginConditionalRender, endConditionalRender, withConditionalRender 19 | ) where 20 | 21 | import Graphics.Rendering.OpenGL.GL.Exception 22 | import Graphics.Rendering.OpenGL.GL.QueryObject 23 | import Graphics.GL 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | data ConditionalRenderMode = 28 | QueryWait 29 | | QueryNoWait 30 | | QueryByRegionWait 31 | | QueryByRegionNoWait 32 | deriving ( Eq, Ord, Show ) 33 | 34 | marshalConditionalRenderMode :: ConditionalRenderMode -> GLenum 35 | marshalConditionalRenderMode x = case x of 36 | QueryWait -> GL_QUERY_WAIT 37 | QueryNoWait -> GL_QUERY_NO_WAIT 38 | QueryByRegionWait -> GL_QUERY_BY_REGION_WAIT 39 | QueryByRegionNoWait -> GL_QUERY_BY_REGION_NO_WAIT 40 | 41 | -------------------------------------------------------------------------------- 42 | 43 | beginConditionalRender :: QueryObject -> ConditionalRenderMode -> IO () 44 | beginConditionalRender q = 45 | glBeginConditionalRender (queryID q) . marshalConditionalRenderMode 46 | 47 | endConditionalRender :: IO () 48 | endConditionalRender = glEndConditionalRender 49 | 50 | withConditionalRender :: QueryObject -> ConditionalRenderMode -> IO a -> IO a 51 | withConditionalRender q m = 52 | bracket_ (beginConditionalRender q m) endConditionalRender 53 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/DisplayLists.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.DisplayLists 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 5.4 (Display Lists) of the OpenGL 2.1 12 | -- specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.DisplayLists ( 17 | -- * Defining Display Lists 18 | DisplayList(DisplayList), ListMode(..), defineList, defineNewList, listIndex, 19 | listMode, maxListNesting, 20 | 21 | -- * Calling Display Lists 22 | callList, callLists, listBase 23 | ) where 24 | 25 | import Control.Monad.IO.Class 26 | import Data.ObjectName 27 | import Data.StateVar 28 | import Foreign.Ptr ( Ptr ) 29 | import Graphics.Rendering.OpenGL.GL.DebugOutput 30 | import Graphics.Rendering.OpenGL.GL.DataType 31 | import Graphics.Rendering.OpenGL.GL.Exception 32 | import Graphics.Rendering.OpenGL.GL.GLboolean 33 | import Graphics.Rendering.OpenGL.GL.QueryUtils 34 | import Graphics.Rendering.OpenGL.GLU.ErrorsInternal 35 | import Graphics.GL 36 | 37 | -------------------------------------------------------------------------------- 38 | 39 | newtype DisplayList = DisplayList { displayListID :: GLuint } 40 | deriving ( Eq, Ord, Show ) 41 | 42 | instance ObjectName DisplayList where 43 | isObjectName = liftIO . fmap unmarshalGLboolean . glIsList . displayListID 44 | deleteObjectNames = 45 | liftIO . mapM_ (uncurry glDeleteLists) . combineConsecutive 46 | 47 | instance CanBeLabeled DisplayList where 48 | objectLabel = objectNameLabel GL_DISPLAY_LIST . displayListID 49 | 50 | combineConsecutive :: [DisplayList] -> [(GLuint, GLsizei)] 51 | combineConsecutive [] = [] 52 | combineConsecutive (z:zs) = (displayListID z, len) : combineConsecutive rest 53 | where (len, rest) = run (0 :: GLsizei) z zs 54 | run n x xs = case n + 1 of 55 | m -> case xs of 56 | [] -> (m, []) 57 | (y:ys) | x `isFollowedBy` y -> run m y ys 58 | | otherwise -> (m, xs) 59 | DisplayList x `isFollowedBy` DisplayList y = x + 1 == y 60 | 61 | instance GeneratableObjectName DisplayList where 62 | genObjectNames n = liftIO $ do 63 | first <- glGenLists (fromIntegral n) 64 | if DisplayList first == noDisplayList 65 | then do recordOutOfMemory 66 | return [] 67 | else return [ DisplayList l 68 | | l <- [ first .. first + fromIntegral n - 1 ] ] 69 | 70 | -------------------------------------------------------------------------------- 71 | 72 | data ListMode = 73 | Compile 74 | | CompileAndExecute 75 | deriving ( Eq, Ord, Show ) 76 | 77 | marshalListMode :: ListMode -> GLenum 78 | marshalListMode x = case x of 79 | Compile -> GL_COMPILE 80 | CompileAndExecute -> GL_COMPILE_AND_EXECUTE 81 | 82 | unmarshalListMode :: GLenum -> ListMode 83 | unmarshalListMode x 84 | | x == GL_COMPILE = Compile 85 | | x == GL_COMPILE_AND_EXECUTE = CompileAndExecute 86 | | otherwise = error ("unmarshalListMode: illegal value " ++ show x) 87 | 88 | -------------------------------------------------------------------------------- 89 | 90 | defineList :: DisplayList -> ListMode -> IO a -> IO a 91 | defineList dl mode = 92 | bracket_ (glNewList (displayListID dl) (marshalListMode mode)) glEndList 93 | 94 | defineNewList :: ListMode -> IO a -> IO DisplayList 95 | defineNewList mode action = do 96 | lst <- genObjectName 97 | _ <- defineList lst mode action 98 | return lst 99 | 100 | -------------------------------------------------------------------------------- 101 | 102 | listIndex :: GettableStateVar (Maybe DisplayList) 103 | listIndex = 104 | makeGettableStateVar 105 | (do l <- getEnum1 (DisplayList . fromIntegral) GetListIndex 106 | return $ if l == noDisplayList then Nothing else Just l) 107 | 108 | noDisplayList :: DisplayList 109 | noDisplayList = DisplayList 0 110 | 111 | listMode :: GettableStateVar ListMode 112 | listMode = makeGettableStateVar (getEnum1 unmarshalListMode GetListMode) 113 | 114 | maxListNesting :: GettableStateVar GLsizei 115 | maxListNesting = makeGettableStateVar (getSizei1 id GetMaxListNesting) 116 | 117 | -------------------------------------------------------------------------------- 118 | 119 | callList :: DisplayList -> IO () 120 | callList = glCallList . displayListID 121 | 122 | callLists :: GLsizei -> DataType -> Ptr a -> IO () 123 | callLists n = glCallLists n . marshalDataType 124 | 125 | -------------------------------------------------------------------------------- 126 | 127 | listBase :: StateVar DisplayList 128 | listBase = 129 | makeStateVar 130 | (getEnum1 (DisplayList . fromIntegral) GetListBase) 131 | (glListBase . displayListID) 132 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Domain.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Domain 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for handling evaluator domains. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | {-# LANGUAGE TypeSynonymInstances #-} 17 | 18 | module Graphics.Rendering.OpenGL.GL.Domain ( 19 | Domain(..) 20 | ) where 21 | 22 | import Foreign.Ptr 23 | import Foreign.Storable 24 | import Graphics.Rendering.OpenGL.GL.QueryUtils 25 | import Graphics.GL 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | class Storable d => Domain d where 30 | glMap1 :: GLenum -> d -> d -> GLint -> GLint -> Ptr d -> IO () 31 | glMap2 :: GLenum -> d -> d -> GLint -> GLint -> d -> d -> GLint -> GLint -> Ptr d -> IO () 32 | glGetMapv :: GLenum -> GLenum -> Ptr d -> IO () 33 | evalCoord1 :: d -> IO () 34 | evalCoord1v :: Ptr d -> IO () 35 | evalCoord2 :: (d, d) -> IO () 36 | evalCoord2v :: Ptr d -> IO () 37 | glMapGrid1 :: GLint -> d -> d -> IO () 38 | glMapGrid2 :: GLint -> d -> d -> GLint -> d -> d -> IO () 39 | get2 :: GetPName2F p => (d -> d -> a) -> p -> IO a 40 | get4 :: GetPName4F p => (d -> d -> d -> d -> a) -> p -> IO a 41 | 42 | -------------------------------------------------------------------------------- 43 | 44 | instance Domain GLfloat where 45 | glMap1 = glMap1f 46 | glMap2 = glMap2f 47 | glGetMapv = glGetMapfv 48 | evalCoord1 = glEvalCoord1f 49 | evalCoord1v = glEvalCoord1fv 50 | evalCoord2 = uncurry glEvalCoord2f 51 | evalCoord2v = glEvalCoord2fv 52 | glMapGrid1 = glMapGrid1f 53 | glMapGrid2 = glMapGrid2f 54 | get2 = getFloat2 55 | get4 = getFloat4 56 | 57 | instance Domain GLdouble where 58 | glMap1 = glMap1d 59 | glMap2 = glMap2d 60 | glGetMapv = glGetMapdv 61 | evalCoord1 = glEvalCoord1d 62 | evalCoord1v = glEvalCoord1dv 63 | evalCoord2 = uncurry glEvalCoord2d 64 | evalCoord2v = glEvalCoord2dv 65 | glMapGrid1 = glMapGrid1d 66 | glMapGrid2 = glMapGrid2d 67 | get2 = getDouble2 68 | get4 = getDouble4 69 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/EdgeFlag.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.EdgeFlag 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling EdgeFlag. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.EdgeFlag ( 17 | EdgeFlag(..), marshalEdgeFlag, unmarshalEdgeFlag 18 | ) where 19 | 20 | import Graphics.Rendering.OpenGL.GL.GLboolean 21 | import Graphics.GL 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | -- | A vertex can begin an edge which lies in the interior of its polygon or on 26 | -- the polygon\'s boundary. 27 | 28 | data EdgeFlag = BeginsInteriorEdge | BeginsBoundaryEdge 29 | deriving ( Eq, Ord, Show ) 30 | 31 | marshalEdgeFlag :: EdgeFlag -> GLboolean 32 | marshalEdgeFlag = marshalGLboolean . (BeginsBoundaryEdge ==) 33 | 34 | unmarshalEdgeFlag :: GLboolean -> EdgeFlag 35 | unmarshalEdgeFlag f = 36 | if unmarshalGLboolean f then BeginsBoundaryEdge else BeginsInteriorEdge 37 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Graphics.Rendering.OpenGL.GL.Exception 6 | -- Copyright : (c) Sven Panne 2002-2019 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : Sven Panne 10 | -- Stability : stable 11 | -- Portability : portable 12 | -- 13 | -- This is a purely internal module to compensate for differences between 14 | -- Haskell implementations. 15 | -- 16 | -------------------------------------------------------------------------------- 17 | 18 | module Graphics.Rendering.OpenGL.GL.Exception ( 19 | bracket, bracket_, unsafeBracket_, finallyRet 20 | ) where 21 | 22 | import Data.IORef ( newIORef, readIORef, writeIORef ) 23 | 24 | #ifdef __NHC__ 25 | import qualified IO ( bracket, bracket_ ) 26 | 27 | {-# INLINE bracket #-} 28 | bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c 29 | bracket = IO.bracket 30 | 31 | {-# INLINE bracket_ #-} 32 | bracket_ :: IO a -> IO b -> IO c -> IO c 33 | bracket_ before = IO.bracket_ before . const 34 | 35 | finally :: IO a -> IO b -> IO a 36 | finally = flip . bracket_ . return $ undefined 37 | #else 38 | import Control.Exception ( bracket, bracket_, finally ) 39 | #endif 40 | 41 | {-# INLINE unsafeBracket_ #-} 42 | unsafeBracket_ :: IO a -> IO b -> IO c -> IO c 43 | unsafeBracket_ before after thing = do 44 | _ <- before 45 | r <- thing 46 | _ <- after 47 | return r 48 | 49 | {-# INLINE finallyRet #-} 50 | finallyRet :: IO a -> IO b -> IO (a, b) 51 | a `finallyRet` sequel = do 52 | r2Ref <- newIORef undefined 53 | r1 <- a `finally` (sequel >>= writeIORef r2Ref) 54 | r2 <- readIORef r2Ref 55 | return (r1, r2) 56 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Face.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Face 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling Face. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Face ( 17 | Face(..), marshalFace, unmarshalFace 18 | ) where 19 | 20 | import Graphics.GL 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | data Face = 25 | Front 26 | | Back 27 | | FrontAndBack 28 | deriving ( Eq, Ord, Show ) 29 | 30 | marshalFace :: Face -> GLenum 31 | marshalFace x = case x of 32 | Front -> GL_FRONT 33 | Back -> GL_BACK 34 | FrontAndBack -> GL_FRONT_AND_BACK 35 | 36 | unmarshalFace :: GLenum -> Face 37 | unmarshalFace x 38 | | x == GL_FRONT = Front 39 | | x == GL_BACK = Back 40 | | x == GL_FRONT_AND_BACK = FrontAndBack 41 | | otherwise = error ("unmarshalFace: illegal value " ++ show x) 42 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FlushFinish.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.FlushFinish 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 2.3.2 (Flush and Finish) of the OpenGL 4.4 12 | -- specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.FlushFinish ( 17 | flush, finish 18 | ) where 19 | 20 | import Graphics.GL 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | -- | Different GL implementations buffer commands in several different 25 | -- locations, including network buffers and the graphics accelerator itself. 26 | -- 'flush' empties all of these buffers, causing all issued commands to be 27 | -- executed as quickly as they are accepted by the actual rendering engine. 28 | -- Though this execution may not be completed in any particular time period, it 29 | -- does complete in finite time. 30 | -- 31 | -- Because any GL program might be executed over a network, or on an accelerator 32 | -- that buffers commands, all programs should call 'flush' whenever they count 33 | -- on having all of their previously issued commands completed. For example, 34 | -- call 'flush' before waiting for user input that depends on the generated 35 | -- image. 36 | -- 37 | -- Note that 'flush' can return at any time. It does not wait until the 38 | -- execution of all previously issued GL commands is complete. 39 | 40 | flush :: IO () 41 | flush = glFlush 42 | 43 | -- | 'finish' does not return until the effects of all previously called GL 44 | -- commands are complete. Such effects include all changes to GL state, all 45 | -- changes to connection state, and all changes to the frame buffer contents. 46 | -- 47 | -- Note that 'finish' requires a round trip to the server. 48 | 49 | finish :: IO () 50 | finish = glFinish 51 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Sven Panne 2019 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : Sven Panne 7 | -- Stability : stable 8 | -- Portability : portable 9 | -- 10 | -- Framebuffer objects. 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects ( 15 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments, 16 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects, 17 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.Queries, 18 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects 19 | ) where 20 | 21 | 22 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments 23 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects 24 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.Queries 25 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects 26 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/Attachments.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments 4 | -- Copyright : (c) Sven Panne 2011-2019, Lars Corbijn 2011-2016 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.Attachments ( 14 | FramebufferObjectAttachment(..), 15 | 16 | fboaToBufferMode, fboaFromBufferMode, 17 | 18 | FramebufferAttachment(..), 19 | 20 | framebufferRenderbuffer, framebufferTexture1D, framebufferTexture2D, 21 | framebufferTexture3D, framebufferTextureLayer 22 | ) where 23 | 24 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment 25 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget 26 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject 27 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget 28 | import Graphics.Rendering.OpenGL.GL.Texturing.Specification 29 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureObject 30 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget 31 | import Graphics.Rendering.OpenGL.GLU.ErrorsInternal 32 | import Graphics.GL 33 | 34 | ----------------------------------------------------------------------------- 35 | 36 | framebufferRenderbuffer :: FramebufferTarget -> FramebufferObjectAttachment 37 | -> RenderbufferTarget -> RenderbufferObject -> IO () 38 | framebufferRenderbuffer fbt fba rbt (RenderbufferObject rboi) = 39 | maybe recordInvalidValue (\mfba -> glFramebufferRenderbuffer (marshalFramebufferTarget fbt) 40 | mfba (marshalRenderbufferTarget rbt) rboi) $ marshalFramebufferObjectAttachment fba 41 | 42 | framebufferTexture1D :: FramebufferTarget -> FramebufferObjectAttachment 43 | -> TextureTarget1D -> TextureObject -> Level -> IO () 44 | framebufferTexture1D fbt fba tt (TextureObject t) l = maybe recordInvalidValue 45 | (\mfba -> glFramebufferTexture1D (marshalFramebufferTarget fbt) mfba 46 | (marshalQueryableTextureTarget tt) t l) $ marshalFramebufferObjectAttachment fba 47 | 48 | -- Note: Typing is too permissive, no TEXTURE_1D_ARRAY allowed per 4.4. spec. 49 | framebufferTexture2D :: FramebufferTarget -> FramebufferObjectAttachment 50 | -> TextureTarget2D -> TextureObject -> Level -> IO () 51 | framebufferTexture2D fbt fba tt (TextureObject t) l = maybe recordInvalidValue 52 | (\mfba -> glFramebufferTexture2D (marshalFramebufferTarget fbt) mfba 53 | (marshalQueryableTextureTarget tt) t l) 54 | $ marshalFramebufferObjectAttachment fba 55 | 56 | -- Note: Typing is too permissive, no TEXTURE_2D_ARRAY or TEXTURE_2D_MULTISAMPLE_ARRAY allowed per 4.4. spec. 57 | framebufferTexture3D :: FramebufferTarget -> FramebufferObjectAttachment 58 | -> TextureTarget3D -> TextureObject -> Level -> GLint -> IO () 59 | framebufferTexture3D fbt fba tt (TextureObject t) le la = maybe recordInvalidValue 60 | (\mfba -> glFramebufferTexture3D (marshalFramebufferTarget fbt) mfba 61 | (marshalQueryableTextureTarget tt) t le la) $ marshalFramebufferObjectAttachment fba 62 | 63 | framebufferTextureLayer :: FramebufferTarget -> FramebufferObjectAttachment 64 | -> TextureObject -> Level -> GLint -> IO() 65 | framebufferTextureLayer fbt fba (TextureObject t) le la = maybe recordInvalidValue 66 | (\mfba -> glFramebufferTextureLayer (marshalFramebufferTarget fbt) 67 | mfba t le la) $ marshalFramebufferObjectAttachment fba 68 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferObject.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObject 5 | -- Copyright : (c) Sven Panne 2013-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for handling FramebufferObjects. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObject ( 17 | FramebufferObject(..) 18 | ) where 19 | 20 | import Control.Monad.IO.Class 21 | import Data.ObjectName 22 | import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) 23 | import Graphics.Rendering.OpenGL.GL.DebugOutput 24 | import Graphics.Rendering.OpenGL.GL.GLboolean 25 | import Graphics.Rendering.OpenGL.GL.QueryUtils 26 | import Graphics.GL 27 | 28 | -------------------------------------------------------------------------------- 29 | 30 | newtype FramebufferObject = FramebufferObject { framebufferID :: GLuint } 31 | deriving ( Eq, Ord, Show ) 32 | 33 | instance ObjectName FramebufferObject where 34 | isObjectName = 35 | liftIO . fmap unmarshalGLboolean . glIsFramebuffer . framebufferID 36 | 37 | deleteObjectNames objs = 38 | liftIO . withArrayLen (map framebufferID objs) $ 39 | glDeleteFramebuffers . fromIntegral 40 | 41 | instance GeneratableObjectName FramebufferObject where 42 | genObjectNames n = 43 | liftIO . allocaArray n $ \buf -> do 44 | glGenFramebuffers (fromIntegral n) buf 45 | fmap (map FramebufferObject) $ peekArray n buf 46 | 47 | instance CanBeLabeled FramebufferObject where 48 | objectLabel = objectNameLabel GL_FRAMEBUFFER . framebufferID 49 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferObjectAttachment.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment 5 | -- Copyright : (c) Sven Panne 2013-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for marshaling FramebufferObjectAttachments. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment ( 17 | FramebufferObjectAttachment(..), 18 | marshalFramebufferObjectAttachment, 19 | unmarshalFramebufferObjectAttachment, 20 | unmarshalFramebufferObjectAttachmentSafe, 21 | fboaToBufferMode, fboaFromBufferMode, 22 | 23 | FramebufferAttachment(..), getFBAParameteriv 24 | ) where 25 | 26 | import Data.Maybe 27 | import Foreign.Marshal 28 | import Graphics.Rendering.OpenGL.GL.BufferMode 29 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget 30 | import Graphics.Rendering.OpenGL.GL.PeekPoke 31 | import Graphics.GL 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | data FramebufferObjectAttachment = 36 | ColorAttachment !GLuint 37 | | DepthAttachment 38 | | StencilAttachment 39 | | DepthStencilAttachment 40 | deriving ( Eq, Ord, Show ) 41 | 42 | marshalFramebufferObjectAttachment :: FramebufferObjectAttachment -> Maybe GLenum 43 | marshalFramebufferObjectAttachment x = case x of 44 | ColorAttachment c -> let ec = fromIntegral c in if ec >= maxColorAttachments 45 | then Nothing 46 | else Just $ GL_COLOR_ATTACHMENT0 + ec 47 | DepthAttachment -> Just GL_DEPTH_ATTACHMENT 48 | StencilAttachment -> Just GL_STENCIL_ATTACHMENT 49 | DepthStencilAttachment -> Just GL_DEPTH_STENCIL_ATTACHMENT 50 | 51 | unmarshalFramebufferObjectAttachment :: GLenum -> FramebufferObjectAttachment 52 | unmarshalFramebufferObjectAttachment x = maybe 53 | (error $ "unmarshalFramebufferObjectAttachment: unknown enum value " ++ show x) id $ 54 | unmarshalFramebufferObjectAttachmentSafe x 55 | --unmarshalFramebufferObjectAttachment x 56 | -- | x == GL_DEPTH_ATTACHMENT = DepthAttachment 57 | -- | x == GL_STENCIL_ATTACHMENT = StencilAttachment 58 | -- | x == GL_DEPTH_STENCIL_ATTACHMENT = DepthStencilAttachment 59 | -- | x >= gl_COLOR_ATTACHMENT0 && x <= gl_COLOR_ATTACHMENT15 60 | -- = ColorAttachment . fromIntegral $ x - gl_COLOR_ATTACHMENT0 61 | -- | otherwise = error $ "unmarshalFramebufferObjectAttachment: unknown enum value " ++ show x 62 | 63 | unmarshalFramebufferObjectAttachmentSafe :: GLenum -> Maybe FramebufferObjectAttachment 64 | unmarshalFramebufferObjectAttachmentSafe x 65 | | x == GL_DEPTH_ATTACHMENT = Just DepthAttachment 66 | | x == GL_STENCIL_ATTACHMENT = Just StencilAttachment 67 | | x == GL_DEPTH_STENCIL_ATTACHMENT = Just DepthStencilAttachment 68 | | x >= GL_COLOR_ATTACHMENT0 && x <= GL_COLOR_ATTACHMENT0 + maxColorAttachments 69 | = Just . ColorAttachment . fromIntegral $ x - GL_COLOR_ATTACHMENT0 70 | | otherwise = Nothing 71 | 72 | fboaToBufferMode :: FramebufferObjectAttachment -> Maybe BufferMode 73 | fboaToBufferMode (ColorAttachment i) = Just . FBOColorAttachment $ fromIntegral i 74 | fboaToBufferMode _ = Nothing 75 | 76 | fboaFromBufferMode :: BufferMode -> Maybe FramebufferObjectAttachment 77 | fboaFromBufferMode (FBOColorAttachment i) = Just . ColorAttachment $ fromIntegral i 78 | fboaFromBufferMode _ = Nothing 79 | 80 | ----------------------------------------------------------------------------- 81 | 82 | class Show a => FramebufferAttachment a where 83 | marshalAttachment :: a -> Maybe GLenum 84 | unmarshalAttachment :: GLenum -> a 85 | unmarshalAttachmentSafe :: GLenum -> Maybe a 86 | 87 | instance FramebufferAttachment FramebufferObjectAttachment where 88 | marshalAttachment = marshalFramebufferObjectAttachment 89 | unmarshalAttachment = unmarshalFramebufferObjectAttachment 90 | unmarshalAttachmentSafe = unmarshalFramebufferObjectAttachmentSafe 91 | 92 | instance FramebufferAttachment BufferMode where 93 | marshalAttachment = marshalBufferMode 94 | unmarshalAttachment = unmarshalBufferMode 95 | unmarshalAttachmentSafe = unmarshalBufferModeSafe 96 | 97 | ----------------------------------------------------------------------------- 98 | 99 | getFBAParameteriv :: FramebufferAttachment fba => FramebufferTarget -> fba 100 | -> (GLint -> a) -> GLenum -> IO a 101 | getFBAParameteriv fbt fba f p = with 0 $ \buf -> do 102 | glGetFramebufferAttachmentParameteriv (marshalFramebufferTarget fbt) 103 | mfba p buf 104 | peek1 f buf 105 | where mfba = fromMaybe (error $ "invalid value" ++ show fba) (marshalAttachment fba) 106 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferObjects.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects 4 | -- Copyright : (c) Sven Panne 2011-2019, Lars Corbijn 2011-2016 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjects ( 14 | FramebufferObject, defaultFramebufferObject, 15 | FramebufferTarget(..), bindFramebuffer, 16 | FramebufferStatus(..), framebufferStatus, 17 | ) where 18 | 19 | import Data.StateVar 20 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObject 21 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget 22 | import Graphics.Rendering.OpenGL.GL.QueryUtils 23 | import Graphics.GL 24 | 25 | ----------------------------------------------------------------------------- 26 | 27 | defaultFramebufferObject :: FramebufferObject 28 | defaultFramebufferObject = FramebufferObject 0 29 | 30 | ----------------------------------------------------------------------------- 31 | 32 | bindFramebuffer :: FramebufferTarget -> StateVar FramebufferObject 33 | bindFramebuffer fbt = 34 | makeStateVar (getBoundFramebuffer fbt) (setFramebuffer fbt) 35 | 36 | marshalFramebufferTargetBinding :: FramebufferTarget -> PName1I 37 | marshalFramebufferTargetBinding x = case x of 38 | DrawFramebuffer -> GetDrawFramebufferBinding 39 | ReadFramebuffer -> GetReadFramebufferBinding 40 | Framebuffer -> GetFramebufferBinding 41 | 42 | getBoundFramebuffer :: FramebufferTarget -> IO FramebufferObject 43 | getBoundFramebuffer = 44 | getInteger1 (FramebufferObject . fromIntegral) . marshalFramebufferTargetBinding 45 | 46 | setFramebuffer :: FramebufferTarget -> FramebufferObject -> IO () 47 | setFramebuffer fbt = 48 | glBindFramebuffer (marshalFramebufferTarget fbt) . framebufferID 49 | 50 | ----------------------------------------------------------------------------- 51 | 52 | data FramebufferStatus = 53 | Complete 54 | | Undefined 55 | | IncompleteMissingAttachment 56 | | IncompleteDrawBuffer 57 | | IncompleteReadBuffer 58 | | IncompleteMultiSample 59 | | Unsupported 60 | deriving ( Eq, Ord, Show ) 61 | 62 | unmarshalFramebufferStatus :: GLenum -> FramebufferStatus 63 | unmarshalFramebufferStatus x 64 | | x == GL_FRAMEBUFFER_COMPLETE = Complete 65 | | x == GL_FRAMEBUFFER_UNDEFINED = Undefined 66 | | x == GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT 67 | = IncompleteMissingAttachment 68 | | x == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = IncompleteDrawBuffer 69 | | x == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = IncompleteReadBuffer 70 | | x == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = IncompleteMultiSample 71 | | x == GL_FRAMEBUFFER_UNSUPPORTED = Unsupported 72 | | otherwise = error $ "unmarshalFramebufferStatus: unknown value: " 73 | ++ show x 74 | 75 | ----------------------------------------------------------------------------- 76 | 77 | framebufferStatus :: FramebufferTarget -> GettableStateVar FramebufferStatus 78 | framebufferStatus t = makeGettableStateVar $ fmap unmarshalFramebufferStatus 79 | . glCheckFramebufferStatus . marshalFramebufferTarget $ t 80 | 81 | ----------------------------------------------------------------------------- 82 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/FramebufferTarget.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget 5 | -- Copyright : (c) Sven Panne 2013-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for marshaling FramebufferTargets. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget ( 17 | FramebufferTarget(..), marshalFramebufferTarget 18 | ) where 19 | 20 | import Graphics.GL 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | data FramebufferTarget = 25 | DrawFramebuffer 26 | | ReadFramebuffer 27 | | Framebuffer 28 | deriving ( Eq, Ord, Show ) 29 | 30 | marshalFramebufferTarget :: FramebufferTarget -> GLenum 31 | marshalFramebufferTarget xs = case xs of 32 | DrawFramebuffer -> GL_DRAW_FRAMEBUFFER 33 | ReadFramebuffer -> GL_READ_FRAMEBUFFER 34 | Framebuffer -> GL_FRAMEBUFFER 35 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/RenderbufferObject.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject 5 | -- Copyright : (c) Sven Panne 2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling RenderBufferObjects. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject ( 17 | RenderbufferObject(..) 18 | ) where 19 | 20 | 21 | import Control.Monad.IO.Class 22 | import Data.ObjectName 23 | import Foreign.Marshal ( allocaArray, peekArray, withArrayLen ) 24 | import Graphics.Rendering.OpenGL.GL.DebugOutput 25 | import Graphics.Rendering.OpenGL.GL.GLboolean 26 | import Graphics.Rendering.OpenGL.GL.QueryUtils 27 | import Graphics.GL 28 | 29 | -------------------------------------------------------------------------------- 30 | 31 | newtype RenderbufferObject = RenderbufferObject { renderbufferID :: GLuint} 32 | deriving ( Eq, Ord, Show ) 33 | 34 | instance ObjectName RenderbufferObject where 35 | isObjectName = 36 | liftIO . fmap unmarshalGLboolean . glIsRenderbuffer . renderbufferID 37 | 38 | deleteObjectNames objs = 39 | liftIO . withArrayLen (map renderbufferID objs) $ 40 | glDeleteRenderbuffers . fromIntegral 41 | 42 | instance GeneratableObjectName RenderbufferObject where 43 | genObjectNames n = 44 | liftIO . allocaArray n $ \buf -> do 45 | glGenRenderbuffers (fromIntegral n) buf 46 | fmap (map RenderbufferObject) $ peekArray n buf 47 | 48 | instance CanBeLabeled RenderbufferObject where 49 | objectLabel = objectNameLabel GL_RENDERBUFFER . renderbufferID 50 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/RenderbufferObjects.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects 4 | -- Copyright : (c) Sven Panne 2011-2019, Lars Corbijn 2011-2016 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObjects ( 14 | RenderbufferObject, 15 | noRenderbufferObject, 16 | RenderbufferTarget(..), 17 | RenderbufferSize(..), Samples(..), 18 | 19 | bindRenderbuffer, 20 | 21 | renderbufferStorage, renderbufferStorageMultiSample, 22 | ) where 23 | 24 | import Data.StateVar 25 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferObject 26 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget 27 | import Graphics.Rendering.OpenGL.GL.QueryUtils 28 | import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat 29 | import Graphics.GL 30 | 31 | ----------------------------------------------------------------------------- 32 | 33 | noRenderbufferObject :: RenderbufferObject 34 | noRenderbufferObject = RenderbufferObject 0 35 | 36 | ----------------------------------------------------------------------------- 37 | 38 | data RenderbufferSize = RenderbufferSize !GLsizei !GLsizei 39 | deriving ( Eq, Ord, Show ) 40 | 41 | ----------------------------------------------------------------------------- 42 | 43 | bindRenderbuffer :: RenderbufferTarget -> StateVar RenderbufferObject 44 | bindRenderbuffer rbt = 45 | makeStateVar (getBoundRenderbuffer rbt) (setRenderbuffer rbt) 46 | 47 | marshalRenderbufferTargetBinding :: RenderbufferTarget -> PName1I 48 | marshalRenderbufferTargetBinding x = case x of 49 | Renderbuffer -> GetRenderbufferBinding 50 | 51 | getBoundRenderbuffer :: RenderbufferTarget -> IO RenderbufferObject 52 | getBoundRenderbuffer = 53 | getInteger1 (RenderbufferObject . fromIntegral) . marshalRenderbufferTargetBinding 54 | 55 | setRenderbuffer :: RenderbufferTarget -> RenderbufferObject -> IO () 56 | setRenderbuffer rbt = glBindRenderbuffer (marshalRenderbufferTarget rbt) 57 | . renderbufferID 58 | 59 | ----------------------------------------------------------------------------- 60 | 61 | renderbufferStorageMultiSample :: RenderbufferTarget -> Samples 62 | -> PixelInternalFormat -> RenderbufferSize -> IO () 63 | renderbufferStorageMultiSample rbt (Samples s) pif (RenderbufferSize w h) = 64 | glRenderbufferStorageMultisample (marshalRenderbufferTarget rbt) s 65 | (marshalPixelInternalFormat' pif) w h 66 | 67 | 68 | renderbufferStorage :: RenderbufferTarget -> PixelInternalFormat 69 | -> RenderbufferSize -> IO () 70 | renderbufferStorage rbt pif (RenderbufferSize w h) = 71 | glRenderbufferStorage (marshalRenderbufferTarget rbt) 72 | (marshalPixelInternalFormat' pif) w h 73 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/FramebufferObjects/RenderbufferTarget.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget 4 | -- Copyright : (c) Sven Panne 2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This is a purely internal module for handling RenderbufferTargets. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget ( 16 | RenderbufferTarget(..), marshalRenderbufferTarget, getRBParameteriv, 17 | Samples(..) 18 | ) where 19 | 20 | import Foreign.Marshal 21 | import Graphics.Rendering.OpenGL.GL.PeekPoke 22 | import Graphics.GL 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | data RenderbufferTarget = Renderbuffer 27 | deriving ( Eq, Ord, Show ) 28 | 29 | marshalRenderbufferTarget :: RenderbufferTarget -> GLenum 30 | marshalRenderbufferTarget x = case x of 31 | Renderbuffer -> GL_RENDERBUFFER 32 | 33 | ----------------------------------------------------------------------------- 34 | 35 | getRBParameteriv :: RenderbufferTarget -> (GLint -> a) -> GLenum -> IO a 36 | getRBParameteriv rbt f p = 37 | with 0 $ \buf -> do 38 | glGetRenderbufferParameteriv (marshalRenderbufferTarget rbt) p buf 39 | peek1 f buf 40 | ----------------------------------------------------------------------------- 41 | 42 | newtype Samples = Samples GLsizei 43 | deriving ( Eq, Ord, Show ) 44 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/GLboolean.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.GLboolean 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling GLboolean. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.GLboolean ( 17 | marshalGLboolean, unmarshalGLboolean 18 | ) where 19 | 20 | import Graphics.GL 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | marshalGLboolean :: Num a => Bool -> a 25 | marshalGLboolean x = fromIntegral $ case x of 26 | False -> GL_FALSE 27 | True -> GL_TRUE 28 | 29 | unmarshalGLboolean :: (Eq a, Num a) => a -> Bool 30 | unmarshalGLboolean = (/= fromIntegral GL_FALSE) 31 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Hints.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Hints 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 5.6 (Hints) of the OpenGL 2.1 specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.Hints ( 16 | HintTarget(..), HintMode(..), hint 17 | ) where 18 | 19 | import Data.StateVar 20 | import Graphics.Rendering.OpenGL.GL.QueryUtils 21 | import Graphics.GL 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | data HintTarget = 26 | PerspectiveCorrection 27 | | PointSmooth 28 | | LineSmooth 29 | | PolygonSmooth 30 | | Fog 31 | | GenerateMipmap 32 | | TextureCompression 33 | | PackCMYK 34 | | UnpackCMYK 35 | deriving ( Eq, Ord, Show ) 36 | 37 | marshalHintTarget :: HintTarget -> GLenum 38 | marshalHintTarget x = case x of 39 | PerspectiveCorrection -> GL_PERSPECTIVE_CORRECTION_HINT 40 | PointSmooth -> GL_POINT_SMOOTH_HINT 41 | LineSmooth -> GL_LINE_SMOOTH_HINT 42 | PolygonSmooth -> GL_POLYGON_SMOOTH_HINT 43 | Fog -> GL_FOG_HINT 44 | GenerateMipmap -> GL_GENERATE_MIPMAP_HINT 45 | TextureCompression -> GL_TEXTURE_COMPRESSION_HINT 46 | PackCMYK -> GL_PACK_CMYK_HINT_EXT 47 | UnpackCMYK -> GL_UNPACK_CMYK_HINT_EXT 48 | 49 | hintTargetToGetPName :: HintTarget -> PName1I 50 | hintTargetToGetPName x = case x of 51 | PerspectiveCorrection -> GetPerspectiveCorrectionHint 52 | PointSmooth -> GetPointSmoothHint 53 | LineSmooth -> GetLineSmoothHint 54 | PolygonSmooth -> GetPolygonSmoothHint 55 | Fog -> GetFogHint 56 | GenerateMipmap -> GetGenerateMipmapHint 57 | TextureCompression -> GetTextureCompressionHint 58 | PackCMYK -> GetPackCMYKHint 59 | UnpackCMYK -> GetUnpackCMYKHint 60 | 61 | -------------------------------------------------------------------------------- 62 | 63 | data HintMode = 64 | DontCare 65 | | Fastest 66 | | Nicest 67 | deriving ( Eq, Ord, Show ) 68 | 69 | marshalHintMode :: HintMode -> GLenum 70 | marshalHintMode x = case x of 71 | DontCare -> GL_DONT_CARE 72 | Fastest -> GL_FASTEST 73 | Nicest -> GL_NICEST 74 | 75 | unmarshalHintMode :: GLenum -> HintMode 76 | unmarshalHintMode x 77 | | x == GL_DONT_CARE = DontCare 78 | | x == GL_FASTEST = Fastest 79 | | x == GL_NICEST = Nicest 80 | | otherwise = error ("unmarshalHintMode: illegal value " ++ show x) 81 | 82 | -------------------------------------------------------------------------------- 83 | 84 | hint :: HintTarget -> StateVar HintMode 85 | hint t = 86 | makeStateVar 87 | (getEnum1 unmarshalHintMode (hintTargetToGetPName t)) 88 | (glHint (marshalHintTarget t) . marshalHintMode) 89 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/IOState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Graphics.Rendering.OpenGL.GL.IOState 6 | -- Copyright : (c) Sven Panne 2002-2019 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : Sven Panne 10 | -- Stability : stable 11 | -- Portability : portable 12 | -- 13 | -- This is a purely internal module for an IO monad with a pointer as an 14 | -- additional state, basically a /StateT (Ptr s) IO a/. 15 | -- 16 | -------------------------------------------------------------------------------- 17 | 18 | module Graphics.Rendering.OpenGL.GL.IOState ( 19 | IOState(..), getIOState, peekIOState, evalIOState, nTimes 20 | ) where 21 | 22 | #if !MIN_VERSION_base(4,8,0) 23 | import Control.Applicative ( Applicative(..) ) 24 | #endif 25 | import Control.Monad ( ap, liftM, replicateM ) 26 | import Foreign.Ptr ( Ptr, plusPtr ) 27 | import Foreign.Storable ( Storable(sizeOf,peek) ) 28 | 29 | -------------------------------------------------------------------------------- 30 | 31 | newtype IOState s a = IOState { runIOState :: Ptr s -> IO (a, Ptr s) } 32 | 33 | instance Applicative (IOState s) where 34 | pure = return 35 | (<*>) = ap 36 | 37 | instance Functor (IOState s) where 38 | fmap = liftM 39 | 40 | instance Monad (IOState s) where 41 | return a = IOState $ \s -> return (a, s) 42 | m >>= k = IOState $ \s -> do (a, s') <- runIOState m s ; runIOState (k a) s' 43 | #if MIN_VERSION_base(4,13,0) 44 | instance MonadFail (IOState s) where 45 | #endif 46 | fail str = IOState $ \_ -> fail str 47 | 48 | getIOState :: IOState s (Ptr s) 49 | getIOState = IOState $ \s -> return (s, s) 50 | 51 | putIOState :: Ptr s -> IOState s () 52 | putIOState s = IOState $ \_ -> return ((), s) 53 | 54 | peekIOState :: Storable a => IOState a a 55 | peekIOState = do 56 | ptr <- getIOState 57 | x <- liftIOState $ peek ptr 58 | putIOState (ptr `plusPtr` sizeOf x) 59 | return x 60 | 61 | liftIOState :: IO a -> IOState s a 62 | liftIOState m = IOState $ \s -> do a <- m ; return (a, s) 63 | 64 | evalIOState :: IOState s a -> Ptr s -> IO a 65 | evalIOState m s = do (a, _) <- runIOState m s ; return a 66 | 67 | nTimes :: Integral a => a -> IOState b c -> IOState b [c] 68 | nTimes n = replicateM (fromIntegral n) 69 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/MatrixComponent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Graphics.Rendering.OpenGL.GL.CoordTrans 6 | -- Copyright : (c) Sven Panne 2002-2019 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : Sven Panne 10 | -- Stability : stable 11 | -- Portability : portable 12 | -- 13 | -- This is a purely internal module for handling matrix components. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Graphics.Rendering.OpenGL.GL.MatrixComponent where 18 | 19 | import Foreign.Ptr 20 | import Foreign.Storable 21 | import Graphics.Rendering.OpenGL.GL.QueryUtils 22 | import Graphics.Rendering.OpenGL.GL.Tensor 23 | import Graphics.GL 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | class Storable c => MatrixComponent c where 28 | getMatrix :: GetPNameMatrix p => p -> Ptr c -> IO () 29 | loadMatrix :: Ptr c -> IO () 30 | loadTransposeMatrix :: Ptr c -> IO () 31 | multMatrix_ :: Ptr c -> IO () 32 | multTransposeMatrix :: Ptr c -> IO () 33 | getUniformv :: GLuint -> GLint -> Ptr c -> IO () 34 | uniformMatrix4v :: GLint -> GLsizei -> GLboolean -> Ptr c -> IO () 35 | rotate :: c -> Vector3 c -> IO () 36 | translate :: Vector3 c -> IO () 37 | scale :: c -> c -> c -> IO () 38 | 39 | instance MatrixComponent GLfloat where 40 | getMatrix = getMatrixf 41 | loadMatrix = glLoadMatrixf 42 | loadTransposeMatrix = glLoadTransposeMatrixf 43 | multMatrix_ = glMultMatrixf 44 | multTransposeMatrix = glMultTransposeMatrixf 45 | getUniformv = glGetUniformfv 46 | uniformMatrix4v = glUniformMatrix4fv 47 | rotate a (Vector3 x y z) = glRotatef a x y z 48 | translate (Vector3 x y z) = glTranslatef x y z 49 | scale = glScalef 50 | 51 | instance MatrixComponent GLdouble where 52 | getMatrix = getMatrixd 53 | loadMatrix = glLoadMatrixd 54 | loadTransposeMatrix = glLoadTransposeMatrixd 55 | multMatrix_ = glMultMatrixd 56 | multTransposeMatrix = glMultTransposeMatrixd 57 | getUniformv = glGetUniformdv 58 | uniformMatrix4v = glUniformMatrix4dv 59 | rotate a (Vector3 x y z) = glRotated a x y z 60 | translate (Vector3 x y z) = glTranslated x y z 61 | scale = glScaled 62 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PeekPoke.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PeekPoke 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module with peek- and poke-related utilities. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PeekPoke ( 17 | poke1, poke2, poke3, poke4, 18 | peek1, peek2, peek3, peek4, 19 | peek1M, peek2M, peek3M, peek4M 20 | ) where 21 | 22 | import Foreign.Ptr 23 | import Foreign.Storable 24 | 25 | -------------------------------------------------------------------------------- 26 | -- The implementation is little bit verbose/redundant, but seems to generate 27 | -- better code than mapM/zipWithM_. 28 | 29 | -------------------------------------------------------------------------------- 30 | 31 | {-# INLINE poke1 #-} 32 | poke1 :: Storable a => Ptr a -> a -> IO () 33 | poke1 ptr x = 34 | pokeElemOff ptr 0 x 35 | 36 | {-# INLINE poke2 #-} 37 | poke2 :: Storable a => Ptr a -> a -> a -> IO () 38 | poke2 ptr x y = do 39 | pokeElemOff ptr 0 x 40 | pokeElemOff ptr 1 y 41 | 42 | {-# INLINE poke3 #-} 43 | poke3 :: Storable a => Ptr a -> a -> a -> a -> IO () 44 | poke3 ptr x y z = do 45 | pokeElemOff ptr 0 x 46 | pokeElemOff ptr 1 y 47 | pokeElemOff ptr 2 z 48 | 49 | {-# INLINE poke4 #-} 50 | poke4 :: Storable a => Ptr a -> a -> a -> a -> a -> IO () 51 | poke4 ptr x y z w = do 52 | pokeElemOff ptr 0 x 53 | pokeElemOff ptr 1 y 54 | pokeElemOff ptr 2 z 55 | pokeElemOff ptr 3 w 56 | 57 | -------------------------------------------------------------------------------- 58 | 59 | {-# INLINE peek1 #-} 60 | peek1 :: Storable a => (a -> b) -> Ptr a -> IO b 61 | peek1 f ptr = do 62 | x <- peekElemOff ptr 0 63 | return $ f x 64 | 65 | {-# INLINE peek2 #-} 66 | peek2 :: Storable a => (a -> a -> b) -> Ptr a -> IO b 67 | peek2 f = peek2M $ \x y -> return (f x y) 68 | 69 | {-# INLINE peek3 #-} 70 | peek3 :: Storable a => (a -> a -> a -> b) -> Ptr a -> IO b 71 | peek3 f = peek3M $ \x y z -> return (f x y z) 72 | 73 | {-# INLINE peek4 #-} 74 | peek4 :: Storable a => (a -> a -> a -> a -> b) -> Ptr a -> IO b 75 | peek4 f = peek4M $ \x y z w -> return (f x y z w) 76 | 77 | -------------------------------------------------------------------------------- 78 | 79 | {-# INLINE peek1M #-} 80 | peek1M :: Storable a => (a -> IO b) -> Ptr a -> IO b 81 | peek1M f ptr = do 82 | x <- peekElemOff ptr 0 83 | f x 84 | 85 | {-# INLINE peek2M #-} 86 | peek2M :: Storable a => (a -> a -> IO b) -> Ptr a -> IO b 87 | peek2M f ptr = do 88 | x <- peekElemOff ptr 0 89 | y <- peekElemOff ptr 1 90 | f x y 91 | 92 | {-# INLINE peek3M #-} 93 | peek3M :: Storable a => (a -> a -> a -> IO b) -> Ptr a -> IO b 94 | peek3M f ptr = do 95 | x <- peekElemOff ptr 0 96 | y <- peekElemOff ptr 1 97 | z <- peekElemOff ptr 2 98 | f x y z 99 | 100 | {-# INLINE peek4M #-} 101 | peek4M :: Storable a => (a -> a -> a -> a -> IO b) -> Ptr a -> IO b 102 | peek4M f ptr = do 103 | x <- peekElemOff ptr 0 104 | y <- peekElemOff ptr 1 105 | z <- peekElemOff ptr 2 106 | w <- peekElemOff ptr 3 107 | f x y z w 108 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelData.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PixelData 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal helper module. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelData ( 17 | PixelData(..), withPixelData 18 | ) where 19 | 20 | import Foreign.Ptr 21 | import Graphics.Rendering.OpenGL.GL.DataType 22 | import Graphics.Rendering.OpenGL.GL.PixelFormat 23 | import Graphics.GL 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | data PixelData a = PixelData PixelFormat DataType (Ptr a) 28 | deriving ( Eq, Ord, Show ) 29 | 30 | withPixelData :: PixelData a -> (GLenum -> GLenum -> Ptr a -> b) -> b 31 | withPixelData (PixelData pixelFormat dataType ptr) f = 32 | f (marshalPixelFormat pixelFormat) (marshalDataType dataType) ptr 33 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelFormat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PixelFormat 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling PixelFormat. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelFormat ( 17 | PixelFormat(..), marshalPixelFormat, unmarshalPixelFormat 18 | ) where 19 | 20 | import Graphics.GL 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | data PixelFormat = 25 | ColorIndex 26 | | StencilIndex 27 | | DepthComponent 28 | | DepthStencil 29 | | Red 30 | | Green 31 | | Blue 32 | | Alpha 33 | | RG 34 | | RGB 35 | | RGBA 36 | | Luminance 37 | | LuminanceAlpha 38 | | RedInteger 39 | | GreenInteger 40 | | BlueInteger 41 | | AlphaInteger 42 | | RGInteger 43 | | RGBInteger 44 | | RGBAInteger 45 | | BGRInteger 46 | | BGRAInteger 47 | | ABGR 48 | | BGR 49 | | BGRA 50 | | CMYK 51 | | CMYKA 52 | | FourTwoTwo 53 | | FourTwoTwoRev 54 | | FourTwoTwoAverage 55 | | FourTwoTwoRevAverage 56 | | YCBCR422 57 | deriving ( Eq, Ord, Show ) 58 | 59 | marshalPixelFormat :: PixelFormat -> GLenum 60 | marshalPixelFormat x = case x of 61 | ColorIndex -> GL_COLOR_INDEX 62 | StencilIndex -> GL_STENCIL_INDEX 63 | DepthComponent -> GL_DEPTH_COMPONENT 64 | Red -> GL_RED 65 | Green -> GL_GREEN 66 | Blue -> GL_BLUE 67 | Alpha -> GL_ALPHA 68 | RG -> GL_RG 69 | RGB -> GL_RGB 70 | RGBA -> GL_RGBA 71 | Luminance -> GL_LUMINANCE 72 | LuminanceAlpha -> GL_LUMINANCE_ALPHA 73 | RedInteger -> GL_RED_INTEGER 74 | GreenInteger -> GL_GREEN_INTEGER 75 | BlueInteger -> GL_BLUE_INTEGER 76 | AlphaInteger -> GL_ALPHA_INTEGER 77 | RGInteger -> GL_RG_INTEGER 78 | RGBInteger -> GL_RGB_INTEGER 79 | RGBAInteger -> GL_RGBA_INTEGER 80 | BGRInteger -> GL_BGR_INTEGER 81 | BGRAInteger -> GL_BGRA_INTEGER 82 | ABGR -> GL_ABGR_EXT 83 | BGR -> GL_BGR 84 | BGRA -> GL_BGRA 85 | CMYK -> GL_CMYK_EXT 86 | CMYKA -> GL_CMYKA_EXT 87 | FourTwoTwo -> GL_422_EXT 88 | FourTwoTwoRev -> GL_422_REV_EXT 89 | FourTwoTwoAverage -> GL_422_AVERAGE_EXT 90 | FourTwoTwoRevAverage -> GL_422_REV_AVERAGE_EXT 91 | YCBCR422 -> GL_YCBCR_422_APPLE 92 | DepthStencil -> GL_DEPTH_STENCIL 93 | 94 | unmarshalPixelFormat :: GLenum -> PixelFormat 95 | unmarshalPixelFormat x 96 | | x == GL_COLOR_INDEX = ColorIndex 97 | | x == GL_STENCIL_INDEX = StencilIndex 98 | | x == GL_DEPTH_COMPONENT = DepthComponent 99 | | x == GL_RED = Red 100 | | x == GL_GREEN = Green 101 | | x == GL_BLUE = Blue 102 | | x == GL_ALPHA = Alpha 103 | | x == GL_RG = RG 104 | | x == GL_RGB = RGB 105 | | x == GL_RGBA = RGBA 106 | | x == GL_LUMINANCE = Luminance 107 | | x == GL_LUMINANCE_ALPHA = LuminanceAlpha 108 | | x == GL_RED_INTEGER = RedInteger 109 | | x == GL_GREEN_INTEGER = GreenInteger 110 | | x == GL_BLUE_INTEGER = BlueInteger 111 | | x == GL_ALPHA_INTEGER = AlphaInteger 112 | | x == GL_RG_INTEGER = RGInteger 113 | | x == GL_RGB_INTEGER = RGBInteger 114 | | x == GL_RGBA_INTEGER = RGBAInteger 115 | | x == GL_BGR_INTEGER = BGRInteger 116 | | x == GL_BGRA_INTEGER = BGRAInteger 117 | | x == GL_ABGR_EXT = ABGR 118 | | x == GL_BGR = BGR 119 | | x == GL_BGRA = BGRA 120 | | x == GL_CMYK_EXT = CMYK 121 | | x == GL_CMYKA_EXT = CMYKA 122 | | x == GL_422_EXT = FourTwoTwo 123 | | x == GL_422_REV_EXT = FourTwoTwoRev 124 | | x == GL_422_AVERAGE_EXT = FourTwoTwoAverage 125 | | x == GL_422_REV_AVERAGE_EXT = FourTwoTwoRevAverage 126 | | x == GL_YCBCR_422_APPLE = YCBCR422 127 | | x == GL_DEPTH_STENCIL = DepthStencil 128 | | otherwise = error ("unmarshalPixelFormat: illegal value " ++ show x) 129 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelRectangles.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.6 (Pixel Rectangles) of the OpenGL 2.1 12 | -- specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelRectangles ( 17 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage, 18 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer, 19 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap, 20 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable, 21 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution, 22 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram, 23 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax, 24 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization 25 | ) where 26 | 27 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage 28 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer 29 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap 30 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable 31 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution 32 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram 33 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax 34 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization 35 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Histogram.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of 12 | -- the OpenGL 2.1 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram ( 17 | Sink(..), histogram, Reset(..), getHistogram, resetHistogram, 18 | histogramRGBASizes, histogramLuminanceSize 19 | ) where 20 | 21 | import Data.StateVar 22 | import Foreign.Marshal.Utils 23 | import Graphics.Rendering.OpenGL.GL.Capability 24 | import Graphics.Rendering.OpenGL.GL.PeekPoke 25 | import Graphics.Rendering.OpenGL.GL.PixelData 26 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable 27 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset 28 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink 29 | import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat 30 | import Graphics.Rendering.OpenGL.GL.VertexSpec 31 | import Graphics.GL 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | data HistogramTarget = 36 | Histogram 37 | | ProxyHistogram 38 | 39 | marshalHistogramTarget :: HistogramTarget -> GLenum 40 | marshalHistogramTarget x = case x of 41 | Histogram -> GL_HISTOGRAM 42 | ProxyHistogram -> GL_PROXY_HISTOGRAM 43 | 44 | proxyToHistogramTarget :: Proxy -> HistogramTarget 45 | proxyToHistogramTarget x = case x of 46 | NoProxy -> Histogram 47 | Proxy -> ProxyHistogram 48 | 49 | -------------------------------------------------------------------------------- 50 | 51 | histogram :: Proxy -> StateVar (Maybe (GLsizei, PixelInternalFormat, Sink)) 52 | histogram proxy = 53 | makeStateVarMaybe 54 | (return CapHistogram) (getHistogram' proxy) (setHistogram proxy) 55 | 56 | getHistogram' :: Proxy -> IO (GLsizei, PixelInternalFormat, Sink) 57 | getHistogram' proxy = do 58 | w <- getHistogramParameteri fromIntegral proxy HistogramWidth 59 | f <- getHistogramParameteri unmarshalPixelInternalFormat proxy HistogramFormat 60 | s <- getHistogramParameteri unmarshalSink proxy HistogramSink 61 | return (w, f, s) 62 | 63 | getHistogramParameteri :: 64 | (GLint -> a) -> Proxy -> GetHistogramParameterPName -> IO a 65 | getHistogramParameteri f proxy p = 66 | with 0 $ \buf -> do 67 | glGetHistogramParameteriv 68 | (marshalHistogramTarget (proxyToHistogramTarget proxy)) 69 | (marshalGetHistogramParameterPName p) 70 | buf 71 | peek1 f buf 72 | 73 | setHistogram :: Proxy -> (GLsizei, PixelInternalFormat, Sink) -> IO () 74 | setHistogram proxy (w, int, sink) = 75 | glHistogram 76 | (marshalHistogramTarget (proxyToHistogramTarget proxy)) 77 | w 78 | (marshalPixelInternalFormat' int) 79 | (marshalSink sink) 80 | 81 | -------------------------------------------------------------------------------- 82 | 83 | getHistogram :: Reset -> PixelData a -> IO () 84 | getHistogram reset pd = 85 | withPixelData pd $ 86 | glGetHistogram 87 | (marshalHistogramTarget Histogram) 88 | (marshalReset reset) 89 | 90 | -------------------------------------------------------------------------------- 91 | 92 | resetHistogram :: IO () 93 | resetHistogram = glResetHistogram (marshalHistogramTarget Histogram) 94 | 95 | -------------------------------------------------------------------------------- 96 | 97 | data GetHistogramParameterPName = 98 | HistogramWidth 99 | | HistogramFormat 100 | | HistogramRedSize 101 | | HistogramGreenSize 102 | | HistogramBlueSize 103 | | HistogramAlphaSize 104 | | HistogramLuminanceSize 105 | | HistogramSink 106 | 107 | marshalGetHistogramParameterPName :: GetHistogramParameterPName -> GLenum 108 | marshalGetHistogramParameterPName x = case x of 109 | HistogramWidth -> GL_HISTOGRAM_WIDTH 110 | HistogramFormat -> GL_HISTOGRAM_FORMAT 111 | HistogramRedSize -> GL_HISTOGRAM_RED_SIZE 112 | HistogramGreenSize -> GL_HISTOGRAM_GREEN_SIZE 113 | HistogramBlueSize -> GL_HISTOGRAM_BLUE_SIZE 114 | HistogramAlphaSize -> GL_HISTOGRAM_ALPHA_SIZE 115 | HistogramLuminanceSize -> GL_HISTOGRAM_LUMINANCE_SIZE 116 | HistogramSink -> GL_HISTOGRAM_SINK 117 | 118 | -------------------------------------------------------------------------------- 119 | 120 | histogramRGBASizes :: Proxy -> GettableStateVar (Color4 GLsizei) 121 | histogramRGBASizes proxy = 122 | makeGettableStateVar $ do 123 | r <- getHistogramParameteri fromIntegral proxy HistogramRedSize 124 | g <- getHistogramParameteri fromIntegral proxy HistogramGreenSize 125 | b <- getHistogramParameteri fromIntegral proxy HistogramBlueSize 126 | a <- getHistogramParameteri fromIntegral proxy HistogramAlphaSize 127 | return $ Color4 r g b a 128 | 129 | histogramLuminanceSize :: Proxy -> GettableStateVar GLsizei 130 | histogramLuminanceSize proxy = 131 | makeGettableStateVar $ 132 | getHistogramParameteri fromIntegral proxy HistogramLuminanceSize 133 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Minmax.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to a part of section 3.6.1 (Pixel Storage Modes) of 12 | -- the OpenGL 2.1 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax ( 17 | minmax, getMinmax, resetMinmax 18 | ) where 19 | 20 | import Data.StateVar 21 | import Foreign.Marshal.Utils 22 | import Graphics.Rendering.OpenGL.GL.Capability 23 | import Graphics.Rendering.OpenGL.GL.PeekPoke 24 | import Graphics.Rendering.OpenGL.GL.PixelData 25 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset 26 | import Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink 27 | import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat 28 | import Graphics.GL 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | data MinmaxTarget = 33 | Minmax 34 | 35 | marshalMinmaxTarget :: MinmaxTarget -> GLenum 36 | marshalMinmaxTarget x = case x of 37 | Minmax -> GL_MINMAX 38 | 39 | -------------------------------------------------------------------------------- 40 | 41 | minmax :: StateVar (Maybe (PixelInternalFormat, Sink)) 42 | minmax = makeStateVarMaybe (return CapMinmax) getMinmax' setMinmax 43 | 44 | getMinmax' :: IO (PixelInternalFormat, Sink) 45 | getMinmax' = do 46 | f <- getMinmaxParameteri unmarshalPixelInternalFormat MinmaxFormat 47 | s <- getMinmaxParameteri unmarshalSink MinmaxSink 48 | return (f, s) 49 | 50 | setMinmax :: (PixelInternalFormat, Sink) -> IO () 51 | setMinmax (int, sink) = 52 | glMinmax 53 | (marshalMinmaxTarget Minmax) 54 | (marshalPixelInternalFormat' int) 55 | (marshalSink sink) 56 | 57 | -------------------------------------------------------------------------------- 58 | 59 | getMinmax :: Reset -> PixelData a -> IO () 60 | getMinmax reset pd = 61 | withPixelData pd $ 62 | glGetMinmax (marshalMinmaxTarget Minmax) (marshalReset reset) 63 | 64 | -------------------------------------------------------------------------------- 65 | 66 | resetMinmax :: IO () 67 | resetMinmax = glResetMinmax (marshalMinmaxTarget Minmax) 68 | 69 | -------------------------------------------------------------------------------- 70 | 71 | data GetMinmaxParameterPName = 72 | MinmaxFormat 73 | | MinmaxSink 74 | 75 | marshalGetMinmaxParameterPName :: GetMinmaxParameterPName -> GLenum 76 | marshalGetMinmaxParameterPName x = case x of 77 | MinmaxFormat -> GL_MINMAX_FORMAT 78 | MinmaxSink -> GL_MINMAX_SINK 79 | 80 | -------------------------------------------------------------------------------- 81 | 82 | getMinmaxParameteri :: (GLint -> a) -> GetMinmaxParameterPName -> IO a 83 | getMinmaxParameteri f p = 84 | with 0 $ \buf -> do 85 | glGetMinmaxParameteriv 86 | (marshalMinmaxTarget Minmax) 87 | (marshalGetMinmaxParameterPName p) 88 | buf 89 | peek1 f buf 90 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelRectangles/PixelStorage.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.6.1 (Pixel Storage Modes) of the 12 | -- OpenGL 2.1 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage ( 17 | PixelStoreDirection(..), swapBytes, lsbFirst, rowLength, skipRows, 18 | skipPixels, rowAlignment, imageHeight, skipImages 19 | ) where 20 | 21 | import Data.StateVar 22 | import Graphics.Rendering.OpenGL.GL.GLboolean 23 | import Graphics.Rendering.OpenGL.GL.QueryUtils 24 | import Graphics.GL 25 | 26 | -------------------------------------------------------------------------------- 27 | 28 | data PixelStoreDirection = 29 | Pack 30 | | Unpack 31 | deriving ( Eq, Ord, Show ) 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | data PixelStore = 36 | UnpackSwapBytes 37 | | UnpackLSBFirst 38 | | UnpackRowLength 39 | | UnpackSkipRows 40 | | UnpackSkipPixels 41 | | UnpackAlignment 42 | | PackSwapBytes 43 | | PackLSBFirst 44 | | PackRowLength 45 | | PackSkipRows 46 | | PackSkipPixels 47 | | PackAlignment 48 | | PackSkipImages 49 | | PackImageHeight 50 | | UnpackSkipImages 51 | | UnpackImageHeight 52 | 53 | marshalPixelStore :: PixelStore -> GLenum 54 | marshalPixelStore x = case x of 55 | UnpackSwapBytes -> GL_UNPACK_SWAP_BYTES 56 | UnpackLSBFirst -> GL_UNPACK_LSB_FIRST 57 | UnpackRowLength -> GL_UNPACK_ROW_LENGTH 58 | UnpackSkipRows -> GL_UNPACK_SKIP_ROWS 59 | UnpackSkipPixels -> GL_UNPACK_SKIP_PIXELS 60 | UnpackAlignment -> GL_UNPACK_ALIGNMENT 61 | PackSwapBytes -> GL_PACK_SWAP_BYTES 62 | PackLSBFirst -> GL_PACK_LSB_FIRST 63 | PackRowLength -> GL_PACK_ROW_LENGTH 64 | PackSkipRows -> GL_PACK_SKIP_ROWS 65 | PackSkipPixels -> GL_PACK_SKIP_PIXELS 66 | PackAlignment -> GL_PACK_ALIGNMENT 67 | PackSkipImages -> GL_PACK_SKIP_IMAGES 68 | PackImageHeight -> GL_PACK_IMAGE_HEIGHT 69 | UnpackSkipImages -> GL_UNPACK_SKIP_IMAGES 70 | UnpackImageHeight -> GL_UNPACK_IMAGE_HEIGHT 71 | 72 | -------------------------------------------------------------------------------- 73 | 74 | swapBytes :: PixelStoreDirection -> StateVar Bool 75 | swapBytes Pack = pixelStoreb GetPackSwapBytes PackSwapBytes 76 | swapBytes Unpack = pixelStoreb GetUnpackSwapBytes UnpackSwapBytes 77 | 78 | lsbFirst :: PixelStoreDirection -> StateVar Bool 79 | lsbFirst Pack = pixelStoreb GetPackLSBFirst PackLSBFirst 80 | lsbFirst Unpack = pixelStoreb GetUnpackLSBFirst UnpackLSBFirst 81 | 82 | rowLength :: PixelStoreDirection -> StateVar GLint 83 | rowLength Pack = pixelStorei GetPackRowLength PackRowLength 84 | rowLength Unpack = pixelStorei GetUnpackRowLength UnpackRowLength 85 | 86 | skipRows :: PixelStoreDirection -> StateVar GLint 87 | skipRows Pack = pixelStorei GetPackSkipRows PackSkipRows 88 | skipRows Unpack = pixelStorei GetUnpackSkipRows UnpackSkipRows 89 | 90 | skipPixels :: PixelStoreDirection -> StateVar GLint 91 | skipPixels Pack = pixelStorei GetPackSkipPixels PackSkipPixels 92 | skipPixels Unpack = pixelStorei GetUnpackSkipPixels UnpackSkipPixels 93 | 94 | rowAlignment :: PixelStoreDirection -> StateVar GLint 95 | rowAlignment Pack = pixelStorei GetPackAlignment PackAlignment 96 | rowAlignment Unpack = pixelStorei GetUnpackAlignment UnpackAlignment 97 | 98 | imageHeight :: PixelStoreDirection -> StateVar GLint 99 | imageHeight Pack = pixelStorei GetPackImageHeight PackImageHeight 100 | imageHeight Unpack = pixelStorei GetUnpackImageHeight UnpackImageHeight 101 | 102 | skipImages :: PixelStoreDirection -> StateVar GLint 103 | skipImages Pack = pixelStorei GetPackSkipImages PackSkipImages 104 | skipImages Unpack = pixelStorei GetUnpackSkipImages UnpackSkipImages 105 | 106 | -------------------------------------------------------------------------------- 107 | 108 | pixelStoreb :: PName1I -> PixelStore -> StateVar Bool 109 | pixelStoreb pn ps = 110 | makeStateVar 111 | (getBoolean1 unmarshalGLboolean pn) 112 | (glPixelStorei (marshalPixelStore ps) . marshalGLboolean) 113 | 114 | pixelStorei :: PName1I -> PixelStore -> StateVar GLint 115 | pixelStorei pn ps = 116 | makeStateVar 117 | (getInteger1 id pn) 118 | (glPixelStorei (marshalPixelStore ps)) 119 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Rasterization.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to a part of section 3.6.4 (Rasterization of Pixel 12 | -- Rectangles) of the OpenGL 2.1 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization ( 17 | PixelData(..), PixelFormat(..), drawPixels, pixelZoom 18 | ) where 19 | 20 | import Control.Monad 21 | import Data.StateVar 22 | import Graphics.Rendering.OpenGL.GL.CoordTrans 23 | import Graphics.Rendering.OpenGL.GL.PixelData 24 | import Graphics.Rendering.OpenGL.GL.PixelFormat 25 | import Graphics.Rendering.OpenGL.GL.QueryUtils 26 | import Graphics.GL 27 | 28 | -------------------------------------------------------------------------------- 29 | 30 | drawPixels :: Size -> PixelData a -> IO () 31 | drawPixels (Size w h) pd = withPixelData pd $ glDrawPixels w h 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | pixelZoom :: StateVar (GLfloat, GLfloat) 36 | pixelZoom = 37 | makeStateVar 38 | (liftM2 (,) (getFloat1 id GetZoomX) (getFloat1 id GetZoomY)) 39 | (uncurry glPixelZoom) 40 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Reset.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling Reset. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Reset ( 17 | Reset(..), marshalReset 18 | ) where 19 | 20 | import Graphics.Rendering.OpenGL.GL.GLboolean 21 | import Graphics.GL 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | data Reset = 26 | NoReset 27 | | Reset 28 | deriving ( Eq, Ord, Show ) 29 | 30 | marshalReset :: Reset -> GLboolean 31 | marshalReset x = marshalGLboolean (x == Reset) 32 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixelRectangles/Sink.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling Sink. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PixelRectangles.Sink ( 17 | Sink(..), marshalSink, unmarshalSink 18 | ) where 19 | 20 | import Graphics.Rendering.OpenGL.GL.GLboolean 21 | import Graphics.GL 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | data Sink = 26 | PassThrough 27 | | Sink 28 | deriving ( Eq, Ord, Show ) 29 | 30 | marshalSink :: Sink -> GLboolean 31 | marshalSink x = marshalGLboolean (x == Sink) 32 | 33 | unmarshalSink :: GLint -> Sink 34 | unmarshalSink s = if unmarshalGLboolean s then Sink else PassThrough 35 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PixellikeObject.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.PixellikeObject 4 | -- Copyright : (c) Sven Panne 2011-2019, Lars Corbijn 2011-2016 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Graphics.Rendering.OpenGL.GL.PixellikeObject ( 14 | PixellikeObjectGetPName(..), 15 | PixellikeObjectTarget(pixellikeObjTarParam), 16 | ) where 17 | 18 | import Data.StateVar 19 | import Foreign.Marshal.Utils 20 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferObjectAttachment 21 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.FramebufferTarget 22 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects.RenderbufferTarget 23 | import Graphics.Rendering.OpenGL.GL.PeekPoke 24 | import Graphics.Rendering.OpenGL.GL.Texturing.Specification 25 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget 26 | import Graphics.GL 27 | 28 | ----------------------------------------------------------------------------- 29 | 30 | data PixellikeObjectGetPName = 31 | RedSize 32 | | BlueSize 33 | | GreenSize 34 | | AlphaSize 35 | | DepthSize 36 | | StencilSize 37 | 38 | class PixellikeObjectTarget t where 39 | --dummy t to include it in the type class 40 | marshalPixellikeOT :: t -> PixellikeObjectGetPName -> GLenum 41 | pixObjTarQueryFunc :: t -> GLenum -> IO GLint 42 | pixellikeObjTarParam :: t -> PixellikeObjectGetPName -> GettableStateVar GLint 43 | pixellikeObjTarParam t p = makeGettableStateVar (pixObjTarQueryFunc t $ marshalPixellikeOT t p) 44 | 45 | instance PixellikeObjectTarget RenderbufferTarget where 46 | marshalPixellikeOT _ x = case x of 47 | RedSize -> GL_RENDERBUFFER_RED_SIZE 48 | BlueSize -> GL_RENDERBUFFER_BLUE_SIZE 49 | GreenSize -> GL_RENDERBUFFER_GREEN_SIZE 50 | AlphaSize -> GL_RENDERBUFFER_ALPHA_SIZE 51 | DepthSize -> GL_RENDERBUFFER_DEPTH_SIZE 52 | StencilSize -> GL_RENDERBUFFER_STENCIL_SIZE 53 | pixObjTarQueryFunc t = getRBParameteriv t id 54 | 55 | data FramebufferTargetAttachment = 56 | FramebufferTargetAttachment FramebufferTarget FramebufferObjectAttachment 57 | 58 | instance PixellikeObjectTarget FramebufferTargetAttachment where 59 | marshalPixellikeOT _ x = case x of 60 | RedSize -> GL_FRAMEBUFFER_ATTACHMENT_RED_SIZE 61 | BlueSize -> GL_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE 62 | GreenSize -> GL_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE 63 | AlphaSize -> GL_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE 64 | DepthSize -> GL_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE 65 | StencilSize -> GL_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE 66 | pixObjTarQueryFunc (FramebufferTargetAttachment fbt fba) = 67 | getFBAParameteriv fbt fba id 68 | 69 | data TextureTargetFull t = TextureTargetFull t Level 70 | 71 | instance QueryableTextureTarget t => PixellikeObjectTarget (TextureTargetFull t) where 72 | marshalPixellikeOT _ x = case x of 73 | RedSize -> GL_TEXTURE_RED_SIZE 74 | BlueSize -> GL_TEXTURE_BLUE_SIZE 75 | GreenSize -> GL_TEXTURE_GREEN_SIZE 76 | AlphaSize -> GL_TEXTURE_ALPHA_SIZE 77 | DepthSize -> GL_TEXTURE_DEPTH_SIZE 78 | StencilSize -> GL_TEXTURE_STENCIL_SIZE 79 | pixObjTarQueryFunc (TextureTargetFull t level) p = 80 | with 0 $ \buf -> do 81 | glGetTexLevelParameteriv (marshalQueryableTextureTarget t) level p buf 82 | peek1 id buf 83 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PointParameter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PointParameter 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for setting point parameters. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PointParameter ( 17 | PointParameter(..), pointParameterf, pointParameterfv 18 | ) where 19 | 20 | import Foreign.Ptr 21 | import Graphics.GL 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | data PointParameter = 26 | PointSizeMin 27 | | PointSizeMax 28 | | PointFadeThresholdSize 29 | | PointDistanceAttenuation 30 | 31 | marshalPointParameter :: PointParameter -> GLenum 32 | marshalPointParameter x = case x of 33 | PointSizeMin -> GL_POINT_SIZE_MIN 34 | PointSizeMax -> GL_POINT_SIZE_MAX 35 | PointFadeThresholdSize -> GL_POINT_FADE_THRESHOLD_SIZE 36 | PointDistanceAttenuation -> GL_POINT_DISTANCE_ATTENUATION 37 | 38 | -------------------------------------------------------------------------------- 39 | 40 | pointParameterf :: PointParameter -> GLfloat -> IO () 41 | pointParameterf = glPointParameterf . marshalPointParameter 42 | 43 | pointParameterfv :: PointParameter -> Ptr GLfloat -> IO () 44 | pointParameterfv = glPointParameterfv . marshalPointParameter 45 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PolygonMode.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PolygonMode 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling PolygonMode. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PolygonMode ( 17 | PolygonMode(..), marshalPolygonMode, unmarshalPolygonMode 18 | ) where 19 | 20 | import Graphics.GL 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | data PolygonMode = 25 | Point 26 | | Line 27 | | Fill 28 | deriving ( Eq, Ord, Show ) 29 | 30 | marshalPolygonMode :: PolygonMode -> GLenum 31 | marshalPolygonMode x = case x of 32 | Point -> GL_POINT 33 | Line -> GL_LINE 34 | Fill -> GL_FILL 35 | 36 | unmarshalPolygonMode :: GLenum -> PolygonMode 37 | unmarshalPolygonMode x 38 | | x == GL_POINT = Point 39 | | x == GL_LINE = Line 40 | | x == GL_FILL = Fill 41 | | otherwise = error ("unmarshalPolygonMode: illegal value " ++ show x) 42 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Polygons.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Polygons 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.5 (Polygons) of the OpenGL 2.1 specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.Polygons ( 16 | polygonSmooth, cullFace, 17 | PolygonStipple(..), GLpolygonstipple, polygonStipple, 18 | PolygonMode(..), polygonMode, polygonOffset, 19 | polygonOffsetPoint, polygonOffsetLine, polygonOffsetFill 20 | ) where 21 | 22 | import Control.Monad 23 | import Data.StateVar 24 | import Foreign.ForeignPtr 25 | import Foreign.Marshal.Array 26 | import Foreign.Ptr 27 | import Graphics.Rendering.OpenGL.GL.Capability 28 | import Graphics.Rendering.OpenGL.GL.Face 29 | import Graphics.Rendering.OpenGL.GL.PixelRectangles 30 | import Graphics.Rendering.OpenGL.GL.PolygonMode 31 | import Graphics.Rendering.OpenGL.GL.QueryUtils 32 | import Graphics.Rendering.OpenGL.GL.SavingState 33 | import Graphics.GL 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | polygonSmooth :: StateVar Capability 38 | polygonSmooth = makeCapability CapPolygonSmooth 39 | 40 | -------------------------------------------------------------------------------- 41 | 42 | cullFace :: StateVar (Maybe Face) 43 | cullFace = makeStateVarMaybe (return CapCullFace) 44 | (getEnum1 unmarshalFace GetCullFaceMode) 45 | (glCullFace . marshalFace) 46 | 47 | -------------------------------------------------------------------------------- 48 | 49 | numPolygonStippleBytes :: Int 50 | numPolygonStippleBytes = 128 -- 32x32 bits divided into GLubytes 51 | 52 | class PolygonStipple s where 53 | withNewPolygonStipple :: (Ptr GLubyte -> IO ()) -> IO s 54 | withPolygonStipple :: s -> (Ptr GLubyte -> IO a) -> IO a 55 | newPolygonStipple :: [GLubyte] -> IO s 56 | getPolygonStippleComponents :: s -> IO [GLubyte] 57 | 58 | withNewPolygonStipple act = 59 | allocaArray numPolygonStippleBytes $ \p -> do 60 | act p 61 | components <- peekArray numPolygonStippleBytes p 62 | newPolygonStipple components 63 | 64 | withPolygonStipple s act = do 65 | components <- getPolygonStippleComponents s 66 | withArray components act 67 | 68 | newPolygonStipple components = 69 | withNewPolygonStipple $ 70 | flip pokeArray (take numPolygonStippleBytes components) 71 | 72 | getPolygonStippleComponents s = 73 | withPolygonStipple s $ peekArray numPolygonStippleBytes 74 | 75 | -------------------------------------------------------------------------------- 76 | 77 | data GLpolygonstipple = GLpolygonstipple (ForeignPtr GLubyte) 78 | deriving ( Eq, Ord, Show ) 79 | 80 | instance PolygonStipple GLpolygonstipple where 81 | withNewPolygonStipple f = do 82 | fp <- mallocForeignPtrArray numPolygonStippleBytes 83 | withForeignPtr fp f 84 | return $ GLpolygonstipple fp 85 | 86 | withPolygonStipple (GLpolygonstipple fp) = withForeignPtr fp 87 | 88 | -------------------------------------------------------------------------------- 89 | 90 | polygonStipple :: PolygonStipple s => StateVar (Maybe s) 91 | polygonStipple = 92 | makeStateVarMaybe (return CapPolygonStipple) 93 | (withoutGaps Pack $ withNewPolygonStipple glGetPolygonStipple) 94 | (\s -> withoutGaps Unpack $ withPolygonStipple s glPolygonStipple) 95 | 96 | -- Note: No need to set rowAlignment, our memory allocator always returns a 97 | -- region which is at least 8-byte aligned (the maximum) 98 | withoutGaps :: PixelStoreDirection -> IO a -> IO a 99 | withoutGaps direction action = 100 | preservingClientAttrib [ PixelStoreAttributes ] $ do 101 | rowLength direction $= 0 102 | skipRows direction $= 0 103 | skipPixels direction $= 0 104 | action 105 | 106 | -------------------------------------------------------------------------------- 107 | 108 | polygonMode :: StateVar (PolygonMode, PolygonMode) 109 | polygonMode = makeStateVar getPolygonMode setPolygonMode 110 | 111 | getPolygonMode :: IO (PolygonMode, PolygonMode) 112 | getPolygonMode = getInteger2 (\front back -> (un front, un back)) GetPolygonMode 113 | where un = unmarshalPolygonMode . fromIntegral 114 | 115 | setPolygonMode :: (PolygonMode, PolygonMode) -> IO () 116 | setPolygonMode (front, back) 117 | -- OpenGL 3 deprecated separate polygon draw modes, so try to avoid them. 118 | | front == back = setPM FrontAndBack front 119 | | otherwise = do setPM Front front; setPM Back back 120 | where setPM f m = glPolygonMode (marshalFace f) (marshalPolygonMode m) 121 | 122 | -------------------------------------------------------------------------------- 123 | 124 | polygonOffset :: StateVar (GLfloat, GLfloat) 125 | polygonOffset = 126 | makeStateVar (liftM2 (,) (getFloat1 id GetPolygonOffsetFactor) 127 | (getFloat1 id GetPolygonOffsetUnits)) 128 | (uncurry glPolygonOffset) 129 | 130 | -------------------------------------------------------------------------------- 131 | 132 | polygonOffsetPoint :: StateVar Capability 133 | polygonOffsetPoint = makeCapability CapPolygonOffsetPoint 134 | 135 | polygonOffsetLine :: StateVar Capability 136 | polygonOffsetLine = makeCapability CapPolygonOffsetLine 137 | 138 | polygonOffsetFill :: StateVar Capability 139 | polygonOffsetFill = makeCapability CapPolygonOffsetFill 140 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/PrimitiveModeInternal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling PrimitiveMode. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal ( 17 | marshalPrimitiveMode, unmarshalPrimitiveMode 18 | ) where 19 | 20 | import Graphics.GL 21 | import Graphics.Rendering.OpenGL.GL.PrimitiveMode 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | marshalPrimitiveMode :: PrimitiveMode -> GLenum 26 | marshalPrimitiveMode x = case x of 27 | Points -> GL_POINTS 28 | Lines -> GL_LINES 29 | LineLoop -> GL_LINE_LOOP 30 | LineStrip -> GL_LINE_STRIP 31 | Triangles -> GL_TRIANGLES 32 | TriangleStrip -> GL_TRIANGLE_STRIP 33 | TriangleFan -> GL_TRIANGLE_FAN 34 | Quads -> GL_QUADS 35 | QuadStrip -> GL_QUAD_STRIP 36 | Polygon -> GL_POLYGON 37 | Patches -> GL_PATCHES 38 | 39 | unmarshalPrimitiveMode :: GLenum -> PrimitiveMode 40 | unmarshalPrimitiveMode x 41 | | x == GL_POINTS = Points 42 | | x == GL_LINES = Lines 43 | | x == GL_LINE_LOOP = LineLoop 44 | | x == GL_LINE_STRIP = LineStrip 45 | | x == GL_TRIANGLES = Triangles 46 | | x == GL_TRIANGLE_STRIP = TriangleStrip 47 | | x == GL_TRIANGLE_FAN = TriangleFan 48 | | x == GL_QUADS = Quads 49 | | x == GL_QUAD_STRIP = QuadStrip 50 | | x == GL_POLYGON = Polygon 51 | | x == GL_PATCHES = Patches 52 | | otherwise = error ("unmarshalPrimitiveMode: illegal value " ++ show x) 53 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/QueryObject.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.QueryObject 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for handling QueryObjects. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.QueryObject ( 17 | QueryObject(..), noQueryObject 18 | ) where 19 | 20 | import Control.Monad.IO.Class 21 | import Data.ObjectName 22 | import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) 23 | import Graphics.Rendering.OpenGL.GL.DebugOutput 24 | import Graphics.Rendering.OpenGL.GL.GLboolean 25 | import Graphics.Rendering.OpenGL.GL.QueryUtils 26 | import Graphics.GL 27 | 28 | -------------------------------------------------------------------------------- 29 | 30 | newtype QueryObject = QueryObject { queryID :: GLuint } 31 | deriving ( Eq, Ord, Show ) 32 | 33 | noQueryObject :: QueryObject 34 | noQueryObject = QueryObject 0 35 | 36 | -------------------------------------------------------------------------------- 37 | 38 | instance ObjectName QueryObject where 39 | isObjectName = liftIO . fmap unmarshalGLboolean . glIsQuery . queryID 40 | 41 | deleteObjectNames queryObjects = 42 | liftIO . withArrayLen (map queryID queryObjects) $ 43 | glDeleteQueries . fromIntegral 44 | 45 | instance GeneratableObjectName QueryObject where 46 | genObjectNames n = 47 | liftIO . allocaArray n $ \buf -> do 48 | glGenQueries (fromIntegral n) buf 49 | fmap (map QueryObject) $ peekArray n buf 50 | 51 | instance CanBeLabeled QueryObject where 52 | objectLabel = objectNameLabel GL_QUERY . queryID 53 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/QueryUtils.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.QueryUtils 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module with utilities to query OpenGL state. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.QueryUtils ( 17 | module Graphics.Rendering.OpenGL.GL.QueryUtils.PName, 18 | module Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib, 19 | 20 | lightIndexToEnum, 21 | modelviewIndexToEnum, modelviewEnumToIndex, 22 | 23 | maybeNullPtr, 24 | 25 | objectNameLabel, objectPtrLabel, maxLabelLength 26 | ) where 27 | 28 | import Data.StateVar 29 | import Foreign.C.String ( peekCStringLen, withCStringLen ) 30 | import Foreign.Ptr ( Ptr, nullPtr ) 31 | import Foreign.Marshal.Alloc ( alloca ) 32 | import Foreign.Marshal.Array ( allocaArray ) 33 | import Graphics.Rendering.OpenGL.GL.PeekPoke 34 | import Graphics.Rendering.OpenGL.GL.QueryUtils.PName 35 | import Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib 36 | import Graphics.GL 37 | 38 | -------------------------------------------------------------------------------- 39 | 40 | -- 0x4000 through 0x4FFF are reserved for light numbers 41 | 42 | lightIndexToEnum :: GLsizei -> Maybe GLenum 43 | lightIndexToEnum i 44 | | 0 <= i && i <= maxLightIndex = Just (GL_LIGHT0 + fromIntegral i) 45 | | otherwise = Nothing 46 | 47 | maxLightIndex :: GLsizei 48 | maxLightIndex = 0xFFF 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | -- 0x1700, 0x850a, and 0x8722 through 0x873f are reserved for modelview matrices 53 | 54 | modelviewIndexToEnum :: GLsizei -> Maybe GLenum 55 | modelviewIndexToEnum 0 = Just GL_MODELVIEW 56 | modelviewIndexToEnum 1 = Just GL_MODELVIEW1_ARB 57 | modelviewIndexToEnum i 58 | | 2 <= i && i <= 31 = Just (GL_MODELVIEW2_ARB - 2 + fromIntegral i) 59 | | otherwise = Nothing 60 | 61 | modelviewEnumToIndex :: GLenum -> Maybe GLsizei 62 | modelviewEnumToIndex x 63 | | x == GL_MODELVIEW = Just 0 64 | | x == GL_MODELVIEW1_ARB = Just 1 65 | | GL_MODELVIEW2_ARB <= x && x <= GL_MODELVIEW31_ARB = Just (fromIntegral (x - (GL_MODELVIEW2_ARB - 2))) 66 | | otherwise = Nothing 67 | 68 | -------------------------------------------------------------------------------- 69 | 70 | maybeNullPtr :: b -> (Ptr a -> b) -> Ptr a -> b 71 | maybeNullPtr n f ptr | ptr == nullPtr = n 72 | | otherwise = f ptr 73 | 74 | -------------------------------------------------------------------------------- 75 | 76 | objectNameLabel :: GLuint -> GLenum -> StateVar (Maybe String) 77 | objectNameLabel name ident = 78 | makeStateVar 79 | (getObjectLabelWith (glGetObjectLabel ident name)) 80 | (setObjectLabelWith (glObjectLabel ident name)) 81 | 82 | objectPtrLabel :: Ptr () -> StateVar (Maybe String) 83 | objectPtrLabel ptr = 84 | makeStateVar 85 | (getObjectLabelWith (glGetObjectPtrLabel ptr)) 86 | (setObjectLabelWith (glObjectPtrLabel ptr)) 87 | 88 | getObjectLabelWith :: (GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()) 89 | -> IO (Maybe String) 90 | getObjectLabelWith getLabel = do 91 | maxLen <- get maxLabelLength 92 | alloca $ \lenBuf -> 93 | allocaArray (fromIntegral maxLen) $ \labelBuf -> do 94 | getLabel maxLen lenBuf labelBuf 95 | actualLen <- peek1 fromIntegral lenBuf 96 | label <- peekCStringLen (labelBuf, actualLen) 97 | return $ if label == "" then Nothing else Just label 98 | 99 | setObjectLabelWith :: (GLsizei -> Ptr GLchar -> IO ()) -> Maybe String -> IO () 100 | setObjectLabelWith setLabel = 101 | maybe (set (nullPtr, (0 :: Int))) (flip withCStringLen set) 102 | where set (labelBuf, len) = setLabel (fromIntegral len) labelBuf 103 | 104 | maxLabelLength :: GettableStateVar GLsizei 105 | maxLabelLength = 106 | makeGettableStateVar (getSizei1 id GetMaxLabelLength) 107 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/QueryUtils/VertexAttrib.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib 5 | -- Copyright : (c) Sven Panne 2009-2019, Lars Corbijn 2009-2016 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne , Jason Dagit 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | module Graphics.Rendering.OpenGL.GL.QueryUtils.VertexAttrib ( 15 | AttribLocation(..), GetVertexAttribPName(..), 16 | getVertexAttribInteger1, getVertexAttribEnum1, getVertexAttribBoolean1, 17 | getVertexAttribFloat4, getVertexAttribIInteger4, getVertexAttribIuInteger4, 18 | GetVertexAttribPointerPName(..), getVertexAttribPointer 19 | ) where 20 | 21 | import Foreign.Marshal.Alloc 22 | import Foreign.Marshal.Utils 23 | import Foreign.Ptr 24 | import Foreign.Storable 25 | import Graphics.Rendering.OpenGL.GL.PeekPoke 26 | import Graphics.GL 27 | 28 | -------------------------------------------------------------------------------- 29 | 30 | newtype AttribLocation = AttribLocation GLuint 31 | deriving ( Eq, Ord, Show ) 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | data GetVertexAttribPName = 36 | GetVertexAttribArrayEnabled 37 | | GetVertexAttribArraySize 38 | | GetVertexAttribArrayStride 39 | | GetVertexAttribArrayType 40 | | GetVertexAttribArrayNormalized 41 | | GetCurrentVertexAttrib 42 | | GetVertexAttribArrayBufferBinding 43 | | GetVertexAttribArrayInteger 44 | 45 | marshalGetVertexAttribPName :: GetVertexAttribPName -> GLenum 46 | marshalGetVertexAttribPName x = case x of 47 | GetVertexAttribArrayEnabled -> GL_VERTEX_ATTRIB_ARRAY_ENABLED 48 | GetVertexAttribArraySize -> GL_VERTEX_ATTRIB_ARRAY_SIZE 49 | GetVertexAttribArrayStride -> GL_VERTEX_ATTRIB_ARRAY_STRIDE 50 | GetVertexAttribArrayType -> GL_VERTEX_ATTRIB_ARRAY_TYPE 51 | GetVertexAttribArrayNormalized -> GL_VERTEX_ATTRIB_ARRAY_NORMALIZED 52 | GetCurrentVertexAttrib -> GL_CURRENT_VERTEX_ATTRIB 53 | GetVertexAttribArrayBufferBinding -> GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING 54 | GetVertexAttribArrayInteger -> GL_VERTEX_ATTRIB_ARRAY_INTEGER 55 | 56 | -------------------------------------------------------------------------------- 57 | 58 | getVertexAttribInteger1 :: (GLint -> b) -> AttribLocation -> GetVertexAttribPName -> IO b 59 | getVertexAttribInteger1 f (AttribLocation location) n = with 0 $ \buf -> do 60 | glGetVertexAttribiv location (marshalGetVertexAttribPName n) buf 61 | peek1 f buf 62 | 63 | getVertexAttribEnum1 :: (GLenum -> b) -> AttribLocation -> GetVertexAttribPName -> IO b 64 | getVertexAttribEnum1 f = getVertexAttribInteger1 (f . fromIntegral) 65 | 66 | getVertexAttribBoolean1 :: (GLboolean -> b) -> AttribLocation -> GetVertexAttribPName -> IO b 67 | getVertexAttribBoolean1 f = getVertexAttribInteger1 (f . fromIntegral) 68 | 69 | getVertexAttribFloat4 :: (GLfloat -> GLfloat -> GLfloat -> GLfloat -> b) -> AttribLocation -> GetVertexAttribPName -> IO b 70 | getVertexAttribFloat4 f (AttribLocation location) n = alloca $ \buf -> do 71 | glGetVertexAttribfv location (marshalGetVertexAttribPName n) buf 72 | peek4 f buf 73 | 74 | getVertexAttribIInteger4 :: (GLint -> GLint -> GLint -> GLint -> b) -> AttribLocation -> GetVertexAttribPName -> IO b 75 | getVertexAttribIInteger4 f (AttribLocation location) n = alloca $ \buf -> do 76 | glGetVertexAttribIiv location (marshalGetVertexAttribPName n) buf 77 | peek4 f buf 78 | 79 | getVertexAttribIuInteger4 :: (GLuint -> GLuint -> GLuint -> GLuint -> b) -> AttribLocation -> GetVertexAttribPName -> IO b 80 | getVertexAttribIuInteger4 f (AttribLocation location) n = alloca $ \buf -> do 81 | glGetVertexAttribIuiv location (marshalGetVertexAttribPName n) buf 82 | peek4 f buf 83 | 84 | -------------------------------------------------------------------------------- 85 | 86 | data GetVertexAttribPointerPName = 87 | VertexAttribArrayPointer 88 | 89 | marshalGetVertexAttribPointerPName :: GetVertexAttribPointerPName -> GLenum 90 | marshalGetVertexAttribPointerPName x = case x of 91 | VertexAttribArrayPointer -> GL_VERTEX_ATTRIB_ARRAY_POINTER 92 | 93 | -------------------------------------------------------------------------------- 94 | 95 | getVertexAttribPointer :: AttribLocation -> GetVertexAttribPointerPName -> IO (Ptr a) 96 | getVertexAttribPointer (AttribLocation location) n = with nullPtr $ \buf -> do 97 | glGetVertexAttribPointerv location (marshalGetVertexAttribPointerPName n) buf 98 | peek buf 99 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/ReadCopyPixels.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.ReadCopyPixels 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 4.3 (Drawing, Reading, and Copying Pixels) 12 | -- of the OpenGL 2.1 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.ReadCopyPixels ( 17 | -- * Reading Pixels 18 | readPixels, readBuffer, 19 | 20 | -- * Copying Pixels 21 | PixelCopyType(..), copyPixels, 22 | 23 | -- * Copying Pixels for framebuffers 24 | BlitBuffer(..), blitFramebuffer 25 | ) where 26 | 27 | import Data.StateVar 28 | import Graphics.Rendering.OpenGL.GL.BufferMode 29 | import Graphics.Rendering.OpenGL.GL.CoordTrans 30 | import Graphics.Rendering.OpenGL.GL.PixelData 31 | import Graphics.Rendering.OpenGL.GL.QueryUtils 32 | import Graphics.Rendering.OpenGL.GL.Texturing.Filter 33 | import Graphics.Rendering.OpenGL.GLU.ErrorsInternal 34 | import Graphics.GL 35 | 36 | -------------------------------------------------------------------------------- 37 | 38 | readPixels :: Position -> Size -> PixelData a -> IO () 39 | readPixels (Position x y) (Size w h) pd = 40 | withPixelData pd $ glReadPixels x y w h 41 | 42 | -------------------------------------------------------------------------------- 43 | 44 | readBuffer :: StateVar BufferMode 45 | readBuffer = 46 | makeStateVar 47 | (getEnum1 unmarshalBufferMode GetReadBuffer) 48 | (maybe recordInvalidValue glReadBuffer . marshalBufferMode) 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | data PixelCopyType = 53 | CopyColor 54 | | CopyDepth 55 | | CopyStencil 56 | deriving ( Eq, Ord, Show ) 57 | 58 | marshalPixelCopyType :: PixelCopyType -> GLenum 59 | marshalPixelCopyType x = case x of 60 | CopyColor -> GL_COLOR 61 | CopyDepth -> GL_DEPTH 62 | CopyStencil -> GL_STENCIL 63 | 64 | -------------------------------------------------------------------------------- 65 | 66 | copyPixels :: Position -> Size -> PixelCopyType -> IO () 67 | copyPixels (Position x y) (Size w h) t = 68 | glCopyPixels x y w h (marshalPixelCopyType t) 69 | 70 | -------------------------------------------------------------------------------- 71 | 72 | -- | The buffers which can be copied with 'blitFramebuffer'. 73 | 74 | data BlitBuffer = 75 | ColorBuffer' 76 | | StencilBuffer' 77 | | DepthBuffer' 78 | deriving ( Eq, Ord, Show ) 79 | 80 | marshalBlitBuffer :: BlitBuffer -> GLbitfield 81 | marshalBlitBuffer x = case x of 82 | ColorBuffer' -> GL_COLOR_BUFFER_BIT 83 | StencilBuffer' -> GL_STENCIL_BUFFER_BIT 84 | DepthBuffer' -> GL_DEPTH_BUFFER_BIT 85 | 86 | -------------------------------------------------------------------------------- 87 | 88 | blitFramebuffer :: Position 89 | -> Position 90 | -> Position 91 | -> Position 92 | -> [BlitBuffer] 93 | -> TextureFilter 94 | -> IO () 95 | blitFramebuffer (Position sx0 sy0) 96 | (Position sx1 sy1) 97 | (Position dx0 dy0) 98 | (Position dx1 dy1) 99 | buffers 100 | filt = 101 | glBlitFramebuffer sx0 sy0 sx1 sy1 dx0 dy0 dx1 dy1 102 | (sum (map marshalBlitBuffer buffers)) 103 | (fromIntegral (marshalMagnificationFilter filt)) 104 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Rectangles.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Rectangles 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 10.9 (Rectangles) of the OpenGL 4.4 specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | {-# LANGUAGE TypeSynonymInstances #-} 16 | 17 | module Graphics.Rendering.OpenGL.GL.Rectangles ( 18 | Rect(..) 19 | ) where 20 | 21 | import Foreign.Ptr 22 | import Graphics.Rendering.OpenGL.GL.Tensor 23 | import Graphics.GL 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | -- | 'rect' and 'rectv' support efficient specification of rectangles as two 28 | -- corner points. Each rectangle command takes four arguments, organized either 29 | -- as two consecutive pairs of (/x/, /y/) coordinates, or as two pointers to 30 | -- arrays, each containing an (/x/, /y/) pair. The resulting rectangle is 31 | -- defined in the /z/ = 0 plane. 32 | -- 33 | -- @'rect' ('Vertex2' x1 y1) ('Vertex2' x2, y2)@ is exactly equivalent to the 34 | -- following sequence: 35 | -- 36 | -- @ 37 | -- 'Graphics.Rendering.OpenGL.GL.BeginEnd.renderPrimitive' 'Graphics.Rendering.OpenGL.GL.BeginEnd.Polygon' $ do 38 | -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x1 y1) 39 | -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x2 y1) 40 | -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x2 y2) 41 | -- 'Graphics.Rendering.OpenGL.GL.VertexSpec.vertex' ('Vertex2' x1 y2) 42 | -- @ 43 | -- 44 | -- Note that if the second vertex is above and to the right of the first vertex, 45 | -- the rectangle is constructed with a counterclockwise winding. 46 | 47 | class Rect a where 48 | rect :: Vertex2 a -> Vertex2 a -> IO () 49 | rectv :: Ptr a -> Ptr a -> IO () 50 | 51 | instance Rect GLshort where 52 | rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRects x1 y1 x2 y2 53 | rectv ptr1 ptr2 = glRectsv ptr1 ptr2 54 | 55 | instance Rect GLint where 56 | rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRecti x1 y1 x2 y2 57 | rectv ptr1 ptr2 = glRectiv ptr1 ptr2 58 | 59 | instance Rect GLfloat where 60 | rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRectf x1 y1 x2 y2 61 | rectv ptr1 ptr2 = glRectfv ptr1 ptr2 62 | 63 | instance Rect GLdouble where 64 | rect (Vertex2 x1 y1) (Vertex2 x2 y2) = glRectd x1 y1 x2 y2 65 | rectv ptr1 ptr2 = glRectdv ptr1 ptr2 66 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/RenderMode.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.RenderMode 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module related to the current render mode. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.RenderMode ( 17 | RenderMode(..), withRenderMode, renderMode 18 | ) where 19 | 20 | import Data.StateVar 21 | import Graphics.Rendering.OpenGL.GL.Exception 22 | import Graphics.Rendering.OpenGL.GL.QueryUtils 23 | import Graphics.GL 24 | 25 | -------------------------------------------------------------------------------- 26 | 27 | data RenderMode = 28 | Render 29 | | Feedback 30 | | Select 31 | deriving ( Eq, Ord, Show ) 32 | 33 | marshalRenderMode :: RenderMode -> GLenum 34 | marshalRenderMode x = case x of 35 | Render -> GL_RENDER 36 | Feedback -> GL_FEEDBACK 37 | Select -> GL_SELECT 38 | 39 | unmarshalRenderMode :: GLenum -> RenderMode 40 | unmarshalRenderMode x 41 | | x == GL_RENDER = Render 42 | | x == GL_FEEDBACK = Feedback 43 | | x == GL_SELECT = Select 44 | | otherwise = error ("unmarshalRenderMode: illegal value " ++ show x) 45 | 46 | -------------------------------------------------------------------------------- 47 | 48 | withRenderMode :: RenderMode -> IO a -> IO (a, GLint) 49 | withRenderMode newMode action = do 50 | oldMode <- get renderMode 51 | _ <- setRenderMode newMode 52 | action `finallyRet` setRenderMode oldMode 53 | 54 | setRenderMode :: RenderMode -> IO GLint 55 | setRenderMode = glRenderMode . marshalRenderMode 56 | 57 | -------------------------------------------------------------------------------- 58 | 59 | renderMode :: GettableStateVar RenderMode 60 | renderMode = makeGettableStateVar $ getEnum1 unmarshalRenderMode GetRenderMode 61 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/SavingState.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.SavingState 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 6.1.14 (Saving and Restoring State) of the 12 | -- OpenGL 2.1 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.SavingState ( 17 | ServerAttributeGroup(..), preservingAttrib, 18 | ClientAttributeGroup(..), preservingClientAttrib 19 | ) where 20 | 21 | import Graphics.Rendering.OpenGL.GL.Exception ( bracket_ ) 22 | import Graphics.GL 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | data ServerAttributeGroup = 27 | CurrentAttributes 28 | | PointAttributes 29 | | LineAttributes 30 | | PolygonAttributes 31 | | PolygonStippleAttributes 32 | | PixelModeAttributes 33 | | LightingAttributes 34 | | FogAttributes 35 | | DepthBufferAttributes 36 | | AccumBufferAttributes 37 | | StencilBufferAttributes 38 | | ViewportAttributes 39 | | TransformAttributes 40 | | EnableAttributes 41 | | ColorBufferAttributes 42 | | HintAttributes 43 | | EvalAttributes 44 | | ListAttributes 45 | | TextureAttributes 46 | | ScissorAttributes 47 | | MultisampleAttributes 48 | | AllServerAttributes 49 | deriving ( Eq, Ord, Show ) 50 | 51 | marshalServerAttributeGroup :: ServerAttributeGroup -> GLbitfield 52 | marshalServerAttributeGroup x = case x of 53 | CurrentAttributes -> GL_CURRENT_BIT 54 | PointAttributes -> GL_POINT_BIT 55 | LineAttributes -> GL_LINE_BIT 56 | PolygonAttributes -> GL_POLYGON_BIT 57 | PolygonStippleAttributes -> GL_POLYGON_STIPPLE_BIT 58 | PixelModeAttributes -> GL_PIXEL_MODE_BIT 59 | LightingAttributes -> GL_LIGHTING_BIT 60 | FogAttributes -> GL_FOG_BIT 61 | DepthBufferAttributes -> GL_DEPTH_BUFFER_BIT 62 | AccumBufferAttributes -> GL_ACCUM_BUFFER_BIT 63 | StencilBufferAttributes -> GL_STENCIL_BUFFER_BIT 64 | ViewportAttributes -> GL_VIEWPORT_BIT 65 | TransformAttributes -> GL_TRANSFORM_BIT 66 | EnableAttributes -> GL_ENABLE_BIT 67 | ColorBufferAttributes -> GL_COLOR_BUFFER_BIT 68 | HintAttributes -> GL_HINT_BIT 69 | EvalAttributes -> GL_EVAL_BIT 70 | ListAttributes -> GL_LIST_BIT 71 | TextureAttributes -> GL_TEXTURE_BIT 72 | ScissorAttributes -> GL_SCISSOR_BIT 73 | MultisampleAttributes -> GL_MULTISAMPLE_BIT 74 | AllServerAttributes -> GL_ALL_ATTRIB_BITS 75 | 76 | -------------------------------------------------------------------------------- 77 | 78 | preservingAttrib :: [ServerAttributeGroup] -> IO a -> IO a 79 | preservingAttrib groups = bracket_ (pushAttrib groups) glPopAttrib 80 | 81 | pushAttrib :: [ServerAttributeGroup] -> IO () 82 | pushAttrib = glPushAttrib . sum . map marshalServerAttributeGroup 83 | 84 | -------------------------------------------------------------------------------- 85 | 86 | data ClientAttributeGroup = 87 | PixelStoreAttributes 88 | | VertexArrayAttributes 89 | | AllClientAttributes 90 | deriving ( Eq, Ord, Show ) 91 | 92 | marshalClientAttributeGroup :: ClientAttributeGroup -> GLbitfield 93 | marshalClientAttributeGroup x = case x of 94 | PixelStoreAttributes -> GL_CLIENT_PIXEL_STORE_BIT 95 | VertexArrayAttributes -> GL_CLIENT_VERTEX_ARRAY_BIT 96 | AllClientAttributes -> GL_CLIENT_ALL_ATTRIB_BITS 97 | 98 | -------------------------------------------------------------------------------- 99 | 100 | preservingClientAttrib :: [ClientAttributeGroup] -> IO a -> IO a 101 | preservingClientAttrib groups = 102 | bracket_ (pushClientAttrib groups) glPopClientAttrib 103 | 104 | pushClientAttrib :: [ClientAttributeGroup] -> IO () 105 | pushClientAttrib = glPushClientAttrib . sum . map marshalClientAttributeGroup 106 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Selection.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Selection 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 5.2 (Selection) of the OpenGL 2.1 specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.Selection ( 16 | HitRecord(..), getHitRecords, 17 | Name(..), withName, loadName, maxNameStackDepth, nameStackDepth, 18 | RenderMode(..), renderMode 19 | ) where 20 | 21 | import Data.StateVar 22 | import Foreign.Marshal.Array 23 | import Foreign.Ptr 24 | import Graphics.Rendering.OpenGL.GL.Exception 25 | import Graphics.Rendering.OpenGL.GL.IOState 26 | import Graphics.Rendering.OpenGL.GL.QueryUtils 27 | import Graphics.Rendering.OpenGL.GL.RenderMode 28 | import Graphics.GL 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | data HitRecord = HitRecord GLfloat GLfloat [Name] 33 | deriving ( Eq, Ord, Show ) 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | getHitRecords :: GLsizei -> IO a -> IO (a, Maybe [HitRecord]) 38 | getHitRecords bufSize action = 39 | allocaArray (fromIntegral bufSize) $ \buf -> do 40 | glSelectBuffer bufSize buf 41 | (value, numHits) <- withRenderMode Select $ do 42 | glInitNames 43 | action 44 | hits <- parseSelectionBuffer numHits buf 45 | return (value, hits) 46 | 47 | -------------------------------------------------------------------------------- 48 | 49 | parseSelectionBuffer :: GLint -> Ptr GLuint -> IO (Maybe [HitRecord]) 50 | parseSelectionBuffer numHits buf 51 | | numHits < 0 = return Nothing 52 | | otherwise = fmap Just $ evalIOState (nTimes numHits parseSelectionHit) buf 53 | 54 | type Parser a = IOState GLuint a 55 | 56 | parseSelectionHit :: Parser HitRecord 57 | parseSelectionHit = do 58 | numNames <- parseGLuint 59 | minZ <- parseGLfloat 60 | maxZ <- parseGLfloat 61 | nameStack <- nTimes numNames parseName 62 | return $ HitRecord minZ maxZ nameStack 63 | 64 | parseGLuint :: Parser GLuint 65 | parseGLuint = peekIOState 66 | 67 | parseGLfloat :: Parser GLfloat 68 | parseGLfloat = fmap (\x -> fromIntegral x / 0xffffffff) parseGLuint 69 | 70 | parseName :: Parser Name 71 | parseName = fmap Name parseGLuint 72 | 73 | -------------------------------------------------------------------------------- 74 | 75 | newtype Name = Name GLuint 76 | deriving ( Eq, Ord, Show ) 77 | 78 | withName :: Name -> IO a -> IO a 79 | withName (Name name) = bracket_ (glPushName name) glPopName 80 | 81 | loadName :: Name -> IO () 82 | loadName (Name n) = glLoadName n 83 | 84 | maxNameStackDepth :: GettableStateVar GLsizei 85 | maxNameStackDepth = makeGettableStateVar (getSizei1 id GetMaxNameStackDepth) 86 | 87 | nameStackDepth :: GettableStateVar GLsizei 88 | nameStackDepth = makeGettableStateVar (getSizei1 id GetNameStackDepth) 89 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Shaders.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Shaders 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 7 (Programs and Shaders) of the OpenGL 4.4 12 | -- specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Shaders ( 17 | module Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects, 18 | module Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries, 19 | module Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects, 20 | module Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries, 21 | module Graphics.Rendering.OpenGL.GL.Shaders.Attribs, 22 | module Graphics.Rendering.OpenGL.GL.Shaders.Uniform, 23 | module Graphics.Rendering.OpenGL.GL.Shaders.Limits 24 | ) where 25 | 26 | import Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects 27 | import Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries 28 | import Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects 29 | import Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries 30 | import Graphics.Rendering.OpenGL.GL.Shaders.Attribs 31 | import Graphics.Rendering.OpenGL.GL.Shaders.Uniform 32 | import Graphics.Rendering.OpenGL.GL.Shaders.Limits 33 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Shaders/Attribs.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Attribs 4 | -- Copyright : (c) Sven Panne 2006-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module contains functions related to shader attributes, corresponding 12 | -- to section 2.20.3 of the OpenGL 3.1 spec (Shader Variables). 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Shaders.Attribs ( 17 | attribLocation, VariableType(..), activeAttribs, 18 | ) where 19 | 20 | import Data.StateVar 21 | import Graphics.Rendering.OpenGL.GL.ByteString 22 | import Graphics.Rendering.OpenGL.GL.QueryUtils 23 | import Graphics.Rendering.OpenGL.GL.Shaders.Program 24 | import Graphics.Rendering.OpenGL.GL.Shaders.Variables 25 | import Graphics.GL 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | activeAttributes :: Program -> GettableStateVar GLuint 30 | activeAttributes = programVar1 fromIntegral ActiveAttributes 31 | 32 | activeAttributeMaxLength :: Program -> GettableStateVar GLsizei 33 | activeAttributeMaxLength = programVar1 fromIntegral ActiveAttributeMaxLength 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | attribLocation :: Program -> String -> StateVar AttribLocation 38 | attribLocation program name = 39 | makeStateVar (getAttribLocation program name) 40 | (\location -> bindAttribLocation program location name) 41 | 42 | getAttribLocation :: Program -> String -> IO AttribLocation 43 | getAttribLocation (Program program) name = 44 | fmap (AttribLocation . fromIntegral) $ 45 | withGLstring name $ 46 | glGetAttribLocation program 47 | 48 | bindAttribLocation :: Program -> AttribLocation -> String -> IO () 49 | bindAttribLocation (Program program) (AttribLocation location) name = 50 | withGLstring name $ 51 | glBindAttribLocation program location 52 | 53 | -------------------------------------------------------------------------------- 54 | 55 | activeAttribs :: Program -> GettableStateVar [(GLint,VariableType,String)] 56 | activeAttribs = 57 | activeVars 58 | activeAttributes 59 | activeAttributeMaxLength 60 | glGetActiveAttrib 61 | unmarshalVariableType 62 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Shaders/Limits.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Limits 4 | -- Copyright : (c) Sven Panne 2006-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module contains functions related to shader limits. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.Shaders.Limits ( 16 | maxVertexTextureImageUnits, maxTextureImageUnits, 17 | maxCombinedTextureImageUnits, maxTextureCoords, maxVertexUniformComponents, 18 | maxFragmentUniformComponents, maxVertexAttribs, maxVaryingFloats 19 | ) where 20 | 21 | import Data.StateVar 22 | import Graphics.Rendering.OpenGL.GL.QueryUtils 23 | import Graphics.GL 24 | 25 | ----------------------------------------------------------------------------- 26 | 27 | -- | Contains the number of hardware units that can be used to access texture 28 | -- maps from the vertex processor. The minimum legal value is 0. 29 | 30 | maxVertexTextureImageUnits :: GettableStateVar GLsizei 31 | maxVertexTextureImageUnits = getLimit GetMaxVertexTextureImageUnits 32 | 33 | -- | Contains the total number of hardware units that can be used to access 34 | -- texture maps from the fragment processor. The minimum legal value is 2. 35 | 36 | maxTextureImageUnits :: GettableStateVar GLsizei 37 | maxTextureImageUnits = getLimit GetMaxTextureImageUnits 38 | 39 | -- | Contains the total number of hardware units that can be used to access 40 | -- texture maps from the vertex processor and the fragment processor combined. 41 | -- Note: If the vertex shader and the fragment processing stage access the same 42 | -- texture image unit, then that counts as using two texture image units. The 43 | -- minimum legal value is 2. 44 | 45 | maxCombinedTextureImageUnits :: GettableStateVar GLsizei 46 | maxCombinedTextureImageUnits = getLimit GetMaxCombinedTextureImageUnits 47 | 48 | -- | Contains the number of texture coordinate sets that are available. The 49 | -- minimum legal value is 2. 50 | 51 | maxTextureCoords :: GettableStateVar GLsizei 52 | maxTextureCoords = getLimit GetMaxTextureCoords 53 | 54 | -- | Contains the number of individual components (i.e., floating-point, integer 55 | -- or boolean values) that are available for vertex shader uniform variables. 56 | -- The minimum legal value is 512. 57 | maxVertexUniformComponents :: GettableStateVar GLsizei 58 | maxVertexUniformComponents = getLimit GetMaxVertexUniformComponents 59 | 60 | -- | Contains the number of individual components (i.e., floating-point, integer 61 | -- or boolean values) that are available for fragment shader uniform variables. 62 | -- The minimum legal value is 64. 63 | 64 | maxFragmentUniformComponents :: GettableStateVar GLsizei 65 | maxFragmentUniformComponents = getLimit GetMaxFragmentUniformComponents 66 | 67 | -- | Contains the number of active vertex attributes that are available. The 68 | -- minimum legal value is 16. 69 | 70 | maxVertexAttribs :: GettableStateVar GLsizei 71 | maxVertexAttribs = getLimit GetMaxVertexAttribs 72 | 73 | -- | Contains the number of individual floating-point values available for 74 | -- varying variables. The minimum legal value is 32. 75 | 76 | maxVaryingFloats :: GettableStateVar GLsizei 77 | maxVaryingFloats = getLimit GetMaxVaryingFloats 78 | 79 | getLimit :: PName1I -> GettableStateVar GLsizei 80 | getLimit = makeGettableStateVar . getSizei1 id 81 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Shaders/Program.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Program 5 | -- Copyright : (c) Sven Panne 2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for handling program objects and related 13 | -- queries. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Graphics.Rendering.OpenGL.GL.Shaders.Program ( 18 | Program(..), 19 | GetProgramPName(..), marshalGetProgramPName, 20 | programVar1, programVar3 21 | ) where 22 | 23 | import Control.Monad.IO.Class 24 | import Data.ObjectName 25 | import Data.StateVar 26 | import Foreign.Marshal.Utils ( with ) 27 | import Foreign.Ptr ( Ptr ) 28 | import Graphics.Rendering.OpenGL.GL.DebugOutput 29 | import Graphics.Rendering.OpenGL.GL.GLboolean 30 | import Graphics.Rendering.OpenGL.GL.PeekPoke 31 | import Graphics.Rendering.OpenGL.GL.QueryUtils 32 | import Graphics.GL 33 | 34 | -------------------------------------------------------------------------------- 35 | 36 | newtype Program = Program { programID :: GLuint } 37 | deriving ( Eq, Ord, Show ) 38 | 39 | instance ObjectName Program where 40 | isObjectName = liftIO . fmap unmarshalGLboolean . glIsProgram . programID 41 | deleteObjectName = liftIO . glDeleteProgram . programID 42 | 43 | instance CanBeLabeled Program where 44 | objectLabel = objectNameLabel GL_PROGRAM . programID 45 | 46 | -------------------------------------------------------------------------------- 47 | 48 | data GetProgramPName = 49 | ProgramDeleteStatus 50 | | LinkStatus 51 | | ValidateStatus 52 | | ProgramInfoLogLength 53 | | AttachedShaders 54 | | ActiveAttributes 55 | | ActiveAttributeMaxLength 56 | | ActiveUniforms 57 | | ActiveUniformMaxLength 58 | | TransformFeedbackBufferMode 59 | | TransformFeedbackVaryings 60 | | TransformFeedbackVaryingMaxLength 61 | | ActiveUniformBlocks 62 | | ActiveUniformBlockMaxNameLength 63 | | GeometryVerticesOut 64 | | GeometryInputType 65 | | GeometryOutputType 66 | | GeometryShaderInvocations 67 | | TessControlOutputVertices 68 | | TessGenMode 69 | | TessGenSpacing 70 | | TessGenVertexOrder 71 | | TessGenPointMode 72 | | ComputeWorkGroupSize -- 3 integers! 73 | | ProgramSeparable 74 | | ProgramBinaryRetrievableHint 75 | | ActiveAtomicCounterBuffers 76 | | ProgramBinaryLength 77 | 78 | marshalGetProgramPName :: GetProgramPName -> GLenum 79 | marshalGetProgramPName x = case x of 80 | ProgramDeleteStatus -> GL_DELETE_STATUS 81 | LinkStatus -> GL_LINK_STATUS 82 | ValidateStatus -> GL_VALIDATE_STATUS 83 | ProgramInfoLogLength -> GL_INFO_LOG_LENGTH 84 | AttachedShaders -> GL_ATTACHED_SHADERS 85 | ActiveAttributes -> GL_ACTIVE_ATTRIBUTES 86 | ActiveAttributeMaxLength -> GL_ACTIVE_ATTRIBUTE_MAX_LENGTH 87 | ActiveUniforms -> GL_ACTIVE_UNIFORMS 88 | ActiveUniformMaxLength -> GL_ACTIVE_UNIFORM_MAX_LENGTH 89 | TransformFeedbackBufferMode -> GL_TRANSFORM_FEEDBACK_BUFFER_MODE 90 | TransformFeedbackVaryings -> GL_TRANSFORM_FEEDBACK_VARYINGS 91 | TransformFeedbackVaryingMaxLength -> GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH 92 | ActiveUniformBlocks -> GL_ACTIVE_UNIFORM_BLOCKS 93 | ActiveUniformBlockMaxNameLength -> GL_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH 94 | GeometryVerticesOut -> GL_GEOMETRY_VERTICES_OUT 95 | GeometryInputType -> GL_GEOMETRY_INPUT_TYPE 96 | GeometryOutputType -> GL_GEOMETRY_OUTPUT_TYPE 97 | GeometryShaderInvocations -> GL_GEOMETRY_SHADER_INVOCATIONS 98 | TessControlOutputVertices -> GL_TESS_CONTROL_OUTPUT_VERTICES 99 | TessGenMode -> GL_TESS_GEN_MODE 100 | TessGenSpacing -> GL_TESS_GEN_SPACING 101 | TessGenVertexOrder -> GL_TESS_GEN_VERTEX_ORDER 102 | TessGenPointMode -> GL_TESS_GEN_POINT_MODE 103 | ComputeWorkGroupSize -> GL_COMPUTE_WORK_GROUP_SIZE 104 | ProgramSeparable -> GL_PROGRAM_SEPARABLE 105 | ProgramBinaryRetrievableHint -> GL_PROGRAM_BINARY_RETRIEVABLE_HINT 106 | ActiveAtomicCounterBuffers -> GL_ACTIVE_ATOMIC_COUNTER_BUFFERS 107 | ProgramBinaryLength -> GL_PROGRAM_BINARY_LENGTH 108 | 109 | programVar1 :: (GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a 110 | programVar1 = programVarN . peek1 111 | 112 | programVar3 :: (GLint -> GLint -> GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a 113 | programVar3 = programVarN . peek3 114 | 115 | programVarN :: (Ptr GLint -> IO a) -> GetProgramPName -> Program -> GettableStateVar a 116 | programVarN f p program = 117 | makeGettableStateVar $ 118 | with 0 $ \buf -> do 119 | glGetProgramiv (programID program) (marshalGetProgramPName p) buf 120 | f buf 121 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Shaders/ProgramBinaries.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries 4 | -- Copyright : (c) Sven Panne 2006-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 7.5 (Program Binaries) of the OpenGL 4.4 12 | -- spec. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Shaders.ProgramBinaries ( 17 | ProgramBinaryFormat(..), programBinaryFormats, 18 | ProgramBinary(..), programBinary 19 | ) where 20 | 21 | import Data.StateVar 22 | import Foreign.Marshal.Alloc 23 | import Graphics.Rendering.OpenGL.GL.ByteString 24 | import Graphics.Rendering.OpenGL.GL.PeekPoke 25 | import Graphics.Rendering.OpenGL.GL.QueryUtils 26 | import Graphics.Rendering.OpenGL.GL.Shaders.Program 27 | import Graphics.GL 28 | 29 | -------------------------------------------------------------------------------- 30 | 31 | newtype ProgramBinaryFormat = ProgramBinaryFormat GLenum 32 | deriving ( Eq, Ord, Show ) 33 | 34 | programBinaryFormats :: GettableStateVar [ProgramBinaryFormat] 35 | programBinaryFormats = 36 | makeGettableStateVar $ do 37 | n <- getInteger1 fromIntegral GetNumProgramBinaryFormats 38 | getEnumN ProgramBinaryFormat GetProgramBinaryFormats n 39 | 40 | data ProgramBinary = ProgramBinary ProgramBinaryFormat ByteString 41 | deriving ( Eq, Ord, Show ) 42 | 43 | programBinary :: Program -> StateVar ProgramBinary 44 | programBinary program = 45 | makeStateVar (getProgramBinary program) (setProgramBinary program) 46 | 47 | getProgramBinary :: Program -> IO ProgramBinary 48 | getProgramBinary program = 49 | alloca $ \formatBuf -> do 50 | let getBin = bind4th formatBuf (glGetProgramBinary . programID) 51 | bs <- stringQuery programBinaryLength getBin program 52 | format <- peek1 ProgramBinaryFormat formatBuf 53 | return $ ProgramBinary format bs 54 | 55 | bind4th :: d -> (a -> b -> c -> d -> e) -> (a -> b -> c -> e) 56 | bind4th x = ((.) . (.) . (.)) ($ x) 57 | 58 | setProgramBinary :: Program -> ProgramBinary -> IO () 59 | setProgramBinary program (ProgramBinary (ProgramBinaryFormat format) bs) = do 60 | withByteString bs $ glProgramBinary (programID program) format 61 | 62 | programBinaryLength :: Program -> GettableStateVar GLsizei 63 | programBinaryLength = programVar1 fromIntegral ProgramBinaryLength 64 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Shaders/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.Shader 5 | -- Copyright : (c) Sven Panne 2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for handling shader objects. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Shaders.Shader ( 17 | Shader(..) 18 | ) where 19 | 20 | import Control.Monad.IO.Class 21 | import Data.ObjectName 22 | import Graphics.Rendering.OpenGL.GL.DebugOutput 23 | import Graphics.Rendering.OpenGL.GL.GLboolean 24 | import Graphics.Rendering.OpenGL.GL.QueryUtils 25 | import Graphics.GL 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | newtype Shader = Shader { shaderID :: GLuint } 30 | deriving ( Eq, Ord, Show ) 31 | 32 | instance ObjectName Shader where 33 | isObjectName = liftIO . fmap unmarshalGLboolean . glIsShader . shaderID 34 | deleteObjectName = liftIO . glDeleteShader . shaderID 35 | 36 | instance CanBeLabeled Shader where 37 | objectLabel = objectNameLabel GL_SHADER . shaderID 38 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Shaders/ShaderBinaries.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries 4 | -- Copyright : (c) Sven Panne 2006-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 7.2 (Shader Binaries) of the OpenGL 4.4 12 | -- spec. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Shaders.ShaderBinaries ( 17 | ShaderBinaryFormat(..), shaderBinaryFormats, 18 | ShaderBinary(..), shaderBinary, 19 | ) where 20 | 21 | import Data.StateVar 22 | import Foreign.Marshal.Array 23 | import Graphics.Rendering.OpenGL.GL.ByteString 24 | import Graphics.Rendering.OpenGL.GL.QueryUtils 25 | import Graphics.Rendering.OpenGL.GL.Shaders.Shader 26 | import Graphics.GL 27 | 28 | -------------------------------------------------------------------------------- 29 | 30 | newtype ShaderBinaryFormat = ShaderBinaryFormat GLenum 31 | deriving ( Eq, Ord, Show ) 32 | 33 | shaderBinaryFormats :: GettableStateVar [ShaderBinaryFormat] 34 | shaderBinaryFormats = 35 | makeGettableStateVar $ do 36 | n <- getInteger1 fromIntegral GetNumShaderBinaryFormats 37 | getEnumN ShaderBinaryFormat GetShaderBinaryFormats n 38 | 39 | data ShaderBinary = ShaderBinary ShaderBinaryFormat ByteString 40 | deriving ( Eq, Ord, Show ) 41 | 42 | shaderBinary :: [Shader] -> SettableStateVar ShaderBinary 43 | shaderBinary shaders = 44 | makeSettableStateVar $ \(ShaderBinary (ShaderBinaryFormat format) bs) -> 45 | withArrayLen (map shaderID shaders) $ \numShaders shadersBuf -> 46 | withByteString bs $ 47 | glShaderBinary (fromIntegral numShaders) shadersBuf format 48 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/StringQueries.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.StringQueries 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This module corresponds to parts of section 6.1.5 (String Queries) of the 13 | -- OpenGL 3.2 specs. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Graphics.Rendering.OpenGL.GL.StringQueries ( 18 | vendor, renderer, glVersion, glExtensions, extensionSupported, 19 | shadingLanguageVersion, majorMinor, ContextProfile'(..), contextProfile 20 | ) where 21 | 22 | import Data.Bits 23 | import Data.Char 24 | #if !MIN_VERSION_base(4,8,0) 25 | import Data.Functor( (<$>), (<$) ) 26 | #endif 27 | import Data.Set ( member, toList ) 28 | import Data.StateVar as S 29 | import Graphics.Rendering.OpenGL.GL.ByteString 30 | import Graphics.Rendering.OpenGL.GL.QueryUtils 31 | import Graphics.GL 32 | import Text.ParserCombinators.ReadP as R 33 | 34 | -------------------------------------------------------------------------------- 35 | 36 | vendor :: GettableStateVar String 37 | vendor = makeStringVar GL_VENDOR 38 | 39 | renderer :: GettableStateVar String 40 | renderer = makeStringVar GL_RENDERER 41 | 42 | glVersion :: GettableStateVar String 43 | glVersion = makeStringVar GL_VERSION 44 | 45 | glExtensions :: GettableStateVar [String] 46 | glExtensions = makeGettableStateVar (toList <$> getExtensions) 47 | 48 | extensionSupported :: String -> GettableStateVar Bool 49 | extensionSupported ext = 50 | makeGettableStateVar (getExtensions >>= (return . member ext)) 51 | 52 | shadingLanguageVersion :: GettableStateVar String 53 | shadingLanguageVersion = makeStringVar GL_SHADING_LANGUAGE_VERSION 54 | 55 | -------------------------------------------------------------------------------- 56 | 57 | data ContextProfile' 58 | = CoreProfile' 59 | | CompatibilityProfile' 60 | deriving ( Eq, Ord, Show ) 61 | 62 | marshalContextProfile' :: ContextProfile' -> GLbitfield 63 | marshalContextProfile' x = case x of 64 | CoreProfile' -> GL_CONTEXT_CORE_PROFILE_BIT 65 | CompatibilityProfile' -> GL_CONTEXT_COMPATIBILITY_PROFILE_BIT 66 | 67 | contextProfile :: GettableStateVar [ContextProfile'] 68 | contextProfile = makeGettableStateVar (getInteger1 i2cps GetContextProfileMask) 69 | 70 | i2cps :: GLint -> [ContextProfile'] 71 | i2cps bitfield = 72 | [ c | c <- [ CoreProfile', CompatibilityProfile' ] 73 | , (fromIntegral bitfield .&. marshalContextProfile' c) /= 0 ] 74 | 75 | -------------------------------------------------------------------------------- 76 | 77 | makeStringVar :: GLenum -> GettableStateVar String 78 | makeStringVar = makeGettableStateVar . getStringWith . glGetString 79 | 80 | -------------------------------------------------------------------------------- 81 | 82 | -- | A utility function to be used with e.g. 'glVersion' or 83 | -- 'shadingLanguageVersion', transforming a variable containing a string of the 84 | -- form /major.minor[optional rest]/ into a variable containing a numeric 85 | -- major\/minor version. If the string is malformed, which should never happen 86 | -- with a sane OpenGL implementation, it is transformed to @(-1,-1)@. 87 | 88 | majorMinor :: GettableStateVar String -> GettableStateVar (Int, Int) 89 | majorMinor = 90 | makeGettableStateVar . (runParser parseVersion (-1, -1) <$>) . S.get 91 | 92 | -------------------------------------------------------------------------------- 93 | -- Copy from Graphics.Rendering.OpenGL.Raw.GetProcAddress... :-/ 94 | 95 | runParser :: ReadP a -> a -> String -> a 96 | runParser parser failed str = 97 | case readP_to_S parser str of 98 | [(v, "")] -> v 99 | _ -> failed 100 | 101 | -- This does quite a bit more than we need for "normal" OpenGL, but at least it 102 | -- documents the convoluted format of the version string in detail. 103 | parseVersion :: ReadP (Int, Int) 104 | parseVersion = do 105 | _prefix <- 106 | -- Too lazy to define a type for the API... 107 | ("CL" <$ string "OpenGL ES-CL ") <++ -- OpenGL ES 1.x Common-Lite 108 | ("CM" <$ string "OpenGL ES-CM ") <++ -- OpenGL ES 1.x Common 109 | ("ES" <$ string "OpenGL ES " ) <++ -- OpenGL ES 2.x or 3.x 110 | ("GL" <$ string "" ) -- OpenGL 111 | major <- read <$> munch1 isDigit 112 | minor <- char '.' >> read <$> munch1 isDigit 113 | _release <- (char '.' >> munch1 (/= ' ')) <++ return "" 114 | _vendorStuff <- (char ' ' >> R.get `manyTill` eof) <++ ("" <$ eof) 115 | return (major, minor) 116 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/SyncObjects.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.SyncObjects 4 | -- Copyright : (c) Sven Panne 2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 4.1 (Sync Objects and Fences) of the 12 | -- OpenGL 4.4 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.SyncObjects ( 17 | -- * Sync Objects and Fences 18 | SyncObject, syncGpuCommandsComplete, 19 | 20 | -- * Waiting for Sync Objects 21 | WaitTimeout, WaitFlag(..), WaitResult(..), clientWaitSync, 22 | waitSync, maxServerWaitTimeout, 23 | 24 | -- * Sync Object Queries 25 | SyncStatus(..), syncStatus 26 | ) where 27 | 28 | import Control.Monad.IO.Class 29 | import Data.ObjectName 30 | import Data.StateVar 31 | import Foreign.Marshal.Utils ( with ) 32 | import Foreign.Ptr ( nullPtr ) 33 | import Graphics.Rendering.OpenGL.GL.DebugOutput 34 | import Graphics.Rendering.OpenGL.GL.GLboolean 35 | import Graphics.Rendering.OpenGL.GL.PeekPoke 36 | import Graphics.Rendering.OpenGL.GL.QueryUtils 37 | import Graphics.GL 38 | 39 | -------------------------------------------------------------------------------- 40 | 41 | newtype SyncObject = SyncObject { syncID :: GLsync } 42 | deriving ( Eq, Ord, Show ) 43 | 44 | instance ObjectName SyncObject where 45 | isObjectName = liftIO . fmap unmarshalGLboolean . glIsSync . syncID 46 | deleteObjectName = liftIO . glDeleteSync . syncID 47 | 48 | instance CanBeLabeled SyncObject where 49 | objectLabel = objectPtrLabel . syncID 50 | 51 | syncGpuCommandsComplete :: IO SyncObject 52 | syncGpuCommandsComplete = 53 | fmap SyncObject $ glFenceSync GL_SYNC_GPU_COMMANDS_COMPLETE 0 54 | 55 | -------------------------------------------------------------------------------- 56 | 57 | type WaitTimeout = GLuint64 58 | 59 | -------------------------------------------------------------------------------- 60 | 61 | data WaitFlag = SyncFlushCommands 62 | deriving ( Eq, Ord, Show ) 63 | 64 | marshalWaitFlag :: WaitFlag -> GLbitfield 65 | marshalWaitFlag x = case x of 66 | SyncFlushCommands -> GL_SYNC_FLUSH_COMMANDS_BIT 67 | 68 | -------------------------------------------------------------------------------- 69 | 70 | data WaitResult = 71 | AlreadySignaled 72 | | TimeoutExpired 73 | | ConditionSatisfied 74 | | WaitFailed 75 | deriving ( Eq, Ord, Show ) 76 | 77 | unmarshalWaitResult :: GLenum -> WaitResult 78 | unmarshalWaitResult x 79 | | x == GL_ALREADY_SIGNALED = AlreadySignaled 80 | | x == GL_TIMEOUT_EXPIRED = TimeoutExpired 81 | | x == GL_CONDITION_SATISFIED = ConditionSatisfied 82 | | x == GL_WAIT_FAILED = WaitFailed 83 | | otherwise = error ("unmarshalWaitResult: illegal value " ++ show x) 84 | 85 | -------------------------------------------------------------------------------- 86 | 87 | clientWaitSync :: SyncObject -> [WaitFlag] -> WaitTimeout -> IO WaitResult 88 | clientWaitSync syncObject flags = 89 | fmap unmarshalWaitResult . 90 | glClientWaitSync (syncID syncObject) (sum (map marshalWaitFlag flags)) 91 | 92 | waitSync :: SyncObject -> IO () 93 | waitSync syncObject = 94 | glWaitSync (syncID syncObject) 0 (fromIntegral GL_TIMEOUT_IGNORED) 95 | 96 | maxServerWaitTimeout :: GettableStateVar WaitTimeout 97 | maxServerWaitTimeout = 98 | makeGettableStateVar (getInteger64 fromIntegral GetMaxServerWaitTimeout) 99 | 100 | -------------------------------------------------------------------------------- 101 | 102 | data SyncStatus = 103 | Unsignaled 104 | | Signaled 105 | deriving ( Eq, Ord, Show ) 106 | 107 | unmarshalSyncStatus :: GLenum -> SyncStatus 108 | unmarshalSyncStatus x 109 | | x == GL_UNSIGNALED = Unsignaled 110 | | x == GL_SIGNALED = Signaled 111 | | otherwise = error ("unmarshalSyncStatus: illegal value " ++ show x) 112 | 113 | syncStatus :: SyncObject -> GettableStateVar SyncStatus 114 | syncStatus syncObject = 115 | makeGettableStateVar $ 116 | with 0 $ \buf -> do 117 | glGetSynciv (syncID syncObject) GL_SYNC_STATUS 1 nullPtr buf 118 | peek1 (unmarshalSyncStatus . fromIntegral) buf 119 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Texturing.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Texturing 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.8 (Texturing) of the OpenGL 2.1 specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GL.Texturing ( 16 | module Graphics.Rendering.OpenGL.GL.Texturing.Specification, 17 | module Graphics.Rendering.OpenGL.GL.Texturing.Parameters, 18 | module Graphics.Rendering.OpenGL.GL.Texturing.Objects, 19 | module Graphics.Rendering.OpenGL.GL.Texturing.Environments, 20 | module Graphics.Rendering.OpenGL.GL.Texturing.Application, 21 | module Graphics.Rendering.OpenGL.GL.Texturing.Queries 22 | ) where 23 | 24 | import Graphics.Rendering.OpenGL.GL.Texturing.Specification 25 | import Graphics.Rendering.OpenGL.GL.Texturing.Parameters 26 | import Graphics.Rendering.OpenGL.GL.Texturing.Objects 27 | import Graphics.Rendering.OpenGL.GL.Texturing.Environments 28 | import Graphics.Rendering.OpenGL.GL.Texturing.Application 29 | import Graphics.Rendering.OpenGL.GL.Texturing.Queries 30 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Texturing/Application.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Application 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.8.15 (Texture Application) of the 12 | -- OpenGL 2.1 specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Texturing.Application ( 17 | texture 18 | ) where 19 | 20 | import Data.StateVar 21 | import Graphics.Rendering.OpenGL.GL.Capability 22 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | texture :: ParameterizedTextureTarget t => t -> StateVar Capability 27 | texture = makeCapability . marshalParameterizedTextureTargetEnableCap 28 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Texturing/Filter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Filter 5 | -- Copyright : (c) Sven Panne 2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling texture filtering modes. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Texturing.Filter ( 17 | TextureFilter(..), 18 | MinificationFilter, marshalMinificationFilter, unmarshalMinificationFilter, 19 | MagnificationFilter, marshalMagnificationFilter, unmarshalMagnificationFilter 20 | ) where 21 | 22 | import Graphics.GL 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | data TextureFilter = 27 | Nearest 28 | | Linear' 29 | deriving ( Eq, Ord, Show ) 30 | 31 | type MinificationFilter = (TextureFilter, Maybe TextureFilter) 32 | 33 | type MagnificationFilter = TextureFilter 34 | 35 | -- We treat MagnificationFilter as a degenerated case of MinificationFilter 36 | magToMin :: MagnificationFilter -> MinificationFilter 37 | magToMin magFilter = (magFilter, Nothing) 38 | 39 | minToMag :: MinificationFilter -> MagnificationFilter 40 | minToMag (magFilter, Nothing) = magFilter 41 | minToMag minFilter = error ("minToMag: illegal value " ++ show minFilter) 42 | 43 | marshalMinificationFilter :: MinificationFilter -> GLint 44 | marshalMinificationFilter x = fromIntegral $ case x of 45 | (Nearest, Nothing ) -> GL_NEAREST 46 | (Linear', Nothing ) -> GL_LINEAR 47 | (Nearest, Just Nearest) -> GL_NEAREST_MIPMAP_NEAREST 48 | (Linear', Just Nearest) -> GL_LINEAR_MIPMAP_NEAREST 49 | (Nearest, Just Linear') -> GL_NEAREST_MIPMAP_LINEAR 50 | (Linear', Just Linear') -> GL_LINEAR_MIPMAP_LINEAR 51 | 52 | marshalMagnificationFilter :: MagnificationFilter -> GLint 53 | marshalMagnificationFilter = marshalMinificationFilter . magToMin 54 | 55 | unmarshalMinificationFilter :: GLint -> MinificationFilter 56 | unmarshalMinificationFilter x 57 | | y == GL_NEAREST = (Nearest, Nothing) 58 | | y == GL_LINEAR = (Linear', Nothing) 59 | | y == GL_NEAREST_MIPMAP_NEAREST = (Nearest, Just Nearest) 60 | | y == GL_LINEAR_MIPMAP_NEAREST = (Linear', Just Nearest) 61 | | y == GL_NEAREST_MIPMAP_LINEAR = (Nearest, Just Linear') 62 | | y == GL_LINEAR_MIPMAP_LINEAR = (Linear', Just Linear') 63 | | otherwise = error ("unmarshalMinificationFilter: illegal value " ++ show x) 64 | where y = fromIntegral x 65 | 66 | unmarshalMagnificationFilter :: GLint -> MagnificationFilter 67 | unmarshalMagnificationFilter = minToMag . unmarshalMinificationFilter 68 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Texturing/Objects.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.Objects 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 3.8.12 (Texture Objects) of the OpenGL 2.1 12 | -- specs. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Texturing.Objects ( 17 | TextureObject(TextureObject), textureBinding, 18 | textureResident, areTexturesResident, 19 | TexturePriority, texturePriority, prioritizeTextures, 20 | generateMipmap' 21 | ) where 22 | 23 | import Data.List 24 | import Data.Maybe (fromMaybe) 25 | import Data.StateVar 26 | import Foreign.Marshal.Array 27 | import Graphics.Rendering.OpenGL.GL.GLboolean 28 | import Graphics.Rendering.OpenGL.GL.QueryUtils 29 | import Graphics.Rendering.OpenGL.GL.Texturing.TexParameter 30 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureObject 31 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget 32 | import Graphics.GL 33 | 34 | -------------------------------------------------------------------------------- 35 | 36 | textureBinding :: BindableTextureTarget t => t -> StateVar (Maybe TextureObject) 37 | textureBinding t = 38 | makeStateVar 39 | (do o <- getEnum1 (TextureObject . fromIntegral) (marshalBindableTextureTargetPName1I t) 40 | return $ if o == defaultTextureObject then Nothing else Just o) 41 | (glBindTexture (marshalBindableTextureTarget t) . textureID . (fromMaybe defaultTextureObject)) 42 | 43 | defaultTextureObject :: TextureObject 44 | defaultTextureObject = TextureObject 0 45 | 46 | -------------------------------------------------------------------------------- 47 | 48 | textureResident :: ParameterizedTextureTarget t => t -> GettableStateVar Bool 49 | textureResident t = 50 | makeGettableStateVar $ 51 | getTexParameteri unmarshalGLboolean t TextureResident 52 | 53 | areTexturesResident :: [TextureObject] -> IO ([TextureObject],[TextureObject]) 54 | areTexturesResident texObjs = do 55 | withArrayLen (map textureID texObjs) $ \len texObjsBuf -> 56 | allocaArray len $ \residentBuf -> do 57 | allResident <- 58 | glAreTexturesResident (fromIntegral len) texObjsBuf residentBuf 59 | if unmarshalGLboolean allResident 60 | then return (texObjs, []) 61 | else do 62 | tr <- fmap (zip texObjs) $ peekArray len residentBuf 63 | let (resident, nonResident) = partition (unmarshalGLboolean . snd) tr 64 | return (map fst resident, map fst nonResident) 65 | 66 | -------------------------------------------------------------------------------- 67 | 68 | type TexturePriority = GLclampf 69 | 70 | texturePriority :: ParameterizedTextureTarget t => t -> StateVar TexturePriority 71 | texturePriority = texParamf realToFrac realToFrac TexturePriority 72 | 73 | prioritizeTextures :: [(TextureObject,TexturePriority)] -> IO () 74 | prioritizeTextures tps = 75 | withArrayLen (map (textureID . fst) tps) $ \len texObjsBuf -> 76 | withArray (map snd tps) $ 77 | glPrioritizeTextures (fromIntegral len) texObjsBuf 78 | 79 | -------------------------------------------------------------------------------- 80 | 81 | -- | Generate mipmaps for the specified texture target. Note that from OpenGL 82 | -- 3.1 onwards you should use this function instead of the texture parameter 83 | -- 'Graphics.Rendering.OpenGL.GL.Texturing.Parameters.generateMipmap'. 84 | 85 | generateMipmap' :: ParameterizedTextureTarget t => t -> IO () 86 | generateMipmap' = glGenerateMipmap . marshalParameterizedTextureTarget 87 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Texturing/TexParameter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.TexParameter 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for getting\/setting texture parameters. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Texturing.TexParameter ( 17 | TexParameter(..), texParami, texParamf, texParamC4f, getTexParameteri 18 | ) where 19 | 20 | import Data.StateVar 21 | import Foreign.Marshal.Alloc 22 | import Foreign.Marshal.Utils 23 | import Foreign.Ptr 24 | import Foreign.Storable 25 | import Graphics.Rendering.OpenGL.GL.PeekPoke 26 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget 27 | import Graphics.Rendering.OpenGL.GL.VertexSpec 28 | import Graphics.GL 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | data TexParameter = 33 | TextureMinFilter 34 | | TextureMagFilter 35 | | TextureWrapS 36 | | TextureWrapT 37 | | TextureWrapR 38 | | TextureBorderColor 39 | | TextureMinLOD 40 | | TextureMaxLOD 41 | | TextureBaseLevel 42 | | TextureMaxLevel 43 | | TexturePriority 44 | | TextureMaxAnisotropy 45 | | TextureCompare 46 | | TextureCompareOperator 47 | | TextureCompareFailValue 48 | | GenerateMipmap 49 | | TextureCompareMode 50 | | TextureCompareFunc 51 | | DepthTextureMode 52 | | TextureLODBias 53 | | TextureResident 54 | 55 | marshalTexParameter :: TexParameter -> GLenum 56 | marshalTexParameter x = case x of 57 | TextureMinFilter -> GL_TEXTURE_MIN_FILTER 58 | TextureMagFilter -> GL_TEXTURE_MAG_FILTER 59 | TextureWrapS -> GL_TEXTURE_WRAP_S 60 | TextureWrapT -> GL_TEXTURE_WRAP_T 61 | TextureWrapR -> GL_TEXTURE_WRAP_R 62 | TextureBorderColor -> GL_TEXTURE_BORDER_COLOR 63 | TextureMinLOD -> GL_TEXTURE_MIN_LOD 64 | TextureMaxLOD -> GL_TEXTURE_MAX_LOD 65 | TextureBaseLevel -> GL_TEXTURE_BASE_LEVEL 66 | TextureMaxLevel -> GL_TEXTURE_MAX_LEVEL 67 | TexturePriority -> GL_TEXTURE_PRIORITY 68 | TextureMaxAnisotropy -> GL_TEXTURE_MAX_ANISOTROPY_EXT 69 | TextureCompare -> GL_TEXTURE_COMPARE_SGIX 70 | TextureCompareOperator -> GL_TEXTURE_COMPARE_OPERATOR_SGIX 71 | TextureCompareFailValue -> GL_TEXTURE_COMPARE_FAIL_VALUE_ARB 72 | GenerateMipmap -> GL_GENERATE_MIPMAP 73 | TextureCompareMode -> GL_TEXTURE_COMPARE_MODE 74 | TextureCompareFunc -> GL_TEXTURE_COMPARE_FUNC 75 | DepthTextureMode -> GL_DEPTH_TEXTURE_MODE 76 | TextureLODBias -> GL_TEXTURE_LOD_BIAS 77 | TextureResident -> GL_TEXTURE_RESIDENT 78 | 79 | -------------------------------------------------------------------------------- 80 | 81 | texParameter :: ParameterizedTextureTarget t 82 | => (GLenum -> GLenum -> b -> IO ()) 83 | -> (a -> (b -> IO ()) -> IO ()) 84 | -> t -> TexParameter -> a -> IO () 85 | texParameter glTexParameter marshalAct t p x = 86 | marshalAct x $ 87 | glTexParameter (marshalParameterizedTextureTarget t) (marshalTexParameter p) 88 | 89 | -------------------------------------------------------------------------------- 90 | 91 | getTexParameter :: (Storable b, ParameterizedTextureTarget t) 92 | => (GLenum -> GLenum -> Ptr b -> IO ()) 93 | -> (b -> a) 94 | -> t -> TexParameter -> IO a 95 | getTexParameter glGetTexParameter unmarshal t p = 96 | alloca $ \buf -> do 97 | glGetTexParameter (marshalParameterizedTextureTarget t) (marshalTexParameter p) buf 98 | peek1 unmarshal buf 99 | 100 | -------------------------------------------------------------------------------- 101 | 102 | m2a :: (a -> b) -> a -> (b -> IO ()) -> IO () 103 | m2a marshal x act = act (marshal x) 104 | 105 | texParami :: ParameterizedTextureTarget t => 106 | (GLint -> a) -> (a -> GLint) -> TexParameter -> t -> StateVar a 107 | texParami unmarshal marshal p t = 108 | makeStateVar 109 | (getTexParameter glGetTexParameteriv unmarshal t p) 110 | (texParameter glTexParameteri (m2a marshal) t p) 111 | 112 | texParamf :: ParameterizedTextureTarget t => 113 | (GLfloat -> a) -> (a -> GLfloat) -> TexParameter -> t -> StateVar a 114 | texParamf unmarshal marshal p t = 115 | makeStateVar 116 | (getTexParameter glGetTexParameterfv unmarshal t p) 117 | (texParameter glTexParameterf (m2a marshal) t p) 118 | 119 | texParamC4f :: ParameterizedTextureTarget t => TexParameter -> t -> StateVar (Color4 GLfloat) 120 | texParamC4f p t = 121 | makeStateVar 122 | (getTexParameter glGetTexParameterC4f id t p) 123 | (texParameter glTexParameterC4f with t p) 124 | 125 | glTexParameterC4f :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () 126 | glTexParameterC4f target pname ptr = glTexParameterfv target pname (castPtr ptr) 127 | 128 | glGetTexParameterC4f :: GLenum -> GLenum -> Ptr (Color4 GLfloat) -> IO () 129 | glGetTexParameterC4f target pname ptr = glGetTexParameterfv target pname (castPtr ptr) 130 | 131 | getTexParameteri :: ParameterizedTextureTarget t => (GLint -> a) -> t -> TexParameter -> IO a 132 | getTexParameteri = getTexParameter glGetTexParameteriv 133 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Texturing/TextureObject.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.TextureObject 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for handling texture objects. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Texturing.TextureObject ( 17 | TextureObject(..) 18 | ) where 19 | 20 | import Control.Monad.IO.Class 21 | import Data.ObjectName 22 | import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) 23 | import Graphics.Rendering.OpenGL.GL.DebugOutput 24 | import Graphics.Rendering.OpenGL.GL.GLboolean 25 | import Graphics.Rendering.OpenGL.GL.QueryUtils 26 | import Graphics.GL 27 | 28 | -------------------------------------------------------------------------------- 29 | 30 | newtype TextureObject = TextureObject { textureID :: GLuint } 31 | deriving ( Eq, Ord, Show ) 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | instance ObjectName TextureObject where 36 | isObjectName = liftIO . fmap unmarshalGLboolean . glIsTexture . textureID 37 | 38 | deleteObjectNames textureObjects = 39 | liftIO . withArrayLen (map textureID textureObjects) $ 40 | glDeleteTextures . fromIntegral 41 | 42 | instance GeneratableObjectName TextureObject where 43 | genObjectNames n = 44 | liftIO . allocaArray n $ \buf -> do 45 | glGenTextures (fromIntegral n) buf 46 | fmap (map TextureObject) $ peekArray n buf 47 | 48 | instance CanBeLabeled TextureObject where 49 | objectLabel = objectNameLabel GL_TEXTURE . textureID 50 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/Texturing/TextureUnit.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit 5 | -- Copyright : (c) Sven Panne 2002-2019 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Sven Panne 9 | -- Stability : stable 10 | -- Portability : portable 11 | -- 12 | -- This is a purely internal module for (un-)marshaling TextureUnit. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit ( 17 | TextureUnit(..), marshalTextureUnit, unmarshalTextureUnit 18 | ) where 19 | 20 | import Foreign.Ptr 21 | import Foreign.Storable 22 | import Graphics.GL 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | -- | Identifies a texture unit via its number, which must be in the range of 27 | -- (0 .. 'maxTextureUnit'). 28 | 29 | newtype TextureUnit = TextureUnit GLuint 30 | deriving ( Eq, Ord, Show ) 31 | 32 | -- Internal note, when setting a sampler (TextureUnit) uniform the GLint 33 | -- functions should be used. 34 | 35 | instance Storable TextureUnit where 36 | sizeOf _ = sizeOf (undefined :: GLuint) 37 | alignment _ = alignment (undefined :: GLuint) 38 | peek pt = peek (castPtr pt) >>= return . TextureUnit 39 | poke pt (TextureUnit tu) = poke (castPtr pt) tu 40 | peekByteOff pt off = peekByteOff pt off >>= return . TextureUnit 41 | pokeByteOff pt off (TextureUnit tu) 42 | = pokeByteOff pt off tu 43 | 44 | 45 | 46 | marshalTextureUnit :: TextureUnit -> GLenum 47 | marshalTextureUnit (TextureUnit x) = GL_TEXTURE0 + fromIntegral x 48 | 49 | unmarshalTextureUnit :: GLenum -> TextureUnit 50 | unmarshalTextureUnit x = TextureUnit (fromIntegral (x - GL_TEXTURE0)) 51 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/TransformFeedback.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.TransformFeedback 4 | -- Copyright : (c) Sven Panne 2011-2019, Lars Corbijn 2011-2016 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Graphics.Rendering.OpenGL.GL.TransformFeedback ( 14 | -- * starting and ending 15 | beginTransformFeedback, endTransformFeedback, 16 | 17 | -- * TransformFeedbackBufferMode 18 | TransformFeedbackBufferMode(..), marshalTransformFeedbackBufferMode, 19 | unmarshalTransformFeedbackBufferMode, 20 | 21 | -- * Shader related 22 | transformFeedbackBufferMode, 23 | transformFeedbackVaryings, 24 | setTransformFeedbackVaryings, 25 | 26 | -- * limits 27 | maxTransformFeedbackSeparateAttribs, 28 | maxTransformFeedbackInterleavedComponents, 29 | maxTransformFeedbackSeparateComponents 30 | ) where 31 | 32 | import Data.StateVar 33 | import Foreign.Marshal.Array 34 | import Graphics.Rendering.OpenGL.GL.ByteString 35 | import Graphics.Rendering.OpenGL.GL.DataType 36 | import Graphics.Rendering.OpenGL.GL.PrimitiveMode 37 | import Graphics.Rendering.OpenGL.GL.PrimitiveModeInternal 38 | import Graphics.Rendering.OpenGL.GL.QueryUtils 39 | import Graphics.Rendering.OpenGL.GL.Shaders.Program 40 | import Graphics.Rendering.OpenGL.GL.Shaders.Variables 41 | import Graphics.GL 42 | 43 | -------------------------------------------------------------------------------- 44 | 45 | beginTransformFeedback :: PrimitiveMode -> IO () 46 | beginTransformFeedback = glBeginTransformFeedback . marshalPrimitiveMode 47 | 48 | endTransformFeedback :: IO () 49 | endTransformFeedback = glEndTransformFeedback 50 | 51 | -------------------------------------------------------------------------------- 52 | 53 | data TransformFeedbackBufferMode = 54 | InterleavedAttribs 55 | | SeparateAttribs 56 | | SeperateAttribs 57 | deriving ( Eq, Ord, Show ) 58 | {-# DEPRECATED SeperateAttribs "Use 'SeparateAttribs' instead." #-} 59 | 60 | marshalTransformFeedbackBufferMode :: TransformFeedbackBufferMode -> GLenum 61 | marshalTransformFeedbackBufferMode x = case x of 62 | InterleavedAttribs -> GL_INTERLEAVED_ATTRIBS 63 | SeparateAttribs -> GL_SEPARATE_ATTRIBS 64 | SeperateAttribs -> GL_SEPARATE_ATTRIBS 65 | 66 | unmarshalTransformFeedbackBufferMode :: GLenum -> TransformFeedbackBufferMode 67 | unmarshalTransformFeedbackBufferMode x 68 | | x == GL_INTERLEAVED_ATTRIBS = InterleavedAttribs 69 | | x == GL_SEPARATE_ATTRIBS = SeparateAttribs 70 | | otherwise = error $ "unmarshalTransformFeedbackBufferMode: illegal value " ++ show x 71 | 72 | -- limits 73 | -- | Max number of seprate atributes or varyings than can be captured 74 | -- in transformfeedback, initial value 4 75 | maxTransformFeedbackSeparateAttribs :: GettableStateVar GLint 76 | maxTransformFeedbackSeparateAttribs = makeGettableStateVar $ 77 | getInteger1 fromIntegral GetMaxTransformFeedbackSeparateAttribs 78 | 79 | -- | Max number of components to write to a single buffer in 80 | -- interleaved mod, initial value 64 81 | maxTransformFeedbackInterleavedComponents :: GettableStateVar GLint 82 | maxTransformFeedbackInterleavedComponents = makeGettableStateVar $ 83 | getInteger1 fromIntegral GetMaxTransformFeedbackInterleavedComponents 84 | 85 | -- | Max number of components per attribute or varying in seperate mode 86 | -- initial value 4 87 | maxTransformFeedbackSeparateComponents :: GettableStateVar GLint 88 | maxTransformFeedbackSeparateComponents = makeGettableStateVar $ 89 | getInteger1 fromIntegral GetMaxTransformFeedbackSeparateComponents 90 | 91 | -------------------------------------------------------------------------------- 92 | 93 | -- | Set all the transform feedbacks varyings for this program 94 | -- it overwrites any previous call to this function 95 | setTransformFeedbackVaryings :: Program -> [String] 96 | -> TransformFeedbackBufferMode -> IO () 97 | setTransformFeedbackVaryings (Program program) sts tfbm = do 98 | ptSts <- mapM (\x -> withGLstring x return) sts 99 | stsPtrs <- newArray ptSts 100 | glTransformFeedbackVaryings program (fromIntegral . length $ sts) stsPtrs 101 | (marshalTransformFeedbackBufferMode tfbm) 102 | 103 | -- | Get the currently used transformFeedbackBufferMode 104 | transformFeedbackBufferMode 105 | :: Program -> GettableStateVar TransformFeedbackBufferMode 106 | transformFeedbackBufferMode = programVar1 107 | (unmarshalTransformFeedbackBufferMode . fromIntegral) 108 | TransformFeedbackBufferMode 109 | 110 | -- | The number of varyings that are currently recorded when in 111 | -- transform feedback mode 112 | numTransformFeedbackVaryings :: Program -> GettableStateVar GLuint 113 | numTransformFeedbackVaryings = 114 | programVar1 fromIntegral TransformFeedbackVaryings 115 | 116 | -- | The maximum length of a varying's name for transform feedback mode 117 | transformFeedbackVaryingMaxLength :: Program -> GettableStateVar GLsizei 118 | transformFeedbackVaryingMaxLength 119 | = programVar1 fromIntegral TransformFeedbackVaryingMaxLength 120 | 121 | -- | The name, datatype and size of the transform feedback varyings. 122 | transformFeedbackVaryings :: Program -> GettableStateVar [(GLint, DataType, String)] 123 | transformFeedbackVaryings = 124 | activeVars 125 | numTransformFeedbackVaryings 126 | transformFeedbackVaryingMaxLength 127 | glGetTransformFeedbackVarying 128 | unmarshalDataType 129 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GL/VertexArrayObjects.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GL.VertexArrayObjects 4 | -- Copyright : (c) Sven Panne 2011-2019, Lars Corbijn 2011-2016 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Graphics.Rendering.OpenGL.GL.VertexArrayObjects ( 14 | VertexArrayObject, 15 | bindVertexArrayObject 16 | ) where 17 | 18 | import Control.Monad.IO.Class 19 | import Data.ObjectName 20 | import Data.StateVar 21 | import Foreign.Marshal.Array ( allocaArray, peekArray, withArrayLen ) 22 | import Graphics.Rendering.OpenGL.GL.DebugOutput 23 | import Graphics.Rendering.OpenGL.GL.GLboolean 24 | import Graphics.Rendering.OpenGL.GL.QueryUtils 25 | import Graphics.GL 26 | 27 | ----------------------------------------------------------------------------- 28 | 29 | newtype VertexArrayObject = VertexArrayObject { vertexArrayID :: GLuint } 30 | deriving( Eq, Ord, Show ) 31 | 32 | instance ObjectName VertexArrayObject where 33 | isObjectName = 34 | liftIO . fmap unmarshalGLboolean . glIsVertexArray . vertexArrayID 35 | 36 | deleteObjectNames bufferObjects = 37 | liftIO . withArrayLen (map vertexArrayID bufferObjects) $ 38 | glDeleteVertexArrays . fromIntegral 39 | 40 | instance GeneratableObjectName VertexArrayObject where 41 | genObjectNames n = liftIO . allocaArray n $ \buf -> do 42 | glGenVertexArrays (fromIntegral n) buf 43 | fmap (map VertexArrayObject) $ peekArray n buf 44 | 45 | instance CanBeLabeled VertexArrayObject where 46 | objectLabel = objectNameLabel GL_VERTEX_ARRAY . vertexArrayID 47 | 48 | bindVertexArrayObject :: StateVar (Maybe VertexArrayObject) 49 | bindVertexArrayObject = makeStateVar getVAO bindVAO 50 | 51 | getVAO :: IO (Maybe VertexArrayObject) 52 | getVAO = do 53 | vao <- getInteger1 (VertexArrayObject . fromIntegral) GetVertexArrayBinding 54 | return $ if vao == noVAO then Nothing else Just vao 55 | 56 | bindVAO :: Maybe VertexArrayObject -> IO () 57 | bindVAO = glBindVertexArray . vertexArrayID . maybe noVAO id 58 | 59 | noVAO :: VertexArrayObject 60 | noVAO = VertexArrayObject 0 61 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GLU.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GLU 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- A Haskell binding for GLU, OpenGL\'s accompanying utility library. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GLU ( 16 | module Graphics.Rendering.OpenGL.GLU.Initialization, 17 | module Graphics.Rendering.OpenGL.GLU.Mipmapping, 18 | module Graphics.Rendering.OpenGL.GLU.Matrix, 19 | module Graphics.Rendering.OpenGL.GLU.Tessellation, 20 | module Graphics.Rendering.OpenGL.GLU.Quadrics, 21 | module Graphics.Rendering.OpenGL.GLU.NURBS, 22 | module Graphics.Rendering.OpenGL.GLU.Errors 23 | ) where 24 | 25 | import Graphics.Rendering.OpenGL.GLU.Initialization 26 | import Graphics.Rendering.OpenGL.GLU.Mipmapping 27 | import Graphics.Rendering.OpenGL.GLU.Matrix 28 | import Graphics.Rendering.OpenGL.GLU.Tessellation 29 | import Graphics.Rendering.OpenGL.GLU.Quadrics 30 | import Graphics.Rendering.OpenGL.GLU.NURBS 31 | import Graphics.Rendering.OpenGL.GLU.Errors 32 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GLU/Errors.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GLU.Errors 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to section 2.5 (GL Errors) of the OpenGL 2.1 specs 12 | -- and chapter 8 (Errors) of the GLU specs, offering a generalized view of 13 | -- errors in GL and GLU. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Graphics.Rendering.OpenGL.GLU.Errors ( 18 | Error(..), ErrorCategory(..), errors 19 | ) where 20 | 21 | import Data.StateVar 22 | import Graphics.Rendering.OpenGL.GLU.ErrorsInternal 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | -- | When an error occurs, it is recorded in this state variable and no further 27 | -- errors are recorded. Reading 'errors' returns the currently recorded errors 28 | -- (there may be more than one due to a possibly distributed implementation) and 29 | -- resets the state variable to @[]@, re-enabling the recording of future 30 | -- errors. The value @[]@ means that there has been no detectable error since 31 | -- the last time 'errors' was read, or since the GL was initialized. 32 | 33 | errors :: GettableStateVar [Error] 34 | errors = makeGettableStateVar getErrors 35 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GLU/Initialization.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GLU.Initialization 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to chapter 2 (Initialization) of the GLU specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GLU.Initialization ( 16 | gluVersion, gluExtensions 17 | ) where 18 | 19 | import Data.StateVar 20 | import Graphics.GLU 21 | import Graphics.Rendering.OpenGL.GL.ByteString 22 | import Graphics.GL 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | gluVersion :: GettableStateVar String 27 | gluVersion = makeGettableStateVar (getString GLU_VERSION) 28 | 29 | gluExtensions :: GettableStateVar [String] 30 | gluExtensions = makeGettableStateVar (fmap words $ getString GLU_EXTENSIONS) 31 | 32 | getString :: GLenum -> IO String 33 | getString = getStringWith . gluGetString 34 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GLU/Matrix.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GLU.Matrix 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to chapter 4 (Matrix Manipulation) of the GLU specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GLU.Matrix ( 16 | ortho2D, perspective, lookAt, pickMatrix, 17 | project, unProject, unProject4 18 | ) where 19 | 20 | import Foreign.Marshal.Alloc 21 | import Foreign.Marshal.Array 22 | import Foreign.Ptr 23 | import Foreign.Storable 24 | import Graphics.GLU 25 | import Graphics.Rendering.OpenGL.GL.CoordTrans 26 | import Graphics.Rendering.OpenGL.GL.GLboolean 27 | import Graphics.Rendering.OpenGL.GL.Tensor 28 | import Graphics.Rendering.OpenGL.GLU.ErrorsInternal 29 | import Graphics.GL 30 | 31 | -------------------------------------------------------------------------------- 32 | -- matrix setup 33 | 34 | ortho2D :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO () 35 | ortho2D = gluOrtho2D 36 | 37 | 38 | perspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO () 39 | perspective = gluPerspective 40 | 41 | lookAt :: Vertex3 GLdouble -> Vertex3 GLdouble -> Vector3 GLdouble -> IO () 42 | lookAt (Vertex3 eyeX eyeY eyeZ) 43 | (Vertex3 centerX centerY centerZ) 44 | (Vector3 upX upY upZ) = 45 | gluLookAt eyeX eyeY eyeZ centerX centerY centerZ upX upY upZ 46 | 47 | pickMatrix :: 48 | (GLdouble, GLdouble) -> (GLdouble, GLdouble) -> (Position, Size) -> IO () 49 | pickMatrix (x, y) (w, h) viewPort = 50 | withViewport viewPort $ gluPickMatrix x y w h 51 | 52 | -------------------------------------------------------------------------------- 53 | -- coordinate projection 54 | 55 | project :: 56 | Matrix m 57 | => Vertex3 GLdouble -> m GLdouble -> m GLdouble -> (Position, Size) 58 | -> IO (Vertex3 GLdouble) 59 | project (Vertex3 objX objY objZ) model proj viewPort = 60 | withColumnMajor model $ \modelBuf -> 61 | withColumnMajor proj $ \projBuf -> 62 | withViewport viewPort $ \viewBuf -> 63 | getVertex3 $ gluProject objX objY objZ modelBuf projBuf viewBuf 64 | 65 | unProject :: 66 | Matrix m 67 | => Vertex3 GLdouble -> m GLdouble -> m GLdouble -> (Position, Size) 68 | -> IO (Vertex3 GLdouble) 69 | unProject (Vertex3 objX objY objZ) model proj viewPort = 70 | withColumnMajor model $ \modelBuf -> 71 | withColumnMajor proj $ \projBuf -> 72 | withViewport viewPort $ \viewBuf -> 73 | getVertex3 $ gluUnProject objX objY objZ modelBuf projBuf viewBuf 74 | 75 | unProject4 :: 76 | Matrix m 77 | => Vertex4 GLdouble -> m GLdouble -> m GLdouble -> (Position, Size) 78 | -> GLclampd -> GLclampd 79 | -> IO (Vertex4 GLdouble) 80 | unProject4 (Vertex4 objX objY objZ clipW) model proj viewPort near far = 81 | withColumnMajor model $ \modelBuf -> 82 | withColumnMajor proj $ \projBuf -> 83 | withViewport viewPort $ \viewBuf -> 84 | getVertex4 $ 85 | gluUnProject4 objX objY objZ clipW modelBuf projBuf viewBuf near far 86 | 87 | -------------------------------------------------------------------------------- 88 | 89 | withViewport :: (Position, Size) -> (Ptr GLint -> IO a ) -> IO a 90 | withViewport (Position x y, Size w h) = 91 | withArray [ x, y, fromIntegral w, fromIntegral h ] 92 | 93 | withColumnMajor :: (Matrix m, MatrixComponent c) => m c -> (Ptr c -> IO b) -> IO b 94 | withColumnMajor mat act = withMatrix mat juggle 95 | where juggle ColumnMajor p = act p 96 | juggle RowMajor p = do 97 | transposedElems <- mapM (peekElemOff p) [ 0, 4, 8, 12, 98 | 1, 5, 9, 13, 99 | 2, 6, 10, 14, 100 | 3, 7, 11, 15 ] 101 | withArray transposedElems act 102 | 103 | getVertex3 :: 104 | (Ptr GLdouble -> Ptr GLdouble -> Ptr GLdouble -> IO GLint) 105 | -> IO (Vertex3 GLdouble) 106 | getVertex3 act = 107 | alloca $ \xBuf -> 108 | alloca $ \yBuf -> 109 | alloca $ \zBuf -> do 110 | ok <- act xBuf yBuf zBuf 111 | if unmarshalGLboolean ok 112 | then do x <- peek xBuf 113 | y <- peek yBuf 114 | z <- peek zBuf 115 | return $ Vertex3 x y z 116 | else do recordInvalidValue 117 | return $ Vertex3 0 0 0 118 | 119 | getVertex4 :: 120 | (Ptr GLdouble -> Ptr GLdouble -> Ptr GLdouble -> Ptr GLdouble -> IO GLint) 121 | -> IO (Vertex4 GLdouble) 122 | getVertex4 act = 123 | alloca $ \xBuf -> 124 | alloca $ \yBuf -> 125 | alloca $ \zBuf -> 126 | alloca $ \wBuf -> do 127 | ok <- act xBuf yBuf zBuf wBuf 128 | if unmarshalGLboolean ok 129 | then do x <- peek xBuf 130 | y <- peek yBuf 131 | z <- peek zBuf 132 | w <- peek wBuf 133 | return $ Vertex4 x y z w 134 | else do recordInvalidValue 135 | return $ Vertex4 0 0 0 0 136 | -------------------------------------------------------------------------------- /src/Graphics/Rendering/OpenGL/GLU/Mipmapping.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Graphics.Rendering.OpenGL.GLU.Mipmapping 4 | -- Copyright : (c) Sven Panne 2002-2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Sven Panne 8 | -- Stability : stable 9 | -- Portability : portable 10 | -- 11 | -- This module corresponds to chapter 3 (Mipmapping) of the GLU specs. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Graphics.Rendering.OpenGL.GLU.Mipmapping ( 16 | scaleImage, build1DMipmaps, build2DMipmaps 17 | ) where 18 | 19 | import Graphics.GLU 20 | import Graphics.Rendering.OpenGL.GL.CoordTrans ( Size(..) ) 21 | import Graphics.Rendering.OpenGL.GL.Texturing.PixelInternalFormat 22 | import Graphics.Rendering.OpenGL.GL.PixelData ( PixelData, withPixelData ) 23 | import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget 24 | import Graphics.Rendering.OpenGL.GLU.ErrorsInternal ( recordInvalidValue ) 25 | import Graphics.GL 26 | 27 | -------------------------------------------------------------------------------- 28 | -- Section 3.1 (Image Scaling) 29 | 30 | scaleImage :: Size -> PixelData a -> Size -> PixelData b -> IO () 31 | scaleImage (Size widthIn heightIn) pdIn (Size widthOut heightOut) pdOut = 32 | withPixelData pdIn $ \fIn dIn pIn -> 33 | withPixelData pdOut $ \fOut dOut pOut -> 34 | if fIn == fOut 35 | then do _ <- gluScaleImage 36 | fIn widthIn heightIn dIn pIn widthOut heightOut dOut pOut 37 | return () -- TODO: Should we use the return value? 38 | else recordInvalidValue 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Section 3.2 (Automatic Mipmapping) 42 | -- Missing for GLU 1.3: gluBuild3DMipmaps, gluBuild{1,2,3}DMipmapLevels 43 | 44 | build1DMipmaps :: 45 | TextureTarget1D -> PixelInternalFormat -> GLsizei -> PixelData a -> IO () 46 | build1DMipmaps target internalFormat height pd = do 47 | _ <- withPixelData pd $ 48 | gluBuild1DMipmaps 49 | (marshalGettableTextureTarget target) 50 | (marshalPixelInternalFormat internalFormat) 51 | height 52 | return () -- TODO: Should we use the return value? 53 | 54 | -------------------------------------------------------------------------------- 55 | 56 | build2DMipmaps :: TextureTarget2D -> PixelInternalFormat -> GLsizei -> GLsizei 57 | -> PixelData a -> IO () 58 | build2DMipmaps target internalFormat width height pd = do 59 | _ <- withPixelData pd $ 60 | gluBuild2DMipmaps 61 | (marshalGettableTextureTarget target) 62 | (marshalPixelInternalFormat internalFormat) 63 | width height 64 | return () -- TODO: Should we use the return value? 65 | --------------------------------------------------------------------------------